1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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, in the case of GARLIC, for an RACW
331 -- that 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 function Specific_RPC_Receiver_Decl
562 (RACW_Type
: Entity_Id
) return Node_Id
;
563 -- Build the RPC receiver, for RACW, if applicable, else return Empty
565 procedure Specific_Build_RPC_Receiver_Body
566 (RPC_Receiver
: Entity_Id
;
567 Request
: out Entity_Id
;
568 Subp_Id
: out Entity_Id
;
569 Subp_Index
: out Entity_Id
;
572 -- Make a subprogram body for an RPC receiver, with the given
573 -- defining unit name. On return:
574 -- - Subp_Id is the subprogram identifier from the PCS.
575 -- - Subp_Index is the index in the list of subprograms
576 -- used for dispatching (a variable of type Subprogram_Id).
577 -- - Stmts is the place where the request dispatching
578 -- statements can occur,
579 -- - Decl is the subprogram body declaration.
581 function Specific_Build_Subprogram_Receiving_Stubs
583 Asynchronous
: Boolean;
584 Dynamically_Asynchronous
: Boolean := False;
585 Stub_Type
: Entity_Id
:= Empty
;
586 RACW_Type
: Entity_Id
:= Empty
;
587 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
588 -- Build the receiving stub for a given subprogram. The subprogram
589 -- declaration is also built by this procedure, and the value returned
590 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
591 -- found in the specification, then its address is read from the stream
592 -- instead of the object itself and converted into an access to
593 -- class-wide type before doing the real call using any of the RACW type
594 -- pointing on the designated type.
596 procedure Specific_Add_Obj_RPC_Receiver_Completion
599 RPC_Receiver
: Entity_Id
;
600 Stub_Elements
: Stub_Structure
);
601 -- Add the necessary code to Decls after the completion of generation
602 -- of the RACW RPC receiver described by Stub_Elements.
604 procedure Specific_Add_Receiving_Stubs_To_Declarations
608 -- Add receiving stubs to the declarative part of an RCI unit
614 package GARLIC_Support
is
616 -- Support for generating DSA code that uses the GARLIC PCS
618 -- The subprograms below provide the GARLIC versions of the
619 -- corresponding Specific_<subprogram> routine declared above.
621 procedure Add_RACW_Features
622 (RACW_Type
: Entity_Id
;
623 Stub_Type
: Entity_Id
;
624 Stub_Type_Access
: Entity_Id
;
625 RPC_Receiver_Decl
: Node_Id
;
626 Body_Decls
: List_Id
);
628 procedure Add_RAST_Features
630 RAS_Type
: Entity_Id
);
632 procedure Build_General_Calling_Stubs
634 Statements
: List_Id
;
635 Target_Partition
: Entity_Id
; -- From RPC_Target
636 Target_RPC_Receiver
: Node_Id
; -- From RPC_Target
637 Subprogram_Id
: Node_Id
;
638 Asynchronous
: Node_Id
:= Empty
;
639 Is_Known_Asynchronous
: Boolean := False;
640 Is_Known_Non_Asynchronous
: Boolean := False;
641 Is_Function
: Boolean;
643 Stub_Type
: Entity_Id
:= Empty
;
644 RACW_Type
: Entity_Id
:= Empty
;
647 function Build_Stub_Target
650 RCI_Locator
: Entity_Id
;
651 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
653 function RPC_Receiver_Decl
(RACW_Type
: Entity_Id
) return Node_Id
;
655 function Build_Subprogram_Receiving_Stubs
657 Asynchronous
: Boolean;
658 Dynamically_Asynchronous
: Boolean := False;
659 Stub_Type
: Entity_Id
:= Empty
;
660 RACW_Type
: Entity_Id
:= Empty
;
661 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
663 procedure Add_Obj_RPC_Receiver_Completion
666 RPC_Receiver
: Entity_Id
;
667 Stub_Elements
: Stub_Structure
);
669 procedure Add_Receiving_Stubs_To_Declarations
674 procedure Build_RPC_Receiver_Body
675 (RPC_Receiver
: Entity_Id
;
676 Request
: out Entity_Id
;
677 Subp_Id
: out Entity_Id
;
678 Subp_Index
: out Entity_Id
;
684 ---------------------
685 -- PolyORB_Support --
686 ---------------------
688 package PolyORB_Support
is
690 -- Support for generating DSA code that uses the PolyORB PCS
692 -- The subprograms below provide the PolyORB versions of the
693 -- corresponding Specific_<subprogram> routine declared above.
695 procedure Add_RACW_Features
696 (RACW_Type
: Entity_Id
;
698 Stub_Type
: Entity_Id
;
699 Stub_Type_Access
: Entity_Id
;
700 RPC_Receiver_Decl
: Node_Id
;
701 Body_Decls
: List_Id
);
703 procedure Add_RAST_Features
705 RAS_Type
: Entity_Id
);
707 procedure Build_General_Calling_Stubs
709 Statements
: List_Id
;
710 Target_Object
: Node_Id
; -- From RPC_Target
711 Subprogram_Id
: Node_Id
;
712 Asynchronous
: Node_Id
:= Empty
;
713 Is_Known_Asynchronous
: Boolean := False;
714 Is_Known_Non_Asynchronous
: Boolean := False;
715 Is_Function
: Boolean;
717 Stub_Type
: Entity_Id
:= Empty
;
718 RACW_Type
: Entity_Id
:= Empty
;
721 function Build_Stub_Target
724 RCI_Locator
: Entity_Id
;
725 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
727 function RPC_Receiver_Decl
(RACW_Type
: Entity_Id
) return Node_Id
;
729 function Build_Subprogram_Receiving_Stubs
731 Asynchronous
: Boolean;
732 Dynamically_Asynchronous
: Boolean := False;
733 Stub_Type
: Entity_Id
:= Empty
;
734 RACW_Type
: Entity_Id
:= Empty
;
735 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
737 procedure Add_Obj_RPC_Receiver_Completion
740 RPC_Receiver
: Entity_Id
;
741 Stub_Elements
: Stub_Structure
);
743 procedure Add_Receiving_Stubs_To_Declarations
748 procedure Build_RPC_Receiver_Body
749 (RPC_Receiver
: Entity_Id
;
750 Request
: out Entity_Id
;
751 Subp_Id
: out Entity_Id
;
752 Subp_Index
: out Entity_Id
;
756 procedure Reserve_NamingContext_Methods
;
757 -- Mark the method names for interface NamingContext as already used in
758 -- the overload table, so no clashes occur with user code (with the
759 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
760 -- their methods to be accessed as objects, for the implementation of
761 -- remote access-to-subprogram types).
769 -- Routines to build distribution helper subprograms for user-defined
770 -- types. For implementation of the Distributed systems annex (DSA)
771 -- over the PolyORB generic middleware components, it is necessary to
772 -- generate several supporting subprograms for each application data
773 -- type used in inter-partition communication. These subprograms are:
775 -- A Typecode function returning a high-level description of the
778 -- Two conversion functions allowing conversion of values of the
779 -- type from and to the generic data containers used by PolyORB.
780 -- These generic containers are called 'Any' type values after the
781 -- CORBA terminology, and hence the conversion subprograms are
782 -- named To_Any and From_Any.
784 function Build_From_Any_Call
787 Decls
: List_Id
) return Node_Id
;
788 -- Build call to From_Any attribute function of type Typ with
789 -- expression N as actual parameter. Decls is the declarations list
790 -- for an appropriate enclosing scope of the point where the call
791 -- will be inserted; if the From_Any attribute for Typ needs to be
792 -- generated at this point, its declaration is appended to Decls.
794 procedure Build_From_Any_Function
798 Fnam
: out Entity_Id
);
799 -- Build From_Any attribute function for Typ. Loc is the reference
800 -- location for generated nodes, Typ is the type for which the
801 -- conversion function is generated. On return, Decl and Fnam contain
802 -- the declaration and entity for the newly-created function.
804 function Build_To_Any_Call
807 Decls
: List_Id
) return Node_Id
;
808 -- Build call to To_Any attribute function with expression as actual
809 -- parameter. Loc is the reference location ofr generated nodes,
810 -- Decls is the declarations list for an appropriate enclosing scope
811 -- of the point where the call will be inserted; if the To_Any
812 -- attribute for the type of N needs to be generated at this point,
813 -- its declaration is appended to Decls.
815 procedure Build_To_Any_Function
819 Fnam
: out Entity_Id
);
820 -- Build To_Any attribute function for Typ. Loc is the reference
821 -- location for generated nodes, Typ is the type for which the
822 -- conversion function is generated. On return, Decl and Fnam contain
823 -- the declaration and entity for the newly-created function.
825 function Build_TypeCode_Call
828 Decls
: List_Id
) return Node_Id
;
829 -- Build call to TypeCode attribute function for Typ. Decls is the
830 -- declarations list for an appropriate enclosing scope of the point
831 -- where the call will be inserted; if the To_Any attribute for Typ
832 -- needs to be generated at this point, its declaration is appended
835 procedure Build_TypeCode_Function
839 Fnam
: out Entity_Id
);
840 -- Build TypeCode attribute function for Typ. Loc is the reference
841 -- location for generated nodes, Typ is the type for which the
842 -- typecode function is generated. On return, Decl and Fnam contain
843 -- the declaration and entity for the newly-created function.
845 procedure Build_Name_And_Repository_Id
847 Name_Str
: out String_Id
;
848 Repo_Id_Str
: out String_Id
);
849 -- In the PolyORB distribution model, each distributed object type
850 -- and each distributed operation has a globally unique identifier,
851 -- its Repository Id. This subprogram builds and returns two strings
852 -- for entity E (a distributed object type or operation): one
853 -- containing the name of E, the second containing its repository id.
855 procedure Assign_Opaque_From_Any
861 -- For a Target object of type Typ, which has opaque representation
862 -- as a sequence of octets determined by stream attributes (which
863 -- includes all limited types), append code to Stmts performing the
865 -- Target := Typ'From_Any (N)
867 -- or, if Target is Empty:
868 -- return Typ'From_Any (N)
874 -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
876 function Build_From_Any_Call
879 Decls
: List_Id
) return Node_Id
880 renames PolyORB_Support
.Helpers
.Build_From_Any_Call
;
882 function Build_To_Any_Call
885 Decls
: List_Id
) return Node_Id
886 renames PolyORB_Support
.Helpers
.Build_To_Any_Call
;
888 function Build_TypeCode_Call
891 Decls
: List_Id
) return Node_Id
892 renames PolyORB_Support
.Helpers
.Build_TypeCode_Call
;
894 ------------------------------------
895 -- Local variables and structures --
896 ------------------------------------
899 -- Needs comments ???
901 Output_From_Constrained
: constant array (Boolean) of Name_Id
:=
902 (False => Name_Output
,
904 -- The attribute to choose depending on the fact that the parameter
905 -- is constrained or not. There is no such thing as Input_From_Constrained
906 -- since this require separate mechanisms ('Input is a function while
907 -- 'Read is a procedure).
910 with procedure Process_Subprogram_Declaration
(Decl
: Node_Id
);
911 -- Generate calling or receiving stub for this subprogram declaration
913 procedure Build_Package_Stubs
(Pkg_Spec
: Node_Id
);
914 -- Recursively visit the given RCI Package_Specification, calling
915 -- Process_Subprogram_Declaration for each remote subprogram.
917 -------------------------
918 -- Build_Package_Stubs --
919 -------------------------
921 procedure Build_Package_Stubs
(Pkg_Spec
: Node_Id
) is
922 Decls
: constant List_Id
:= Visible_Declarations
(Pkg_Spec
);
925 procedure Visit_Nested_Pkg
(Nested_Pkg_Decl
: Node_Id
);
926 -- Recurse for the given nested package declaration
928 -----------------------
929 -- Visit_Nested_Spec --
930 -----------------------
932 procedure Visit_Nested_Pkg
(Nested_Pkg_Decl
: Node_Id
) is
933 Nested_Pkg_Spec
: constant Node_Id
:= Specification
(Nested_Pkg_Decl
);
935 Push_Scope
(Scope_Of_Spec
(Nested_Pkg_Spec
));
936 Build_Package_Stubs
(Nested_Pkg_Spec
);
938 end Visit_Nested_Pkg
;
940 -- Start of processing for Build_Package_Stubs
943 Decl
:= First
(Decls
);
944 while Present
(Decl
) loop
946 when N_Subprogram_Declaration
=>
948 -- Note: we test Comes_From_Source on Spec, not Decl, because
949 -- in the case of a subprogram instance, only the specification
950 -- (not the declaration) is marked as coming from source.
952 if Comes_From_Source
(Specification
(Decl
)) then
953 Process_Subprogram_Declaration
(Decl
);
956 when N_Package_Declaration
=>
958 -- Case of a nested package or package instantiation coming
959 -- from source. Note that the anonymous wrapper package for
960 -- subprogram instances is not flagged Is_Generic_Instance at
961 -- this point, so there is a distinct circuit to handle them
962 -- (see case N_Subprogram_Instantiation below).
965 Pkg_Ent
: constant Entity_Id
:=
966 Defining_Unit_Name
(Specification
(Decl
));
968 if Comes_From_Source
(Decl
)
970 (Is_Generic_Instance
(Pkg_Ent
)
971 and then Comes_From_Source
972 (Get_Package_Instantiation_Node
(Pkg_Ent
)))
974 Visit_Nested_Pkg
(Decl
);
978 when N_Subprogram_Instantiation
=>
980 -- The subprogram declaration for an instance of a generic
981 -- subprogram is wrapped in a package that does not come from
982 -- source, so we need to explicitly traverse it here.
984 if Comes_From_Source
(Decl
) then
985 Visit_Nested_Pkg
(Instance_Spec
(Decl
));
993 end Build_Package_Stubs
;
995 ---------------------------------------
996 -- Add_Calling_Stubs_To_Declarations --
997 ---------------------------------------
999 procedure Add_Calling_Stubs_To_Declarations
(Pkg_Spec
: Node_Id
) is
1000 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
1002 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
1003 -- Subprogram id 0 is reserved for calls received from
1004 -- remote access-to-subprogram dereferences.
1006 RCI_Instantiation
: Node_Id
;
1008 procedure Visit_Subprogram
(Decl
: Node_Id
);
1009 -- Generate calling stub for one remote subprogram
1011 ----------------------
1012 -- Visit_Subprogram --
1013 ----------------------
1015 procedure Visit_Subprogram
(Decl
: Node_Id
) is
1016 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
1017 Spec
: constant Node_Id
:= Specification
(Decl
);
1018 Subp_Stubs
: Node_Id
;
1020 Subp_Str
: String_Id
;
1021 pragma Warnings
(Off
, Subp_Str
);
1024 -- Disable expansion of stubs if serious errors have been diagnosed,
1025 -- because otherwise some illegal remote subprogram declarations
1026 -- could cause cascaded errors in stubs.
1028 if Serious_Errors_Detected
/= 0 then
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_Decl
: Node_Id
;
1971 Stub_Type_Access_Decl
: Node_Id
;
1974 if Stub_Elements
/= Empty_Stub_Structure
then
1975 Stub_Type
:= Stub_Elements
.Stub_Type
;
1976 Stub_Type_Access
:= Stub_Elements
.Stub_Type_Access
;
1977 RPC_Receiver_Decl
:= Stub_Elements
.RPC_Receiver_Decl
;
1978 Body_Decls
:= Stub_Elements
.Body_Decls
;
1984 Stub_Type
:= Make_Temporary
(Loc
, 'S');
1985 Set_Ekind
(Stub_Type
, E_Record_Type
);
1986 Set_Is_RACW_Stub_Type
(Stub_Type
);
1988 Make_Defining_Identifier
(Loc
,
1989 Chars
=> New_External_Name
1990 (Related_Id
=> Chars
(Stub_Type
), Suffix
=> 'A'));
1992 RPC_Receiver_Decl
:= Specific_RPC_Receiver_Decl
(RACW_Type
);
1994 -- Create new stub type, copying components from generic RACW_Stub_Type
1997 Make_Full_Type_Declaration
(Loc
,
1998 Defining_Identifier
=> Stub_Type
,
2000 Make_Record_Definition
(Loc
,
2001 Tagged_Present
=> True,
2002 Limited_Present
=> True,
2004 Make_Component_List
(Loc
,
2006 Copy_Component_List
(RTE
(RE_RACW_Stub_Type
), Loc
))));
2008 -- Does the stub type need to explicitly implement interfaces from the
2009 -- designated type???
2011 -- In particular are there issues in the case where the designated type
2012 -- is a synchronized interface???
2014 Stub_Type_Access_Decl
:=
2015 Make_Full_Type_Declaration
(Loc
,
2016 Defining_Identifier
=> Stub_Type_Access
,
2018 Make_Access_To_Object_Definition
(Loc
,
2019 All_Present
=> True,
2020 Subtype_Indication
=> New_Occurrence_Of
(Stub_Type
, Loc
)));
2022 Append_To
(Decls
, Stub_Type_Decl
);
2023 Analyze
(Last
(Decls
));
2024 Append_To
(Decls
, Stub_Type_Access_Decl
);
2025 Analyze
(Last
(Decls
));
2027 -- We can't directly derive the stub type from the designated type,
2028 -- because we don't want any components or discriminants from the real
2029 -- type, so instead we manually fake a derivation to get an appropriate
2032 Derive_Subprograms
(Parent_Type
=> Designated_Type
,
2033 Derived_Type
=> Stub_Type
);
2035 if Present
(RPC_Receiver_Decl
) then
2036 Append_To
(Decls
, RPC_Receiver_Decl
);
2039 -- Kludge, requires comment???
2041 RPC_Receiver_Decl
:= Last
(Decls
);
2044 Body_Decls
:= New_List
;
2046 Stubs_Table
.Set
(Designated_Type
,
2047 (Stub_Type
=> Stub_Type
,
2048 Stub_Type_Access
=> Stub_Type_Access
,
2049 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
2050 Body_Decls
=> Body_Decls
,
2051 RACW_Type
=> RACW_Type
));
2054 ------------------------
2055 -- Append_RACW_Bodies --
2056 ------------------------
2058 procedure Append_RACW_Bodies
(Decls
: List_Id
; Spec_Id
: Entity_Id
) is
2062 E
:= First_Entity
(Spec_Id
);
2063 while Present
(E
) loop
2064 if Is_Remote_Access_To_Class_Wide_Type
(E
) then
2065 Append_List_To
(Decls
, Get_And_Reset_RACW_Bodies
(E
));
2070 end Append_RACW_Bodies
;
2072 ----------------------------------
2073 -- Assign_Subprogram_Identifier --
2074 ----------------------------------
2076 procedure Assign_Subprogram_Identifier
2081 N
: constant Name_Id
:= Chars
(Def
);
2083 Overload_Order
: constant Int
:= Overload_Counter_Table
.Get
(N
) + 1;
2086 Overload_Counter_Table
.Set
(N
, Overload_Order
);
2088 Get_Name_String
(N
);
2090 -- Homonym handling: as in Exp_Dbug, but much simpler, because the only
2091 -- entities for which we have to generate names here need only to be
2092 -- disambiguated within their own scope.
2094 if Overload_Order
> 1 then
2095 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 2) := "__";
2096 Name_Len
:= Name_Len
+ 2;
2097 Add_Nat_To_Name_Buffer
(Overload_Order
);
2100 Id
:= String_From_Name_Buffer
;
2101 Subprogram_Identifier_Table
.Set
2103 Subprogram_Identifiers
'(Str_Identifier => Id, Int_Identifier => Spn));
2104 end Assign_Subprogram_Identifier;
2106 -------------------------------------
2107 -- Build_Actual_Object_Declaration --
2108 -------------------------------------
2110 procedure Build_Actual_Object_Declaration
2111 (Object : Entity_Id;
2117 Loc : constant Source_Ptr := Sloc (Object);
2120 -- Declare a temporary object for the actual, possibly initialized with
2121 -- a 'Input
/From_Any call
.
2123 -- Complication arises in the case of limited types, for which such a
2124 -- declaration is illegal in Ada 95. In that case, we first generate a
2125 -- renaming declaration of the 'Input call, and then if needed we
2126 -- generate an overlaid non-constant view.
2128 if Ada_Version
<= Ada_95
2129 and then Is_Limited_Type
(Etyp
)
2130 and then Present
(Expr
)
2133 -- Object : Etyp renames <func-call>
2136 Make_Object_Renaming_Declaration
(Loc
,
2137 Defining_Identifier
=> Object
,
2138 Subtype_Mark
=> New_Occurrence_Of
(Etyp
, Loc
),
2143 -- The name defined by the renaming declaration denotes a
2144 -- constant view; create a non-constant object at the same address
2145 -- to be used as the actual.
2148 Constant_Object
: constant Entity_Id
:=
2149 Make_Temporary
(Loc
, 'P');
2152 Set_Defining_Identifier
2153 (Last
(Decls
), Constant_Object
);
2155 -- We have an unconstrained Etyp: build the actual constrained
2156 -- subtype for the value we just read from the stream.
2158 -- subtype S is <actual subtype of Constant_Object>;
2161 Build_Actual_Subtype
(Etyp
,
2162 New_Occurrence_Of
(Constant_Object
, Loc
)));
2167 Make_Object_Declaration
(Loc
,
2168 Defining_Identifier
=> Object
,
2169 Object_Definition
=>
2171 (Defining_Identifier
(Last
(Decls
)), Loc
)));
2172 Set_Ekind
(Object
, E_Variable
);
2174 -- Suppress default initialization:
2175 -- pragma Import (Ada, Object);
2179 Chars
=> Name_Import
,
2180 Pragma_Argument_Associations
=> New_List
(
2181 Make_Pragma_Argument_Association
(Loc
,
2182 Chars
=> Name_Convention
,
2183 Expression
=> Make_Identifier
(Loc
, Name_Ada
)),
2184 Make_Pragma_Argument_Association
(Loc
,
2185 Chars
=> Name_Entity
,
2186 Expression
=> New_Occurrence_Of
(Object
, Loc
)))));
2188 -- for Object'Address use Constant_Object'Address;
2191 Make_Attribute_Definition_Clause
(Loc
,
2192 Name
=> New_Occurrence_Of
(Object
, Loc
),
2193 Chars
=> Name_Address
,
2195 Make_Attribute_Reference
(Loc
,
2196 Prefix
=> New_Occurrence_Of
(Constant_Object
, Loc
),
2197 Attribute_Name
=> Name_Address
)));
2202 -- General case of a regular object declaration. Object is flagged
2203 -- constant unless it has mode out or in out, to allow the backend
2204 -- to optimize where possible.
2206 -- Object : [constant] Etyp [:= <expr>];
2209 Make_Object_Declaration
(Loc
,
2210 Defining_Identifier
=> Object
,
2211 Constant_Present
=> Present
(Expr
) and then not Variable
,
2212 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
2213 Expression
=> Expr
));
2215 if Constant_Present
(Last
(Decls
)) then
2216 Set_Ekind
(Object
, E_Constant
);
2218 Set_Ekind
(Object
, E_Variable
);
2221 end Build_Actual_Object_Declaration
;
2223 ------------------------------
2224 -- Build_Get_Unique_RP_Call --
2225 ------------------------------
2227 function Build_Get_Unique_RP_Call
2229 Pointer
: Entity_Id
;
2230 Stub_Type
: Entity_Id
) return List_Id
2234 Make_Procedure_Call_Statement
(Loc
,
2236 New_Occurrence_Of
(RTE
(RE_Get_Unique_Remote_Pointer
), Loc
),
2237 Parameter_Associations
=> New_List
(
2238 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2239 New_Occurrence_Of
(Pointer
, Loc
)))),
2241 Make_Assignment_Statement
(Loc
,
2243 Make_Selected_Component
(Loc
,
2244 Prefix
=> New_Occurrence_Of
(Pointer
, Loc
),
2246 New_Occurrence_Of
(First_Tag_Component
2247 (Designated_Type
(Etype
(Pointer
))), Loc
)),
2249 Make_Attribute_Reference
(Loc
,
2250 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
2251 Attribute_Name
=> Name_Tag
)));
2253 -- Note: The assignment to Pointer._Tag is safe here because
2254 -- we carefully ensured that Stub_Type has exactly the same layout
2255 -- as System.Partition_Interface.RACW_Stub_Type.
2257 end Build_Get_Unique_RP_Call
;
2259 -----------------------------------
2260 -- Build_Ordered_Parameters_List --
2261 -----------------------------------
2263 function Build_Ordered_Parameters_List
(Spec
: Node_Id
) return List_Id
is
2264 Constrained_List
: List_Id
;
2265 Unconstrained_List
: List_Id
;
2266 Current_Parameter
: Node_Id
;
2269 First_Parameter
: Node_Id
;
2270 For_RAS
: Boolean := False;
2273 if No
(Parameter_Specifications
(Spec
)) then
2277 Constrained_List
:= New_List
;
2278 Unconstrained_List
:= New_List
;
2279 First_Parameter
:= First
(Parameter_Specifications
(Spec
));
2281 if Nkind
(Parameter_Type
(First_Parameter
)) = N_Access_Definition
2282 and then Chars
(Defining_Identifier
(First_Parameter
)) = Name_uS
2287 -- Loop through the parameters and add them to the right list. Note that
2288 -- we treat a parameter of a null-excluding access type as unconstrained
2289 -- because we can't declare an object of such a type with default
2292 Current_Parameter
:= First_Parameter
;
2293 while Present
(Current_Parameter
) loop
2294 Ptyp
:= Parameter_Type
(Current_Parameter
);
2296 if (Nkind
(Ptyp
) = N_Access_Definition
2297 or else not Transmit_As_Unconstrained
(Etype
(Ptyp
)))
2298 and then not (For_RAS
and then Current_Parameter
= First_Parameter
)
2300 Append_To
(Constrained_List
, New_Copy
(Current_Parameter
));
2302 Append_To
(Unconstrained_List
, New_Copy
(Current_Parameter
));
2305 Next
(Current_Parameter
);
2308 -- Unconstrained parameters are returned first
2310 Append_List_To
(Unconstrained_List
, Constrained_List
);
2312 return Unconstrained_List
;
2313 end Build_Ordered_Parameters_List
;
2315 ----------------------------------
2316 -- Build_Passive_Partition_Stub --
2317 ----------------------------------
2319 procedure Build_Passive_Partition_Stub
(U
: Node_Id
) is
2321 Pkg_Ent
: Entity_Id
;
2324 Loc
: constant Source_Ptr
:= Sloc
(U
);
2327 -- Verify that the implementation supports distribution, by accessing
2328 -- a type defined in the proper version of system.rpc
2331 Dist_OK
: Entity_Id
;
2332 pragma Warnings
(Off
, Dist_OK
);
2334 Dist_OK
:= RTE
(RE_Params_Stream_Type
);
2337 -- Use body if present, spec otherwise
2339 if Nkind
(U
) = N_Package_Declaration
then
2340 Pkg_Spec
:= Specification
(U
);
2341 L
:= Visible_Declarations
(Pkg_Spec
);
2343 Pkg_Spec
:= Parent
(Corresponding_Spec
(U
));
2344 L
:= Declarations
(U
);
2346 Pkg_Ent
:= Defining_Entity
(Pkg_Spec
);
2349 Make_Procedure_Call_Statement
(Loc
,
2351 New_Occurrence_Of
(RTE
(RE_Register_Passive_Package
), Loc
),
2352 Parameter_Associations
=> New_List
(
2353 Make_String_Literal
(Loc
,
2354 Fully_Qualified_Name_String
(Pkg_Ent
, Append_NUL
=> False)),
2355 Make_Attribute_Reference
(Loc
,
2356 Prefix
=> New_Occurrence_Of
(Pkg_Ent
, Loc
),
2357 Attribute_Name
=> Name_Version
)));
2360 end Build_Passive_Partition_Stub
;
2362 --------------------------------------
2363 -- Build_RPC_Receiver_Specification --
2364 --------------------------------------
2366 function Build_RPC_Receiver_Specification
2367 (RPC_Receiver
: Entity_Id
;
2368 Request_Parameter
: Entity_Id
) return Node_Id
2370 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
2373 Make_Procedure_Specification
(Loc
,
2374 Defining_Unit_Name
=> RPC_Receiver
,
2375 Parameter_Specifications
=> New_List
(
2376 Make_Parameter_Specification
(Loc
,
2377 Defining_Identifier
=> Request_Parameter
,
2379 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
2380 end Build_RPC_Receiver_Specification
;
2382 ----------------------------------------
2383 -- Build_Remote_Subprogram_Proxy_Type --
2384 ----------------------------------------
2386 function Build_Remote_Subprogram_Proxy_Type
2388 ACR_Expression
: Node_Id
) return Node_Id
2392 Make_Record_Definition
(Loc
,
2393 Tagged_Present
=> True,
2394 Limited_Present
=> True,
2396 Make_Component_List
(Loc
,
2397 Component_Items
=> New_List
(
2398 Make_Component_Declaration
(Loc
,
2399 Defining_Identifier
=>
2400 Make_Defining_Identifier
(Loc
,
2401 Name_All_Calls_Remote
),
2402 Component_Definition
=>
2403 Make_Component_Definition
(Loc
,
2404 Subtype_Indication
=>
2405 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
2409 Make_Component_Declaration
(Loc
,
2410 Defining_Identifier
=>
2411 Make_Defining_Identifier
(Loc
,
2413 Component_Definition
=>
2414 Make_Component_Definition
(Loc
,
2415 Subtype_Indication
=>
2416 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2418 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)),
2420 Make_Component_Declaration
(Loc
,
2421 Defining_Identifier
=>
2422 Make_Defining_Identifier
(Loc
,
2424 Component_Definition
=>
2425 Make_Component_Definition
(Loc
,
2426 Subtype_Indication
=>
2427 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))))));
2428 end Build_Remote_Subprogram_Proxy_Type
;
2430 --------------------
2431 -- Build_Stub_Tag --
2432 --------------------
2434 function Build_Stub_Tag
2436 RACW_Type
: Entity_Id
) return Node_Id
2438 Stub_Type
: constant Entity_Id
:= Corresponding_Stub_Type
(RACW_Type
);
2441 Make_Attribute_Reference
(Loc
,
2442 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
2443 Attribute_Name
=> Name_Tag
);
2446 ------------------------------------
2447 -- Build_Subprogram_Calling_Stubs --
2448 ------------------------------------
2450 function Build_Subprogram_Calling_Stubs
2451 (Vis_Decl
: Node_Id
;
2453 Asynchronous
: Boolean;
2454 Dynamically_Asynchronous
: Boolean := False;
2455 Stub_Type
: Entity_Id
:= Empty
;
2456 RACW_Type
: Entity_Id
:= Empty
;
2457 Locator
: Entity_Id
:= Empty
;
2458 New_Name
: Name_Id
:= No_Name
) return Node_Id
2460 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
2462 Decls
: constant List_Id
:= New_List
;
2463 Statements
: constant List_Id
:= New_List
;
2465 Subp_Spec
: Node_Id
;
2466 -- The specification of the body
2468 Controlling_Parameter
: Entity_Id
:= Empty
;
2470 Asynchronous_Expr
: Node_Id
:= Empty
;
2472 RCI_Locator
: Entity_Id
;
2474 Spec_To_Use
: Node_Id
;
2476 procedure Insert_Partition_Check
(Parameter
: Node_Id
);
2477 -- Check that the parameter has been elaborated on the same partition
2478 -- than the controlling parameter (E.4(19)).
2480 ----------------------------
2481 -- Insert_Partition_Check --
2482 ----------------------------
2484 procedure Insert_Partition_Check
(Parameter
: Node_Id
) is
2485 Parameter_Entity
: constant Entity_Id
:=
2486 Defining_Identifier
(Parameter
);
2488 -- The expression that will be built is of the form:
2490 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2491 -- raise Constraint_Error;
2494 -- We do not check that Parameter is in Stub_Type since such a check
2495 -- has been inserted at the point of call already (a tag check since
2496 -- we have multiple controlling operands).
2499 Make_Raise_Constraint_Error
(Loc
,
2503 Make_Function_Call
(Loc
,
2505 New_Occurrence_Of
(RTE
(RE_Same_Partition
), Loc
),
2506 Parameter_Associations
=>
2508 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2509 New_Occurrence_Of
(Parameter_Entity
, Loc
)),
2510 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2511 New_Occurrence_Of
(Controlling_Parameter
, Loc
))))),
2512 Reason
=> CE_Partition_Check_Failed
));
2513 end Insert_Partition_Check
;
2515 -- Start of processing for Build_Subprogram_Calling_Stubs
2519 Copy_Specification
(Loc
,
2520 Spec
=> Specification
(Vis_Decl
),
2521 New_Name
=> New_Name
);
2523 if Locator
= Empty
then
2524 RCI_Locator
:= RCI_Cache
;
2525 Spec_To_Use
:= Specification
(Vis_Decl
);
2527 RCI_Locator
:= Locator
;
2528 Spec_To_Use
:= Subp_Spec
;
2531 -- Find a controlling argument if we have a stub type. Also check
2532 -- if this subprogram can be made asynchronous.
2534 if Present
(Stub_Type
)
2535 and then Present
(Parameter_Specifications
(Spec_To_Use
))
2538 Current_Parameter
: Node_Id
:=
2539 First
(Parameter_Specifications
2542 while Present
(Current_Parameter
) loop
2544 Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
)
2546 if Controlling_Parameter
= Empty
then
2547 Controlling_Parameter
:=
2548 Defining_Identifier
(Current_Parameter
);
2550 Insert_Partition_Check
(Current_Parameter
);
2554 Next
(Current_Parameter
);
2559 pragma Assert
(No
(Stub_Type
) or else Present
(Controlling_Parameter
));
2561 if Dynamically_Asynchronous
then
2562 Asynchronous_Expr
:= Make_Selected_Component
(Loc
,
2563 Prefix
=> Controlling_Parameter
,
2564 Selector_Name
=> Name_Asynchronous
);
2567 Specific_Build_General_Calling_Stubs
2569 Statements
=> Statements
,
2570 Target
=> Specific_Build_Stub_Target
(Loc
,
2571 Decls
, RCI_Locator
, Controlling_Parameter
),
2572 Subprogram_Id
=> Subp_Id
,
2573 Asynchronous
=> Asynchronous_Expr
,
2574 Is_Known_Asynchronous
=> Asynchronous
2575 and then not Dynamically_Asynchronous
,
2576 Is_Known_Non_Asynchronous
2578 and then not Dynamically_Asynchronous
,
2579 Is_Function
=> Nkind
(Spec_To_Use
) =
2580 N_Function_Specification
,
2581 Spec
=> Spec_To_Use
,
2582 Stub_Type
=> Stub_Type
,
2583 RACW_Type
=> RACW_Type
,
2586 RCI_Calling_Stubs_Table
.Set
2587 (Defining_Unit_Name
(Specification
(Vis_Decl
)),
2588 Defining_Unit_Name
(Spec_To_Use
));
2591 Make_Subprogram_Body
(Loc
,
2592 Specification
=> Subp_Spec
,
2593 Declarations
=> Decls
,
2594 Handled_Statement_Sequence
=>
2595 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
));
2596 end Build_Subprogram_Calling_Stubs
;
2598 -------------------------
2599 -- Build_Subprogram_Id --
2600 -------------------------
2602 function Build_Subprogram_Id
2604 E
: Entity_Id
) return Node_Id
2607 if Get_Subprogram_Ids
(E
).Str_Identifier
= No_String
then
2609 Current_Declaration
: Node_Id
;
2610 Current_Subp
: Entity_Id
;
2611 Current_Subp_Str
: String_Id
;
2612 Current_Subp_Number
: Int
:= First_RCI_Subprogram_Id
;
2614 pragma Warnings
(Off
, Current_Subp_Str
);
2617 -- Build_Subprogram_Id is called outside of the context of
2618 -- generating calling or receiving stubs. Hence we are processing
2619 -- an 'Access attribute_reference for an RCI subprogram, for the
2620 -- purpose of obtaining a RAS value.
2623 (Is_Remote_Call_Interface
(Scope
(E
))
2625 (Nkind
(Parent
(E
)) = N_Procedure_Specification
2627 Nkind
(Parent
(E
)) = N_Function_Specification
));
2629 Current_Declaration
:=
2630 First
(Visible_Declarations
2631 (Package_Specification_Of_Scope
(Scope
(E
))));
2632 while Present
(Current_Declaration
) loop
2633 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
2634 and then Comes_From_Source
(Current_Declaration
)
2636 Current_Subp
:= Defining_Unit_Name
(Specification
(
2637 Current_Declaration
));
2639 Assign_Subprogram_Identifier
2640 (Current_Subp
, Current_Subp_Number
, Current_Subp_Str
);
2642 Current_Subp_Number
:= Current_Subp_Number
+ 1;
2645 Next
(Current_Declaration
);
2650 case Get_PCS_Name
is
2651 when Name_PolyORB_DSA
=>
2652 return Make_String_Literal
(Loc
, Get_Subprogram_Id
(E
));
2654 return Make_Integer_Literal
(Loc
, Get_Subprogram_Id
(E
));
2656 end Build_Subprogram_Id
;
2658 ------------------------
2659 -- Copy_Specification --
2660 ------------------------
2662 function Copy_Specification
2665 Ctrl_Type
: Entity_Id
:= Empty
;
2666 New_Name
: Name_Id
:= No_Name
) return Node_Id
2668 Parameters
: List_Id
:= No_List
;
2670 Current_Parameter
: Node_Id
;
2671 Current_Identifier
: Entity_Id
;
2672 Current_Type
: Node_Id
;
2674 Name_For_New_Spec
: Name_Id
;
2676 New_Identifier
: Entity_Id
;
2678 -- Comments needed in body below ???
2681 if New_Name
= No_Name
then
2682 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
2683 or else Nkind
(Spec
) = N_Procedure_Specification
);
2685 Name_For_New_Spec
:= Chars
(Defining_Unit_Name
(Spec
));
2687 Name_For_New_Spec
:= New_Name
;
2690 if Present
(Parameter_Specifications
(Spec
)) then
2691 Parameters
:= New_List
;
2692 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2693 while Present
(Current_Parameter
) loop
2694 Current_Identifier
:= Defining_Identifier
(Current_Parameter
);
2695 Current_Type
:= Parameter_Type
(Current_Parameter
);
2697 if Nkind
(Current_Type
) = N_Access_Definition
then
2698 if Present
(Ctrl_Type
) then
2699 pragma Assert
(Is_Controlling_Formal
(Current_Identifier
));
2701 Make_Access_Definition
(Loc
,
2702 Subtype_Mark
=> New_Occurrence_Of
(Ctrl_Type
, Loc
),
2703 Null_Exclusion_Present
=>
2704 Null_Exclusion_Present
(Current_Type
));
2708 Make_Access_Definition
(Loc
,
2710 New_Copy_Tree
(Subtype_Mark
(Current_Type
)),
2711 Null_Exclusion_Present
=>
2712 Null_Exclusion_Present
(Current_Type
));
2716 if Present
(Ctrl_Type
)
2717 and then Is_Controlling_Formal
(Current_Identifier
)
2719 Current_Type
:= New_Occurrence_Of
(Ctrl_Type
, Loc
);
2721 Current_Type
:= New_Copy_Tree
(Current_Type
);
2725 New_Identifier
:= Make_Defining_Identifier
(Loc
,
2726 Chars
(Current_Identifier
));
2728 Append_To
(Parameters
,
2729 Make_Parameter_Specification
(Loc
,
2730 Defining_Identifier
=> New_Identifier
,
2731 Parameter_Type
=> Current_Type
,
2732 In_Present
=> In_Present
(Current_Parameter
),
2733 Out_Present
=> Out_Present
(Current_Parameter
),
2735 New_Copy_Tree
(Expression
(Current_Parameter
))));
2737 -- For a regular formal parameter (that needs to be marshalled
2738 -- in the context of remote calls), set the Etype now, because
2739 -- marshalling processing might need it.
2741 if Is_Entity_Name
(Current_Type
) then
2742 Set_Etype
(New_Identifier
, Entity
(Current_Type
));
2744 -- Current_Type is an access definition, special processing
2745 -- (not requiring etype) will occur for marshalling.
2751 Next
(Current_Parameter
);
2755 case Nkind
(Spec
) is
2757 when N_Function_Specification | N_Access_Function_Definition
=>
2759 Make_Function_Specification
(Loc
,
2760 Defining_Unit_Name
=>
2761 Make_Defining_Identifier
(Loc
,
2762 Chars
=> Name_For_New_Spec
),
2763 Parameter_Specifications
=> Parameters
,
2764 Result_Definition
=>
2765 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
2767 when N_Procedure_Specification | N_Access_Procedure_Definition
=>
2769 Make_Procedure_Specification
(Loc
,
2770 Defining_Unit_Name
=>
2771 Make_Defining_Identifier
(Loc
,
2772 Chars
=> Name_For_New_Spec
),
2773 Parameter_Specifications
=> Parameters
);
2776 raise Program_Error
;
2778 end Copy_Specification
;
2780 -----------------------------
2781 -- Corresponding_Stub_Type --
2782 -----------------------------
2784 function Corresponding_Stub_Type
(RACW_Type
: Entity_Id
) return Entity_Id
is
2785 Desig
: constant Entity_Id
:=
2786 Etype
(Designated_Type
(RACW_Type
));
2787 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
2789 return Stub_Elements
.Stub_Type
;
2790 end Corresponding_Stub_Type
;
2792 ---------------------------
2793 -- Could_Be_Asynchronous --
2794 ---------------------------
2796 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean is
2797 Current_Parameter
: Node_Id
;
2800 if Present
(Parameter_Specifications
(Spec
)) then
2801 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2802 while Present
(Current_Parameter
) loop
2803 if Out_Present
(Current_Parameter
) then
2807 Next
(Current_Parameter
);
2812 end Could_Be_Asynchronous
;
2814 ---------------------------
2815 -- Declare_Create_NVList --
2816 ---------------------------
2818 procedure Declare_Create_NVList
2826 Make_Object_Declaration
(Loc
,
2827 Defining_Identifier
=> NVList
,
2828 Aliased_Present
=> False,
2829 Object_Definition
=>
2830 New_Occurrence_Of
(RTE
(RE_NVList_Ref
), Loc
)));
2833 Make_Procedure_Call_Statement
(Loc
,
2834 Name
=> New_Occurrence_Of
(RTE
(RE_NVList_Create
), Loc
),
2835 Parameter_Associations
=> New_List
(
2836 New_Occurrence_Of
(NVList
, Loc
))));
2837 end Declare_Create_NVList
;
2839 ---------------------------------------------
2840 -- Expand_All_Calls_Remote_Subprogram_Call --
2841 ---------------------------------------------
2843 procedure Expand_All_Calls_Remote_Subprogram_Call
(N
: Node_Id
) is
2844 Loc
: constant Source_Ptr
:= Sloc
(N
);
2845 Called_Subprogram
: constant Entity_Id
:= Entity
(Name
(N
));
2846 RCI_Package
: constant Entity_Id
:= Scope
(Called_Subprogram
);
2847 RCI_Locator_Decl
: Node_Id
;
2848 RCI_Locator
: Entity_Id
;
2849 Calling_Stubs
: Node_Id
;
2850 E_Calling_Stubs
: Entity_Id
;
2853 E_Calling_Stubs
:= RCI_Calling_Stubs_Table
.Get
(Called_Subprogram
);
2855 if E_Calling_Stubs
= Empty
then
2856 RCI_Locator
:= RCI_Locator_Table
.Get
(RCI_Package
);
2858 -- The RCI_Locator package and calling stub are is inserted at the
2859 -- top level in the current unit, and must appear in the proper scope
2860 -- so that it is not prematurely removed by the GCC back end.
2863 Scop
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
2865 if Ekind
(Scop
) = E_Package_Body
then
2866 Push_Scope
(Spec_Entity
(Scop
));
2867 elsif Ekind
(Scop
) = E_Subprogram_Body
then
2869 (Corresponding_Spec
(Unit_Declaration_Node
(Scop
)));
2875 if RCI_Locator
= Empty
then
2878 (Loc
, Specification
(Unit_Declaration_Node
(RCI_Package
)));
2879 Prepend_To
(Current_Sem_Unit_Declarations
, RCI_Locator_Decl
);
2880 Analyze
(RCI_Locator_Decl
);
2881 RCI_Locator
:= Defining_Unit_Name
(RCI_Locator_Decl
);
2884 RCI_Locator_Decl
:= Parent
(RCI_Locator
);
2887 Calling_Stubs
:= Build_Subprogram_Calling_Stubs
2888 (Vis_Decl
=> Parent
(Parent
(Called_Subprogram
)),
2890 Build_Subprogram_Id
(Loc
, Called_Subprogram
),
2891 Asynchronous
=> Nkind
(N
) = N_Procedure_Call_Statement
2893 Is_Asynchronous
(Called_Subprogram
),
2894 Locator
=> RCI_Locator
,
2895 New_Name
=> New_Internal_Name
('S'));
2896 Insert_After
(RCI_Locator_Decl
, Calling_Stubs
);
2897 Analyze
(Calling_Stubs
);
2900 E_Calling_Stubs
:= Defining_Unit_Name
(Specification
(Calling_Stubs
));
2903 Rewrite
(Name
(N
), New_Occurrence_Of
(E_Calling_Stubs
, Loc
));
2904 end Expand_All_Calls_Remote_Subprogram_Call
;
2906 ---------------------------------
2907 -- Expand_Calling_Stubs_Bodies --
2908 ---------------------------------
2910 procedure Expand_Calling_Stubs_Bodies
(Unit_Node
: Node_Id
) is
2911 Spec
: constant Node_Id
:= Specification
(Unit_Node
);
2913 Add_Calling_Stubs_To_Declarations
(Spec
);
2914 end Expand_Calling_Stubs_Bodies
;
2916 -----------------------------------
2917 -- Expand_Receiving_Stubs_Bodies --
2918 -----------------------------------
2920 procedure Expand_Receiving_Stubs_Bodies
(Unit_Node
: Node_Id
) is
2923 Stubs_Decls
: List_Id
;
2924 Stubs_Stmts
: List_Id
;
2927 if Nkind
(Unit_Node
) = N_Package_Declaration
then
2928 Spec
:= Specification
(Unit_Node
);
2929 Decls
:= Private_Declarations
(Spec
);
2932 Decls
:= Visible_Declarations
(Spec
);
2935 Push_Scope
(Scope_Of_Spec
(Spec
));
2936 Specific_Add_Receiving_Stubs_To_Declarations
(Spec
, Decls
, Decls
);
2940 Package_Specification_Of_Scope
(Corresponding_Spec
(Unit_Node
));
2941 Decls
:= Declarations
(Unit_Node
);
2943 Push_Scope
(Scope_Of_Spec
(Unit_Node
));
2944 Stubs_Decls
:= New_List
;
2945 Stubs_Stmts
:= New_List
;
2946 Specific_Add_Receiving_Stubs_To_Declarations
2947 (Spec
, Stubs_Decls
, Stubs_Stmts
);
2949 Insert_List_Before
(First
(Decls
), Stubs_Decls
);
2952 HSS_Stmts
: constant List_Id
:=
2953 Statements
(Handled_Statement_Sequence
(Unit_Node
));
2955 First_HSS_Stmt
: constant Node_Id
:= First
(HSS_Stmts
);
2958 if No
(First_HSS_Stmt
) then
2959 Append_List_To
(HSS_Stmts
, Stubs_Stmts
);
2961 Insert_List_Before
(First_HSS_Stmt
, Stubs_Stmts
);
2967 end Expand_Receiving_Stubs_Bodies
;
2969 --------------------
2970 -- GARLIC_Support --
2971 --------------------
2973 package body GARLIC_Support
is
2975 -- Local subprograms
2977 procedure Add_RACW_Read_Attribute
2978 (RACW_Type
: Entity_Id
;
2979 Stub_Type
: Entity_Id
;
2980 Stub_Type_Access
: Entity_Id
;
2981 Body_Decls
: List_Id
);
2982 -- Add Read attribute for the RACW type. The declaration and attribute
2983 -- definition clauses are inserted right after the declaration of
2984 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2985 -- appended to it (case where the RACW declaration is in the main unit).
2987 procedure Add_RACW_Write_Attribute
2988 (RACW_Type
: Entity_Id
;
2989 Stub_Type
: Entity_Id
;
2990 Stub_Type_Access
: Entity_Id
;
2991 RPC_Receiver
: Node_Id
;
2992 Body_Decls
: List_Id
);
2993 -- Same as above for the Write attribute
2995 function Stream_Parameter
return Node_Id
;
2996 function Result
return Node_Id
;
2997 function Object
return Node_Id
renames Result
;
2998 -- Functions to create occurrences of the formal parameter names of the
2999 -- 'Read and 'Write attributes.
3002 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
3003 -- their ancillary subroutines (set on entry by Add_RACW_Features).
3005 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
3006 -- Add a subprogram body for RAS Access TSS
3008 -------------------------------------
3009 -- Add_Obj_RPC_Receiver_Completion --
3010 -------------------------------------
3012 procedure Add_Obj_RPC_Receiver_Completion
3015 RPC_Receiver
: Entity_Id
;
3016 Stub_Elements
: Stub_Structure
)
3019 -- The RPC receiver body should not be the completion of the
3020 -- declaration recorded in the stub structure, because then the
3021 -- occurrences of the formal parameters within the body should refer
3022 -- to the entities from the declaration, not from the completion, to
3023 -- which we do not have easy access. Instead, the RPC receiver body
3024 -- acts as its own declaration, and the RPC receiver declaration is
3025 -- completed by a renaming-as-body.
3028 Make_Subprogram_Renaming_Declaration
(Loc
,
3030 Copy_Specification
(Loc
,
3031 Specification
(Stub_Elements
.RPC_Receiver_Decl
)),
3032 Name
=> New_Occurrence_Of
(RPC_Receiver
, Loc
)));
3033 end Add_Obj_RPC_Receiver_Completion
;
3035 -----------------------
3036 -- Add_RACW_Features --
3037 -----------------------
3039 procedure Add_RACW_Features
3040 (RACW_Type
: Entity_Id
;
3041 Stub_Type
: Entity_Id
;
3042 Stub_Type_Access
: Entity_Id
;
3043 RPC_Receiver_Decl
: Node_Id
;
3044 Body_Decls
: List_Id
)
3046 RPC_Receiver
: Node_Id
;
3047 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
3050 Loc
:= Sloc
(RACW_Type
);
3054 -- For a RAS, the RPC receiver is that of the RCI unit, not that
3055 -- of the corresponding distributed object type. We retrieve its
3056 -- address from the local proxy object.
3058 RPC_Receiver
:= Make_Selected_Component
(Loc
,
3060 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
), Object
),
3061 Selector_Name
=> Make_Identifier
(Loc
, Name_Receiver
));
3064 RPC_Receiver
:= Make_Attribute_Reference
(Loc
,
3065 Prefix
=> New_Occurrence_Of
(
3066 Defining_Unit_Name
(Specification
(RPC_Receiver_Decl
)), Loc
),
3067 Attribute_Name
=> Name_Address
);
3070 Add_RACW_Write_Attribute
3077 Add_RACW_Read_Attribute
3082 end Add_RACW_Features
;
3084 -----------------------------
3085 -- Add_RACW_Read_Attribute --
3086 -----------------------------
3088 procedure Add_RACW_Read_Attribute
3089 (RACW_Type
: Entity_Id
;
3090 Stub_Type
: Entity_Id
;
3091 Stub_Type_Access
: Entity_Id
;
3092 Body_Decls
: List_Id
)
3094 Proc_Decl
: Node_Id
;
3095 Attr_Decl
: Node_Id
;
3097 Body_Node
: Node_Id
;
3099 Statements
: constant List_Id
:= New_List
;
3101 Local_Statements
: List_Id
;
3102 Remote_Statements
: List_Id
;
3103 -- Various parts of the procedure
3105 Pnam
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
3106 Asynchronous_Flag
: constant Entity_Id
:=
3107 Asynchronous_Flags_Table
.Get
(RACW_Type
);
3108 pragma Assert
(Present
(Asynchronous_Flag
));
3110 -- Prepare local identifiers
3112 Source_Partition
: Entity_Id
;
3113 Source_Receiver
: Entity_Id
;
3114 Source_Address
: Entity_Id
;
3115 Local_Stub
: Entity_Id
;
3116 Stubbed_Result
: Entity_Id
;
3118 -- Start of processing for Add_RACW_Read_Attribute
3121 Build_Stream_Procedure
(Loc
,
3122 RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> True);
3123 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
3124 Copy_Specification
(Loc
, Specification
(Body_Node
)));
3127 Make_Attribute_Definition_Clause
(Loc
,
3128 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
3132 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
3134 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
3135 Insert_After
(Proc_Decl
, Attr_Decl
);
3137 if No
(Body_Decls
) then
3139 -- Case of processing an RACW type from another unit than the
3140 -- main one: do not generate a body.
3145 -- Prepare local identifiers
3147 Source_Partition
:= Make_Temporary
(Loc
, 'P');
3148 Source_Receiver
:= Make_Temporary
(Loc
, 'S');
3149 Source_Address
:= Make_Temporary
(Loc
, 'P');
3150 Local_Stub
:= Make_Temporary
(Loc
, 'L');
3151 Stubbed_Result
:= Make_Temporary
(Loc
, 'S');
3153 -- Generate object declarations
3156 Make_Object_Declaration
(Loc
,
3157 Defining_Identifier
=> Source_Partition
,
3158 Object_Definition
=>
3159 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
)),
3161 Make_Object_Declaration
(Loc
,
3162 Defining_Identifier
=> Source_Receiver
,
3163 Object_Definition
=>
3164 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3166 Make_Object_Declaration
(Loc
,
3167 Defining_Identifier
=> Source_Address
,
3168 Object_Definition
=>
3169 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3171 Make_Object_Declaration
(Loc
,
3172 Defining_Identifier
=> Local_Stub
,
3173 Aliased_Present
=> True,
3174 Object_Definition
=> New_Occurrence_Of
(Stub_Type
, Loc
)),
3176 Make_Object_Declaration
(Loc
,
3177 Defining_Identifier
=> Stubbed_Result
,
3178 Object_Definition
=>
3179 New_Occurrence_Of
(Stub_Type_Access
, Loc
),
3181 Make_Attribute_Reference
(Loc
,
3183 New_Occurrence_Of
(Local_Stub
, Loc
),
3185 Name_Unchecked_Access
)));
3187 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3189 Append_List_To
(Statements
, New_List
(
3190 Make_Attribute_Reference
(Loc
,
3192 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3193 Attribute_Name
=> Name_Read
,
3194 Expressions
=> New_List
(
3196 New_Occurrence_Of
(Source_Partition
, Loc
))),
3198 Make_Attribute_Reference
(Loc
,
3200 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3203 Expressions
=> New_List
(
3205 New_Occurrence_Of
(Source_Receiver
, Loc
))),
3207 Make_Attribute_Reference
(Loc
,
3209 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3212 Expressions
=> New_List
(
3214 New_Occurrence_Of
(Source_Address
, Loc
)))));
3216 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3218 Set_Etype
(Stubbed_Result
, Stub_Type_Access
);
3220 -- If the Address is Null_Address, then return a null object, unless
3221 -- RACW_Type is null-excluding, in which case unconditionally raise
3222 -- CONSTRAINT_ERROR instead.
3225 Zero_Statements
: List_Id
;
3226 -- Statements executed when a zero value is received
3229 if Can_Never_Be_Null
(RACW_Type
) then
3230 Zero_Statements
:= New_List
(
3231 Make_Raise_Constraint_Error
(Loc
,
3232 Reason
=> CE_Null_Not_Allowed
));
3234 Zero_Statements
:= New_List
(
3235 Make_Assignment_Statement
(Loc
,
3237 Expression
=> Make_Null
(Loc
)),
3238 Make_Simple_Return_Statement
(Loc
));
3241 Append_To
(Statements
,
3242 Make_Implicit_If_Statement
(RACW_Type
,
3245 Left_Opnd
=> New_Occurrence_Of
(Source_Address
, Loc
),
3246 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
3247 Then_Statements
=> Zero_Statements
));
3250 -- If the RACW denotes an object created on the current partition,
3251 -- Local_Statements will be executed. The real object will be used.
3253 Local_Statements
:= New_List
(
3254 Make_Assignment_Statement
(Loc
,
3257 Unchecked_Convert_To
(RACW_Type
,
3258 OK_Convert_To
(RTE
(RE_Address
),
3259 New_Occurrence_Of
(Source_Address
, Loc
)))));
3261 -- If the object is located on another partition, then a stub object
3262 -- will be created with all the information needed to rebuild the
3263 -- real object at the other end.
3265 Remote_Statements
:= New_List
(
3267 Make_Assignment_Statement
(Loc
,
3268 Name
=> Make_Selected_Component
(Loc
,
3269 Prefix
=> Stubbed_Result
,
3270 Selector_Name
=> Name_Origin
),
3272 New_Occurrence_Of
(Source_Partition
, Loc
)),
3274 Make_Assignment_Statement
(Loc
,
3275 Name
=> Make_Selected_Component
(Loc
,
3276 Prefix
=> Stubbed_Result
,
3277 Selector_Name
=> Name_Receiver
),
3279 New_Occurrence_Of
(Source_Receiver
, Loc
)),
3281 Make_Assignment_Statement
(Loc
,
3282 Name
=> Make_Selected_Component
(Loc
,
3283 Prefix
=> Stubbed_Result
,
3284 Selector_Name
=> Name_Addr
),
3286 New_Occurrence_Of
(Source_Address
, Loc
)));
3288 Append_To
(Remote_Statements
,
3289 Make_Assignment_Statement
(Loc
,
3290 Name
=> Make_Selected_Component
(Loc
,
3291 Prefix
=> Stubbed_Result
,
3292 Selector_Name
=> Name_Asynchronous
),
3294 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)));
3296 Append_List_To
(Remote_Statements
,
3297 Build_Get_Unique_RP_Call
(Loc
, Stubbed_Result
, Stub_Type
));
3298 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3299 -- set on the stub type if, and only if, the RACW type has a pragma
3300 -- Asynchronous. This is incorrect for RACWs that implement RAS
3301 -- types, because in that case the /designated subprogram/ (not the
3302 -- type) might be asynchronous, and that causes the stub to need to
3303 -- be asynchronous too. A solution is to transport a RAS as a struct
3304 -- containing a RACW and an asynchronous flag, and to properly alter
3305 -- the Asynchronous component in the stub type in the RAS's Input
3308 Append_To
(Remote_Statements
,
3309 Make_Assignment_Statement
(Loc
,
3311 Expression
=> Unchecked_Convert_To
(RACW_Type
,
3312 New_Occurrence_Of
(Stubbed_Result
, Loc
))));
3314 -- Distinguish between the local and remote cases, and execute the
3315 -- appropriate piece of code.
3317 Append_To
(Statements
,
3318 Make_Implicit_If_Statement
(RACW_Type
,
3322 Make_Function_Call
(Loc
,
3323 Name
=> New_Occurrence_Of
(
3324 RTE
(RE_Get_Local_Partition_Id
), Loc
)),
3325 Right_Opnd
=> New_Occurrence_Of
(Source_Partition
, Loc
)),
3326 Then_Statements
=> Local_Statements
,
3327 Else_Statements
=> Remote_Statements
));
3329 Set_Declarations
(Body_Node
, Decls
);
3330 Append_To
(Body_Decls
, Body_Node
);
3331 end Add_RACW_Read_Attribute
;
3333 ------------------------------
3334 -- Add_RACW_Write_Attribute --
3335 ------------------------------
3337 procedure Add_RACW_Write_Attribute
3338 (RACW_Type
: Entity_Id
;
3339 Stub_Type
: Entity_Id
;
3340 Stub_Type_Access
: Entity_Id
;
3341 RPC_Receiver
: Node_Id
;
3342 Body_Decls
: List_Id
)
3344 Body_Node
: Node_Id
;
3345 Proc_Decl
: Node_Id
;
3346 Attr_Decl
: Node_Id
;
3348 Statements
: constant List_Id
:= New_List
;
3349 Local_Statements
: List_Id
;
3350 Remote_Statements
: List_Id
;
3351 Null_Statements
: List_Id
;
3353 Pnam
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
3356 Build_Stream_Procedure
3357 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> False);
3359 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
3360 Copy_Specification
(Loc
, Specification
(Body_Node
)));
3363 Make_Attribute_Definition_Clause
(Loc
,
3364 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
3365 Chars
=> Name_Write
,
3368 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
3370 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
3371 Insert_After
(Proc_Decl
, Attr_Decl
);
3373 if No
(Body_Decls
) then
3377 -- Build the code fragment corresponding to the marshalling of a
3380 Local_Statements
:= New_List
(
3382 Pack_Entity_Into_Stream_Access
(Loc
,
3383 Stream
=> Stream_Parameter
,
3384 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
3386 Pack_Node_Into_Stream_Access
(Loc
,
3387 Stream
=> Stream_Parameter
,
3388 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
), RPC_Receiver
),
3389 Etyp
=> RTE
(RE_Unsigned_64
)),
3391 Pack_Node_Into_Stream_Access
(Loc
,
3392 Stream
=> Stream_Parameter
,
3393 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
),
3394 Make_Attribute_Reference
(Loc
,
3396 Make_Explicit_Dereference
(Loc
,
3398 Attribute_Name
=> Name_Address
)),
3399 Etyp
=> RTE
(RE_Unsigned_64
)));
3401 -- Build the code fragment corresponding to the marshalling of
3404 Remote_Statements
:= New_List
(
3405 Pack_Node_Into_Stream_Access
(Loc
,
3406 Stream
=> Stream_Parameter
,
3408 Make_Selected_Component
(Loc
,
3410 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3411 Selector_Name
=> Make_Identifier
(Loc
, Name_Origin
)),
3412 Etyp
=> RTE
(RE_Partition_ID
)),
3414 Pack_Node_Into_Stream_Access
(Loc
,
3415 Stream
=> Stream_Parameter
,
3417 Make_Selected_Component
(Loc
,
3419 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3420 Selector_Name
=> Make_Identifier
(Loc
, Name_Receiver
)),
3421 Etyp
=> RTE
(RE_Unsigned_64
)),
3423 Pack_Node_Into_Stream_Access
(Loc
,
3424 Stream
=> Stream_Parameter
,
3426 Make_Selected_Component
(Loc
,
3428 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3429 Selector_Name
=> Make_Identifier
(Loc
, Name_Addr
)),
3430 Etyp
=> RTE
(RE_Unsigned_64
)));
3432 -- Build code fragment corresponding to marshalling of a null object
3434 Null_Statements
:= New_List
(
3436 Pack_Entity_Into_Stream_Access
(Loc
,
3437 Stream
=> Stream_Parameter
,
3438 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
3440 Pack_Node_Into_Stream_Access
(Loc
,
3441 Stream
=> Stream_Parameter
,
3442 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
), RPC_Receiver
),
3443 Etyp
=> RTE
(RE_Unsigned_64
)),
3445 Pack_Node_Into_Stream_Access
(Loc
,
3446 Stream
=> Stream_Parameter
,
3447 Object
=> Make_Integer_Literal
(Loc
, Uint_0
),
3448 Etyp
=> RTE
(RE_Unsigned_64
)));
3450 Append_To
(Statements
,
3451 Make_Implicit_If_Statement
(RACW_Type
,
3454 Left_Opnd
=> Object
,
3455 Right_Opnd
=> Make_Null
(Loc
)),
3457 Then_Statements
=> Null_Statements
,
3459 Elsif_Parts
=> New_List
(
3460 Make_Elsif_Part
(Loc
,
3464 Make_Attribute_Reference
(Loc
,
3466 Attribute_Name
=> Name_Tag
),
3469 Make_Attribute_Reference
(Loc
,
3470 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
3471 Attribute_Name
=> Name_Tag
)),
3472 Then_Statements
=> Remote_Statements
)),
3473 Else_Statements
=> Local_Statements
));
3475 Append_To
(Body_Decls
, Body_Node
);
3476 end Add_RACW_Write_Attribute
;
3478 ------------------------
3479 -- Add_RAS_Access_TSS --
3480 ------------------------
3482 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
3483 Loc
: constant Source_Ptr
:= Sloc
(N
);
3485 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
3486 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
3487 -- Ras_Type is the access to subprogram type while Fat_Type is the
3488 -- corresponding record type.
3490 RACW_Type
: constant Entity_Id
:=
3491 Underlying_RACW_Type
(Ras_Type
);
3492 Desig
: constant Entity_Id
:=
3493 Etype
(Designated_Type
(RACW_Type
));
3495 Stub_Elements
: constant Stub_Structure
:=
3496 Stubs_Table
.Get
(Desig
);
3497 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
3499 Proc
: constant Entity_Id
:=
3500 Make_Defining_Identifier
(Loc
,
3501 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
3503 Proc_Spec
: Node_Id
;
3505 -- Formal parameters
3507 Package_Name
: constant Entity_Id
:=
3508 Make_Defining_Identifier
(Loc
,
3512 Subp_Id
: constant Entity_Id
:=
3513 Make_Defining_Identifier
(Loc
,
3515 -- Target subprogram
3517 Asynch_P
: constant Entity_Id
:=
3518 Make_Defining_Identifier
(Loc
,
3519 Chars
=> Name_Asynchronous
);
3520 -- Is the procedure to which the 'Access applies asynchronous?
3522 All_Calls_Remote
: constant Entity_Id
:=
3523 Make_Defining_Identifier
(Loc
,
3524 Chars
=> Name_All_Calls_Remote
);
3525 -- True if an All_Calls_Remote pragma applies to the RCI unit
3526 -- that contains the subprogram.
3528 -- Common local variables
3530 Proc_Decls
: List_Id
;
3531 Proc_Statements
: List_Id
;
3533 Origin
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
3535 -- Additional local variables for the local case
3537 Proxy_Addr
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
3539 -- Additional local variables for the remote case
3541 Local_Stub
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
3542 Stub_Ptr
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
3545 (Field_Name
: Name_Id
;
3546 Value
: Node_Id
) return Node_Id
;
3547 -- Construct an assignment that sets the named component in the
3555 (Field_Name
: Name_Id
;
3556 Value
: Node_Id
) return Node_Id
3560 Make_Assignment_Statement
(Loc
,
3562 Make_Selected_Component
(Loc
,
3564 Selector_Name
=> Field_Name
),
3565 Expression
=> Value
);
3568 -- Start of processing for Add_RAS_Access_TSS
3571 Proc_Decls
:= New_List
(
3573 -- Common declarations
3575 Make_Object_Declaration
(Loc
,
3576 Defining_Identifier
=> Origin
,
3577 Constant_Present
=> True,
3578 Object_Definition
=>
3579 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3581 Make_Function_Call
(Loc
,
3583 New_Occurrence_Of
(RTE
(RE_Get_Active_Partition_Id
), Loc
),
3584 Parameter_Associations
=> New_List
(
3585 New_Occurrence_Of
(Package_Name
, Loc
)))),
3587 -- Declaration use only in the local case: proxy address
3589 Make_Object_Declaration
(Loc
,
3590 Defining_Identifier
=> Proxy_Addr
,
3591 Object_Definition
=>
3592 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3594 -- Declarations used only in the remote case: stub object and
3597 Make_Object_Declaration
(Loc
,
3598 Defining_Identifier
=> Local_Stub
,
3599 Aliased_Present
=> True,
3600 Object_Definition
=>
3601 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
3603 Make_Object_Declaration
(Loc
,
3604 Defining_Identifier
=>
3606 Object_Definition
=>
3607 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
3609 Make_Attribute_Reference
(Loc
,
3610 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
3611 Attribute_Name
=> Name_Unchecked_Access
)));
3613 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
3615 -- Build_Get_Unique_RP_Call needs above information
3617 -- Note: Here we assume that the Fat_Type is a record
3618 -- containing just a pointer to a proxy or stub object.
3620 Proc_Statements
:= New_List
(
3624 -- Get_RAS_Info (Pkg, Subp, PA);
3625 -- if Origin = Local_Partition_Id
3626 -- and then not All_Calls_Remote
3628 -- return Fat_Type!(PA);
3631 Make_Procedure_Call_Statement
(Loc
,
3632 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
3633 Parameter_Associations
=> New_List
(
3634 New_Occurrence_Of
(Package_Name
, Loc
),
3635 New_Occurrence_Of
(Subp_Id
, Loc
),
3636 New_Occurrence_Of
(Proxy_Addr
, Loc
))),
3638 Make_Implicit_If_Statement
(N
,
3644 New_Occurrence_Of
(Origin
, Loc
),
3646 Make_Function_Call
(Loc
,
3648 RTE
(RE_Get_Local_Partition_Id
), Loc
))),
3652 New_Occurrence_Of
(All_Calls_Remote
, Loc
))),
3654 Then_Statements
=> New_List
(
3655 Make_Simple_Return_Statement
(Loc
,
3656 Unchecked_Convert_To
(Fat_Type
,
3657 OK_Convert_To
(RTE
(RE_Address
),
3658 New_Occurrence_Of
(Proxy_Addr
, Loc
)))))),
3660 Set_Field
(Name_Origin
,
3661 New_Occurrence_Of
(Origin
, Loc
)),
3663 Set_Field
(Name_Receiver
,
3664 Make_Function_Call
(Loc
,
3666 New_Occurrence_Of
(RTE
(RE_Get_RCI_Package_Receiver
), Loc
),
3667 Parameter_Associations
=> New_List
(
3668 New_Occurrence_Of
(Package_Name
, Loc
)))),
3670 Set_Field
(Name_Addr
, New_Occurrence_Of
(Proxy_Addr
, Loc
)),
3672 -- E.4.1(9) A remote call is asynchronous if it is a call to
3673 -- a procedure or a call through a value of an access-to-procedure
3674 -- type to which a pragma Asynchronous applies.
3676 -- Asynch_P is true when the procedure is asynchronous;
3677 -- Asynch_T is true when the type is asynchronous.
3679 Set_Field
(Name_Asynchronous
,
3681 New_Occurrence_Of
(Asynch_P
, Loc
),
3682 New_Occurrence_Of
(Boolean_Literals
(
3683 Is_Asynchronous
(Ras_Type
)), Loc
))));
3685 Append_List_To
(Proc_Statements
,
3686 Build_Get_Unique_RP_Call
3687 (Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
3689 -- Return the newly created value
3691 Append_To
(Proc_Statements
,
3692 Make_Simple_Return_Statement
(Loc
,
3694 Unchecked_Convert_To
(Fat_Type
,
3695 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
3698 Make_Function_Specification
(Loc
,
3699 Defining_Unit_Name
=> Proc
,
3700 Parameter_Specifications
=> New_List
(
3701 Make_Parameter_Specification
(Loc
,
3702 Defining_Identifier
=> Package_Name
,
3704 New_Occurrence_Of
(Standard_String
, Loc
)),
3706 Make_Parameter_Specification
(Loc
,
3707 Defining_Identifier
=> Subp_Id
,
3709 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
)),
3711 Make_Parameter_Specification
(Loc
,
3712 Defining_Identifier
=> Asynch_P
,
3714 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3716 Make_Parameter_Specification
(Loc
,
3717 Defining_Identifier
=> All_Calls_Remote
,
3719 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
3721 Result_Definition
=>
3722 New_Occurrence_Of
(Fat_Type
, Loc
));
3724 -- Set the kind and return type of the function to prevent
3725 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3727 Set_Ekind
(Proc
, E_Function
);
3728 Set_Etype
(Proc
, Fat_Type
);
3731 Make_Subprogram_Body
(Loc
,
3732 Specification
=> Proc_Spec
,
3733 Declarations
=> Proc_Decls
,
3734 Handled_Statement_Sequence
=>
3735 Make_Handled_Sequence_Of_Statements
(Loc
,
3736 Statements
=> Proc_Statements
)));
3738 Set_TSS
(Fat_Type
, Proc
);
3739 end Add_RAS_Access_TSS
;
3741 -----------------------
3742 -- Add_RAST_Features --
3743 -----------------------
3745 procedure Add_RAST_Features
3746 (Vis_Decl
: Node_Id
;
3747 RAS_Type
: Entity_Id
)
3749 pragma Unreferenced
(RAS_Type
);
3751 Add_RAS_Access_TSS
(Vis_Decl
);
3752 end Add_RAST_Features
;
3754 -----------------------------------------
3755 -- Add_Receiving_Stubs_To_Declarations --
3756 -----------------------------------------
3758 procedure Add_Receiving_Stubs_To_Declarations
3759 (Pkg_Spec
: Node_Id
;
3763 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
3765 Request_Parameter
: Node_Id
;
3767 Pkg_RPC_Receiver
: constant Entity_Id
:=
3768 Make_Temporary
(Loc
, 'H');
3769 Pkg_RPC_Receiver_Statements
: List_Id
;
3770 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
3771 Pkg_RPC_Receiver_Body
: Node_Id
;
3772 -- A Pkg_RPC_Receiver is built to decode the request
3774 Lookup_RAS
: Node_Id
;
3775 Lookup_RAS_Info
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
3776 -- A remote subprogram is created to allow peers to look up RAS
3777 -- information using subprogram ids.
3779 Subp_Id
: Entity_Id
;
3780 Subp_Index
: Entity_Id
;
3781 -- Subprogram_Id as read from the incoming stream
3783 Current_Subp_Number
: Int
:= First_RCI_Subprogram_Id
;
3784 Current_Stubs
: Node_Id
;
3786 Subp_Info_Array
: constant Entity_Id
:= Make_Temporary
(Loc
, 'I');
3787 Subp_Info_List
: constant List_Id
:= New_List
;
3789 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
3791 All_Calls_Remote_E
: Entity_Id
;
3792 Proxy_Object_Addr
: Entity_Id
;
3794 procedure Append_Stubs_To
3795 (RPC_Receiver_Cases
: List_Id
;
3797 Subprogram_Number
: Int
);
3798 -- Add one case to the specified RPC receiver case list
3799 -- associating Subprogram_Number with the subprogram declared
3800 -- by Declaration, for which we have receiving stubs in Stubs.
3802 procedure Visit_Subprogram
(Decl
: Node_Id
);
3803 -- Generate receiving stub for one remote subprogram
3805 ---------------------
3806 -- Append_Stubs_To --
3807 ---------------------
3809 procedure Append_Stubs_To
3810 (RPC_Receiver_Cases
: List_Id
;
3812 Subprogram_Number
: Int
)
3815 Append_To
(RPC_Receiver_Cases
,
3816 Make_Case_Statement_Alternative
(Loc
,
3818 New_List
(Make_Integer_Literal
(Loc
, Subprogram_Number
)),
3821 Make_Procedure_Call_Statement
(Loc
,
3823 New_Occurrence_Of
(Defining_Entity
(Stubs
), Loc
),
3824 Parameter_Associations
=> New_List
(
3825 New_Occurrence_Of
(Request_Parameter
, Loc
))))));
3826 end Append_Stubs_To
;
3828 ----------------------
3829 -- Visit_Subprogram --
3830 ----------------------
3832 procedure Visit_Subprogram
(Decl
: Node_Id
) is
3833 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
3834 Spec
: constant Node_Id
:= Specification
(Decl
);
3835 Subp_Def
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
3837 Subp_Val
: String_Id
;
3838 pragma Warnings
(Off
, Subp_Val
);
3841 -- Disable expansion of stubs if serious errors have been
3842 -- diagnosed, because otherwise some illegal remote subprogram
3843 -- declarations could cause cascaded errors in stubs.
3845 if Serious_Errors_Detected
/= 0 then
3849 -- Build receiving stub
3852 Build_Subprogram_Receiving_Stubs
3855 Nkind
(Spec
) = N_Procedure_Specification
3856 and then Is_Asynchronous
(Subp_Def
));
3858 Append_To
(Decls
, Current_Stubs
);
3859 Analyze
(Current_Stubs
);
3863 Add_RAS_Proxy_And_Analyze
(Decls
,
3865 All_Calls_Remote_E
=> All_Calls_Remote_E
,
3866 Proxy_Object_Addr
=> Proxy_Object_Addr
);
3868 -- Compute distribution identifier
3870 Assign_Subprogram_Identifier
3871 (Subp_Def
, Current_Subp_Number
, Subp_Val
);
3873 pragma Assert
(Current_Subp_Number
= Get_Subprogram_Id
(Subp_Def
));
3875 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
3876 -- table for this receiver. This aggregate must be kept consistent
3877 -- with the declaration of RCI_Subp_Info in
3878 -- System.Partition_Interface.
3880 Append_To
(Subp_Info_List
,
3881 Make_Component_Association
(Loc
,
3882 Choices
=> New_List
(
3883 Make_Integer_Literal
(Loc
, Current_Subp_Number
)),
3886 Make_Aggregate
(Loc
,
3887 Component_Associations
=> New_List
(
3891 Make_Component_Association
(Loc
,
3893 New_List
(Make_Identifier
(Loc
, Name_Addr
)),
3895 New_Occurrence_Of
(Proxy_Object_Addr
, Loc
))))));
3897 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3898 Stubs
=> Current_Stubs
,
3899 Subprogram_Number
=> Current_Subp_Number
);
3901 Current_Subp_Number
:= Current_Subp_Number
+ 1;
3902 end Visit_Subprogram
;
3904 procedure Visit_Spec
is new Build_Package_Stubs
(Visit_Subprogram
);
3906 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3909 -- Building receiving stubs consist in several operations:
3911 -- - a package RPC receiver must be built. This subprogram
3912 -- will get a Subprogram_Id from the incoming stream
3913 -- and will dispatch the call to the right subprogram;
3915 -- - a receiving stub for each subprogram visible in the package
3916 -- spec. This stub will read all the parameters from the stream,
3917 -- and put the result as well as the exception occurrence in the
3920 -- - a dummy package with an empty spec and a body made of an
3921 -- elaboration part, whose job is to register the receiving
3922 -- part of this RCI package on the name server. This is done
3923 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3925 Build_RPC_Receiver_Body
(
3926 RPC_Receiver
=> Pkg_RPC_Receiver
,
3927 Request
=> Request_Parameter
,
3929 Subp_Index
=> Subp_Index
,
3930 Stmts
=> Pkg_RPC_Receiver_Statements
,
3931 Decl
=> Pkg_RPC_Receiver_Body
);
3932 pragma Assert
(Subp_Id
= Subp_Index
);
3934 -- A null subp_id denotes a call through a RAS, in which case the
3935 -- next Uint_64 element in the stream is the address of the local
3936 -- proxy object, from which we can retrieve the actual subprogram id.
3938 Append_To
(Pkg_RPC_Receiver_Statements
,
3939 Make_Implicit_If_Statement
(Pkg_Spec
,
3942 New_Occurrence_Of
(Subp_Id
, Loc
),
3943 Make_Integer_Literal
(Loc
, 0)),
3945 Then_Statements
=> New_List
(
3946 Make_Assignment_Statement
(Loc
,
3948 New_Occurrence_Of
(Subp_Id
, Loc
),
3951 Make_Selected_Component
(Loc
,
3953 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
3954 OK_Convert_To
(RTE
(RE_Address
),
3955 Make_Attribute_Reference
(Loc
,
3957 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3960 Expressions
=> New_List
(
3961 Make_Selected_Component
(Loc
,
3962 Prefix
=> Request_Parameter
,
3963 Selector_Name
=> Name_Params
))))),
3965 Selector_Name
=> Make_Identifier
(Loc
, Name_Subp_Id
))))));
3967 -- Build a subprogram for RAS information lookups
3970 Make_Subprogram_Declaration
(Loc
,
3972 Make_Function_Specification
(Loc
,
3973 Defining_Unit_Name
=>
3975 Parameter_Specifications
=> New_List
(
3976 Make_Parameter_Specification
(Loc
,
3977 Defining_Identifier
=>
3978 Make_Defining_Identifier
(Loc
, Name_Subp_Id
),
3982 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))),
3983 Result_Definition
=>
3984 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)));
3985 Append_To
(Decls
, Lookup_RAS
);
3986 Analyze
(Lookup_RAS
);
3988 Current_Stubs
:= Build_Subprogram_Receiving_Stubs
3989 (Vis_Decl
=> Lookup_RAS
,
3990 Asynchronous
=> False);
3991 Append_To
(Decls
, Current_Stubs
);
3992 Analyze
(Current_Stubs
);
3994 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3995 Stubs
=> Current_Stubs
,
3996 Subprogram_Number
=> 1);
3998 -- For each subprogram, the receiving stub will be built and a
3999 -- case statement will be made on the Subprogram_Id to dispatch
4000 -- to the right subprogram.
4002 All_Calls_Remote_E
:=
4004 (Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
4006 Overload_Counter_Table
.Reset
;
4008 Visit_Spec
(Pkg_Spec
);
4010 -- If we receive an invalid Subprogram_Id, it is best to do nothing
4011 -- rather than raising an exception since we do not want someone
4012 -- to crash a remote partition by sending invalid subprogram ids.
4013 -- This is consistent with the other parts of the case statement
4014 -- since even in presence of incorrect parameters in the stream,
4015 -- every exception will be caught and (if the subprogram is not an
4016 -- APC) put into the result stream and sent away.
4018 Append_To
(Pkg_RPC_Receiver_Cases
,
4019 Make_Case_Statement_Alternative
(Loc
,
4020 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
4021 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
4023 Append_To
(Pkg_RPC_Receiver_Statements
,
4024 Make_Case_Statement
(Loc
,
4025 Expression
=> New_Occurrence_Of
(Subp_Id
, Loc
),
4026 Alternatives
=> Pkg_RPC_Receiver_Cases
));
4029 Make_Object_Declaration
(Loc
,
4030 Defining_Identifier
=> Subp_Info_Array
,
4031 Constant_Present
=> True,
4032 Aliased_Present
=> True,
4033 Object_Definition
=>
4034 Make_Subtype_Indication
(Loc
,
4036 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
4038 Make_Index_Or_Discriminant_Constraint
(Loc
,
4041 Low_Bound
=> Make_Integer_Literal
(Loc
,
4042 First_RCI_Subprogram_Id
),
4044 Make_Integer_Literal
(Loc
,
4046 First_RCI_Subprogram_Id
4047 + List_Length
(Subp_Info_List
) - 1)))))));
4049 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
4050 -- has zero length, and the declaration is for an empty array, in
4051 -- which case no initialization aggregate must be generated.
4053 if Present
(First
(Subp_Info_List
)) then
4054 Set_Expression
(Last
(Decls
),
4055 Make_Aggregate
(Loc
,
4056 Component_Associations
=> Subp_Info_List
));
4058 -- No initialization provided: remove CONSTANT so that the
4059 -- declaration is not an incomplete deferred constant.
4062 Set_Constant_Present
(Last
(Decls
), False);
4065 Analyze
(Last
(Decls
));
4068 Subp_Info_Addr
: Node_Id
;
4069 -- Return statement for Lookup_RAS_Info: address of the subprogram
4070 -- information record for the requested subprogram id.
4073 if Present
(First
(Subp_Info_List
)) then
4075 Make_Selected_Component
(Loc
,
4077 Make_Indexed_Component
(Loc
,
4078 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
4079 Expressions
=> New_List
(
4080 Convert_To
(Standard_Integer
,
4081 Make_Identifier
(Loc
, Name_Subp_Id
)))),
4082 Selector_Name
=> Make_Identifier
(Loc
, Name_Addr
));
4084 -- Case of no visible subprogram: just raise Constraint_Error, we
4085 -- know for sure we got junk from a remote partition.
4089 Make_Raise_Constraint_Error
(Loc
,
4090 Reason
=> CE_Range_Check_Failed
);
4091 Set_Etype
(Subp_Info_Addr
, RTE
(RE_Unsigned_64
));
4095 Make_Subprogram_Body
(Loc
,
4097 Copy_Specification
(Loc
, Parent
(Lookup_RAS_Info
)),
4098 Declarations
=> No_List
,
4099 Handled_Statement_Sequence
=>
4100 Make_Handled_Sequence_Of_Statements
(Loc
,
4101 Statements
=> New_List
(
4102 Make_Simple_Return_Statement
(Loc
,
4105 (RTE
(RE_Unsigned_64
), Subp_Info_Addr
))))));
4108 Analyze
(Last
(Decls
));
4110 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
4111 Analyze
(Last
(Decls
));
4115 Append_To
(Register_Pkg_Actuals
,
4116 Make_String_Literal
(Loc
,
4118 Fully_Qualified_Name_String
4119 (Defining_Entity
(Pkg_Spec
), Append_NUL
=> False)));
4123 Append_To
(Register_Pkg_Actuals
,
4124 Make_Attribute_Reference
(Loc
,
4125 Prefix
=> New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
4126 Attribute_Name
=> Name_Unrestricted_Access
));
4130 Append_To
(Register_Pkg_Actuals
,
4131 Make_Attribute_Reference
(Loc
,
4133 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
4134 Attribute_Name
=> Name_Version
));
4138 Append_To
(Register_Pkg_Actuals
,
4139 Make_Attribute_Reference
(Loc
,
4140 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
4141 Attribute_Name
=> Name_Address
));
4145 Append_To
(Register_Pkg_Actuals
,
4146 Make_Attribute_Reference
(Loc
,
4147 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
4148 Attribute_Name
=> Name_Length
));
4150 -- Generate the call
4153 Make_Procedure_Call_Statement
(Loc
,
4155 New_Occurrence_Of
(RTE
(RE_Register_Receiving_Stub
), Loc
),
4156 Parameter_Associations
=> Register_Pkg_Actuals
));
4157 Analyze
(Last
(Stmts
));
4158 end Add_Receiving_Stubs_To_Declarations
;
4160 ---------------------------------
4161 -- Build_General_Calling_Stubs --
4162 ---------------------------------
4164 procedure Build_General_Calling_Stubs
4166 Statements
: List_Id
;
4167 Target_Partition
: Entity_Id
;
4168 Target_RPC_Receiver
: Node_Id
;
4169 Subprogram_Id
: Node_Id
;
4170 Asynchronous
: Node_Id
:= Empty
;
4171 Is_Known_Asynchronous
: Boolean := False;
4172 Is_Known_Non_Asynchronous
: Boolean := False;
4173 Is_Function
: Boolean;
4175 Stub_Type
: Entity_Id
:= Empty
;
4176 RACW_Type
: Entity_Id
:= Empty
;
4179 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
4181 Stream_Parameter
: Node_Id
;
4182 -- Name of the stream used to transmit parameters to the remote
4185 Result_Parameter
: Node_Id
;
4186 -- Name of the result parameter (in non-APC cases) which get the
4187 -- result of the remote subprogram.
4189 Exception_Return_Parameter
: Node_Id
;
4190 -- Name of the parameter which will hold the exception sent by the
4191 -- remote subprogram.
4193 Current_Parameter
: Node_Id
;
4194 -- Current parameter being handled
4196 Ordered_Parameters_List
: constant List_Id
:=
4197 Build_Ordered_Parameters_List
(Spec
);
4199 Asynchronous_Statements
: List_Id
:= No_List
;
4200 Non_Asynchronous_Statements
: List_Id
:= No_List
;
4201 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4203 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4204 -- List of statements for extra formal parameters. It will appear
4205 -- after the regular statements for writing out parameters.
4207 pragma Unreferenced
(RACW_Type
);
4208 -- Used only for the PolyORB case
4211 -- The general form of a calling stub for a given subprogram is:
4213 -- procedure X (...) is P : constant Partition_ID :=
4214 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4215 -- System.RPC.Params_Stream_Type (0); begin
4216 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4217 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4218 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4219 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4221 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4223 -- There are some variations: Do_APC is called for an asynchronous
4224 -- procedure and the part after the call is completely ommitted as
4225 -- well as the declaration of Result. For a function call, 'Input is
4226 -- always used to read the result even if it is constrained.
4228 Stream_Parameter
:= Make_Temporary
(Loc
, 'S');
4231 Make_Object_Declaration
(Loc
,
4232 Defining_Identifier
=> Stream_Parameter
,
4233 Aliased_Present
=> True,
4234 Object_Definition
=>
4235 Make_Subtype_Indication
(Loc
,
4237 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
4239 Make_Index_Or_Discriminant_Constraint
(Loc
,
4241 New_List
(Make_Integer_Literal
(Loc
, 0))))));
4243 if not Is_Known_Asynchronous
then
4244 Result_Parameter
:= Make_Temporary
(Loc
, 'R');
4247 Make_Object_Declaration
(Loc
,
4248 Defining_Identifier
=> Result_Parameter
,
4249 Aliased_Present
=> True,
4250 Object_Definition
=>
4251 Make_Subtype_Indication
(Loc
,
4253 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
4255 Make_Index_Or_Discriminant_Constraint
(Loc
,
4257 New_List
(Make_Integer_Literal
(Loc
, 0))))));
4259 Exception_Return_Parameter
:= Make_Temporary
(Loc
, 'E');
4262 Make_Object_Declaration
(Loc
,
4263 Defining_Identifier
=> Exception_Return_Parameter
,
4264 Object_Definition
=>
4265 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
4268 Result_Parameter
:= Empty
;
4269 Exception_Return_Parameter
:= Empty
;
4272 -- Put first the RPC receiver corresponding to the remote package
4274 Append_To
(Statements
,
4275 Make_Attribute_Reference
(Loc
,
4277 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
4278 Attribute_Name
=> Name_Write
,
4279 Expressions
=> New_List
(
4280 Make_Attribute_Reference
(Loc
,
4281 Prefix
=> New_Occurrence_Of
(Stream_Parameter
, Loc
),
4282 Attribute_Name
=> Name_Access
),
4283 Target_RPC_Receiver
)));
4285 -- Then put the Subprogram_Id of the subprogram we want to call in
4288 Append_To
(Statements
,
4289 Make_Attribute_Reference
(Loc
,
4290 Prefix
=> New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4291 Attribute_Name
=> Name_Write
,
4292 Expressions
=> New_List
(
4293 Make_Attribute_Reference
(Loc
,
4294 Prefix
=> New_Occurrence_Of
(Stream_Parameter
, Loc
),
4295 Attribute_Name
=> Name_Access
),
4298 Current_Parameter
:= First
(Ordered_Parameters_List
);
4299 while Present
(Current_Parameter
) loop
4301 Typ
: constant Node_Id
:=
4302 Parameter_Type
(Current_Parameter
);
4304 Constrained
: Boolean;
4306 Extra_Parameter
: Entity_Id
;
4309 if Is_RACW_Controlling_Formal
4310 (Current_Parameter
, Stub_Type
)
4312 -- In the case of a controlling formal argument, we marshall
4313 -- its addr field rather than the local stub.
4315 Append_To
(Statements
,
4316 Pack_Node_Into_Stream
(Loc
,
4317 Stream
=> Stream_Parameter
,
4319 Make_Selected_Component
(Loc
,
4321 Defining_Identifier
(Current_Parameter
),
4322 Selector_Name
=> Name_Addr
),
4323 Etyp
=> RTE
(RE_Unsigned_64
)));
4328 (Defining_Identifier
(Current_Parameter
), Loc
);
4330 -- Access type parameters are transmitted as in out
4331 -- parameters. However, a dereference is needed so that
4332 -- we marshall the designated object.
4334 if Nkind
(Typ
) = N_Access_Definition
then
4335 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4336 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4338 Etyp
:= Etype
(Typ
);
4341 Constrained
:= not Transmit_As_Unconstrained
(Etyp
);
4343 -- Any parameter but unconstrained out parameters are
4344 -- transmitted to the peer.
4346 if In_Present
(Current_Parameter
)
4347 or else not Out_Present
(Current_Parameter
)
4348 or else not Constrained
4350 Append_To
(Statements
,
4351 Make_Attribute_Reference
(Loc
,
4352 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4354 Output_From_Constrained
(Constrained
),
4355 Expressions
=> New_List
(
4356 Make_Attribute_Reference
(Loc
,
4358 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4359 Attribute_Name
=> Name_Access
),
4364 -- If the current parameter has a dynamic constrained status,
4365 -- then this status is transmitted as well.
4366 -- This should be done for accessibility as well ???
4368 if Nkind
(Typ
) /= N_Access_Definition
4369 and then Need_Extra_Constrained
(Current_Parameter
)
4371 -- In this block, we do not use the extra formal that has
4372 -- been created because it does not exist at the time of
4373 -- expansion when building calling stubs for remote access
4374 -- to subprogram types. We create an extra variable of this
4375 -- type and push it in the stream after the regular
4378 Extra_Parameter
:= Make_Temporary
(Loc
, 'P');
4381 Make_Object_Declaration
(Loc
,
4382 Defining_Identifier
=> Extra_Parameter
,
4383 Constant_Present
=> True,
4384 Object_Definition
=>
4385 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4387 Make_Attribute_Reference
(Loc
,
4390 Defining_Identifier
(Current_Parameter
), Loc
),
4391 Attribute_Name
=> Name_Constrained
)));
4393 Append_To
(Extra_Formal_Statements
,
4394 Make_Attribute_Reference
(Loc
,
4396 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4397 Attribute_Name
=> Name_Write
,
4398 Expressions
=> New_List
(
4399 Make_Attribute_Reference
(Loc
,
4402 (Stream_Parameter
, Loc
), Attribute_Name
=>
4404 New_Occurrence_Of
(Extra_Parameter
, Loc
))));
4407 Next
(Current_Parameter
);
4411 -- Append the formal statements list to the statements
4413 Append_List_To
(Statements
, Extra_Formal_Statements
);
4415 if not Is_Known_Non_Asynchronous
then
4417 -- Build the call to System.RPC.Do_APC
4419 Asynchronous_Statements
:= New_List
(
4420 Make_Procedure_Call_Statement
(Loc
,
4422 New_Occurrence_Of
(RTE
(RE_Do_Apc
), Loc
),
4423 Parameter_Associations
=> New_List
(
4424 New_Occurrence_Of
(Target_Partition
, Loc
),
4425 Make_Attribute_Reference
(Loc
,
4427 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4428 Attribute_Name
=> Name_Access
))));
4430 Asynchronous_Statements
:= No_List
;
4433 if not Is_Known_Asynchronous
then
4435 -- Build the call to System.RPC.Do_RPC
4437 Non_Asynchronous_Statements
:= New_List
(
4438 Make_Procedure_Call_Statement
(Loc
,
4440 New_Occurrence_Of
(RTE
(RE_Do_Rpc
), Loc
),
4441 Parameter_Associations
=> New_List
(
4442 New_Occurrence_Of
(Target_Partition
, Loc
),
4444 Make_Attribute_Reference
(Loc
,
4446 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4447 Attribute_Name
=> Name_Access
),
4449 Make_Attribute_Reference
(Loc
,
4451 New_Occurrence_Of
(Result_Parameter
, Loc
),
4452 Attribute_Name
=> Name_Access
))));
4454 -- Read the exception occurrence from the result stream and
4455 -- reraise it. It does no harm if this is a Null_Occurrence since
4456 -- this does nothing.
4458 Append_To
(Non_Asynchronous_Statements
,
4459 Make_Attribute_Reference
(Loc
,
4461 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4463 Attribute_Name
=> Name_Read
,
4465 Expressions
=> New_List
(
4466 Make_Attribute_Reference
(Loc
,
4468 New_Occurrence_Of
(Result_Parameter
, Loc
),
4469 Attribute_Name
=> Name_Access
),
4470 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
4472 Append_To
(Non_Asynchronous_Statements
,
4473 Make_Procedure_Call_Statement
(Loc
,
4475 New_Occurrence_Of
(RTE
(RE_Reraise_Occurrence
), Loc
),
4476 Parameter_Associations
=> New_List
(
4477 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
4481 -- If this is a function call, then read the value and return
4482 -- it. The return value is written/read using 'Output/'Input.
4484 Append_To
(Non_Asynchronous_Statements
,
4485 Make_Tag_Check
(Loc
,
4486 Make_Simple_Return_Statement
(Loc
,
4488 Make_Attribute_Reference
(Loc
,
4491 Etype
(Result_Definition
(Spec
)), Loc
),
4493 Attribute_Name
=> Name_Input
,
4495 Expressions
=> New_List
(
4496 Make_Attribute_Reference
(Loc
,
4498 New_Occurrence_Of
(Result_Parameter
, Loc
),
4499 Attribute_Name
=> Name_Access
))))));
4502 -- Loop around parameters and assign out (or in out)
4503 -- parameters. In the case of RACW, controlling arguments
4504 -- cannot possibly have changed since they are remote, so
4505 -- we do not read them from the stream.
4507 Current_Parameter
:= First
(Ordered_Parameters_List
);
4508 while Present
(Current_Parameter
) loop
4510 Typ
: constant Node_Id
:=
4511 Parameter_Type
(Current_Parameter
);
4518 (Defining_Identifier
(Current_Parameter
), Loc
);
4520 if Nkind
(Typ
) = N_Access_Definition
then
4521 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4522 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4524 Etyp
:= Etype
(Typ
);
4527 if (Out_Present
(Current_Parameter
)
4528 or else Nkind
(Typ
) = N_Access_Definition
)
4529 and then Etyp
/= Stub_Type
4531 Append_To
(Non_Asynchronous_Statements
,
4532 Make_Attribute_Reference
(Loc
,
4534 New_Occurrence_Of
(Etyp
, Loc
),
4536 Attribute_Name
=> Name_Read
,
4538 Expressions
=> New_List
(
4539 Make_Attribute_Reference
(Loc
,
4541 New_Occurrence_Of
(Result_Parameter
, Loc
),
4542 Attribute_Name
=> Name_Access
),
4547 Next
(Current_Parameter
);
4552 if Is_Known_Asynchronous
then
4553 Append_List_To
(Statements
, Asynchronous_Statements
);
4555 elsif Is_Known_Non_Asynchronous
then
4556 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
4559 pragma Assert
(Present
(Asynchronous
));
4560 Prepend_To
(Asynchronous_Statements
,
4561 Make_Attribute_Reference
(Loc
,
4562 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4563 Attribute_Name
=> Name_Write
,
4564 Expressions
=> New_List
(
4565 Make_Attribute_Reference
(Loc
,
4567 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4568 Attribute_Name
=> Name_Access
),
4569 New_Occurrence_Of
(Standard_True
, Loc
))));
4571 Prepend_To
(Non_Asynchronous_Statements
,
4572 Make_Attribute_Reference
(Loc
,
4573 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4574 Attribute_Name
=> Name_Write
,
4575 Expressions
=> New_List
(
4576 Make_Attribute_Reference
(Loc
,
4578 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4579 Attribute_Name
=> Name_Access
),
4580 New_Occurrence_Of
(Standard_False
, Loc
))));
4582 Append_To
(Statements
,
4583 Make_Implicit_If_Statement
(Nod
,
4584 Condition
=> Asynchronous
,
4585 Then_Statements
=> Asynchronous_Statements
,
4586 Else_Statements
=> Non_Asynchronous_Statements
));
4588 end Build_General_Calling_Stubs
;
4590 -----------------------------
4591 -- Build_RPC_Receiver_Body --
4592 -----------------------------
4594 procedure Build_RPC_Receiver_Body
4595 (RPC_Receiver
: Entity_Id
;
4596 Request
: out Entity_Id
;
4597 Subp_Id
: out Entity_Id
;
4598 Subp_Index
: out Entity_Id
;
4599 Stmts
: out List_Id
;
4602 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
4604 RPC_Receiver_Spec
: Node_Id
;
4605 RPC_Receiver_Decls
: List_Id
;
4608 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
4610 RPC_Receiver_Spec
:=
4611 Build_RPC_Receiver_Specification
4612 (RPC_Receiver
=> RPC_Receiver
,
4613 Request_Parameter
=> Request
);
4615 Subp_Id
:= Make_Temporary
(Loc
, 'P');
4616 Subp_Index
:= Subp_Id
;
4618 -- Subp_Id may not be a constant, because in the case of the RPC
4619 -- receiver for an RCI package, when a call is received from a RAS
4620 -- dereference, it will be assigned during subsequent processing.
4622 RPC_Receiver_Decls
:= New_List
(
4623 Make_Object_Declaration
(Loc
,
4624 Defining_Identifier
=> Subp_Id
,
4625 Object_Definition
=>
4626 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4628 Make_Attribute_Reference
(Loc
,
4630 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4631 Attribute_Name
=> Name_Input
,
4632 Expressions
=> New_List
(
4633 Make_Selected_Component
(Loc
,
4635 Selector_Name
=> Name_Params
)))));
4640 Make_Subprogram_Body
(Loc
,
4641 Specification
=> RPC_Receiver_Spec
,
4642 Declarations
=> RPC_Receiver_Decls
,
4643 Handled_Statement_Sequence
=>
4644 Make_Handled_Sequence_Of_Statements
(Loc
,
4645 Statements
=> Stmts
));
4646 end Build_RPC_Receiver_Body
;
4648 -----------------------
4649 -- Build_Stub_Target --
4650 -----------------------
4652 function Build_Stub_Target
4655 RCI_Locator
: Entity_Id
;
4656 Controlling_Parameter
: Entity_Id
) return RPC_Target
4658 Target_Info
: RPC_Target
(PCS_Kind
=> Name_GARLIC_DSA
);
4661 Target_Info
.Partition
:= Make_Temporary
(Loc
, 'P');
4663 if Present
(Controlling_Parameter
) then
4665 Make_Object_Declaration
(Loc
,
4666 Defining_Identifier
=> Target_Info
.Partition
,
4667 Constant_Present
=> True,
4668 Object_Definition
=>
4669 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4672 Make_Selected_Component
(Loc
,
4673 Prefix
=> Controlling_Parameter
,
4674 Selector_Name
=> Name_Origin
)));
4676 Target_Info
.RPC_Receiver
:=
4677 Make_Selected_Component
(Loc
,
4678 Prefix
=> Controlling_Parameter
,
4679 Selector_Name
=> Name_Receiver
);
4683 Make_Object_Declaration
(Loc
,
4684 Defining_Identifier
=> Target_Info
.Partition
,
4685 Constant_Present
=> True,
4686 Object_Definition
=>
4687 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4690 Make_Function_Call
(Loc
,
4691 Name
=> Make_Selected_Component
(Loc
,
4693 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4695 Make_Identifier
(Loc
,
4696 Name_Get_Active_Partition_ID
)))));
4698 Target_Info
.RPC_Receiver
:=
4699 Make_Selected_Component
(Loc
,
4701 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4703 Make_Identifier
(Loc
, Name_Get_RCI_Package_Receiver
));
4706 end Build_Stub_Target
;
4708 --------------------------------------
4709 -- Build_Subprogram_Receiving_Stubs --
4710 --------------------------------------
4712 function Build_Subprogram_Receiving_Stubs
4713 (Vis_Decl
: Node_Id
;
4714 Asynchronous
: Boolean;
4715 Dynamically_Asynchronous
: Boolean := False;
4716 Stub_Type
: Entity_Id
:= Empty
;
4717 RACW_Type
: Entity_Id
:= Empty
;
4718 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
4720 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
4722 Request_Parameter
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4723 -- Formal parameter for receiving stubs: a descriptor for an incoming
4726 Decls
: constant List_Id
:= New_List
;
4727 -- All the parameters will get declared before calling the real
4728 -- subprograms. Also the out parameters will be declared.
4730 Statements
: constant List_Id
:= New_List
;
4732 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4733 -- Statements concerning extra formal parameters
4735 After_Statements
: constant List_Id
:= New_List
;
4736 -- Statements to be executed after the subprogram call
4738 Inner_Decls
: List_Id
:= No_List
;
4739 -- In case of a function, the inner declarations are needed since
4740 -- the result may be unconstrained.
4742 Excep_Handlers
: List_Id
:= No_List
;
4743 Excep_Choice
: Entity_Id
;
4744 Excep_Code
: List_Id
;
4746 Parameter_List
: constant List_Id
:= New_List
;
4747 -- List of parameters to be passed to the subprogram
4749 Current_Parameter
: Node_Id
;
4751 Ordered_Parameters_List
: constant List_Id
:=
4752 Build_Ordered_Parameters_List
4753 (Specification
(Vis_Decl
));
4755 Subp_Spec
: Node_Id
;
4756 -- Subprogram specification
4758 Called_Subprogram
: Node_Id
;
4759 -- The subprogram to call
4761 Null_Raise_Statement
: Node_Id
;
4763 Dynamic_Async
: Entity_Id
;
4766 if Present
(RACW_Type
) then
4767 Called_Subprogram
:= New_Occurrence_Of
(Parent_Primitive
, Loc
);
4769 Called_Subprogram
:=
4771 (Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
4774 if Dynamically_Asynchronous
then
4775 Dynamic_Async
:= Make_Temporary
(Loc
, 'S');
4777 Dynamic_Async
:= Empty
;
4780 if not Asynchronous
or Dynamically_Asynchronous
then
4782 -- The first statement after the subprogram call is a statement to
4783 -- write a Null_Occurrence into the result stream.
4785 Null_Raise_Statement
:=
4786 Make_Attribute_Reference
(Loc
,
4788 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4789 Attribute_Name
=> Name_Write
,
4790 Expressions
=> New_List
(
4791 Make_Selected_Component
(Loc
,
4792 Prefix
=> Request_Parameter
,
4793 Selector_Name
=> Name_Result
),
4794 New_Occurrence_Of
(RTE
(RE_Null_Occurrence
), Loc
)));
4796 if Dynamically_Asynchronous
then
4797 Null_Raise_Statement
:=
4798 Make_Implicit_If_Statement
(Vis_Decl
,
4800 Make_Op_Not
(Loc
, New_Occurrence_Of
(Dynamic_Async
, Loc
)),
4801 Then_Statements
=> New_List
(Null_Raise_Statement
));
4804 Append_To
(After_Statements
, Null_Raise_Statement
);
4807 -- Loop through every parameter and get its value from the stream. If
4808 -- the parameter is unconstrained, then the parameter is read using
4809 -- 'Input at the point of declaration.
4811 Current_Parameter
:= First
(Ordered_Parameters_List
);
4812 while Present
(Current_Parameter
) loop
4815 Constrained
: Boolean;
4817 Need_Extra_Constrained
: Boolean;
4818 -- True when an Extra_Constrained actual is required
4820 Object
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
4822 Expr
: Node_Id
:= Empty
;
4824 Is_Controlling_Formal
: constant Boolean :=
4825 Is_RACW_Controlling_Formal
4826 (Current_Parameter
, Stub_Type
);
4829 if Is_Controlling_Formal
then
4831 -- We have a controlling formal parameter. Read its address
4832 -- rather than a real object. The address is in Unsigned_64
4835 Etyp
:= RTE
(RE_Unsigned_64
);
4837 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
4840 Constrained
:= not Transmit_As_Unconstrained
(Etyp
);
4842 if In_Present
(Current_Parameter
)
4843 or else not Out_Present
(Current_Parameter
)
4844 or else not Constrained
4845 or else Is_Controlling_Formal
4847 -- If an input parameter is constrained, then the read of
4848 -- the parameter is deferred until the beginning of the
4849 -- subprogram body. If it is unconstrained, then an
4850 -- expression is built for the object declaration and the
4851 -- variable is set using 'Input instead of 'Read. Note that
4852 -- this deferral does not change the order in which the
4853 -- actuals are read because Build_Ordered_Parameter_List
4854 -- puts them unconstrained first.
4857 Append_To
(Statements
,
4858 Make_Attribute_Reference
(Loc
,
4859 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4860 Attribute_Name
=> Name_Read
,
4861 Expressions
=> New_List
(
4862 Make_Selected_Component
(Loc
,
4863 Prefix
=> Request_Parameter
,
4864 Selector_Name
=> Name_Params
),
4865 New_Occurrence_Of
(Object
, Loc
))));
4869 -- Build and append Input_With_Tag_Check function
4872 Input_With_Tag_Check
(Loc
,
4875 Make_Selected_Component
(Loc
,
4876 Prefix
=> Request_Parameter
,
4877 Selector_Name
=> Name_Params
)));
4879 -- Prepare function call expression
4882 Make_Function_Call
(Loc
,
4886 (Specification
(Last
(Decls
))), Loc
));
4890 Need_Extra_Constrained
:=
4891 Nkind
(Parameter_Type
(Current_Parameter
)) /=
4894 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
4896 Present
(Extra_Constrained
4897 (Defining_Identifier
(Current_Parameter
)));
4899 -- We may not associate an extra constrained actual to a
4900 -- constant object, so if one is needed, declare the actual
4901 -- as a variable even if it won't be modified.
4903 Build_Actual_Object_Declaration
4906 Variable
=> Need_Extra_Constrained
4907 or else Out_Present
(Current_Parameter
),
4911 -- An out parameter may be written back using a 'Write
4912 -- attribute instead of a 'Output because it has been
4913 -- constrained by the parameter given to the caller. Note that
4914 -- out controlling arguments in the case of a RACW are not put
4915 -- back in the stream because the pointer on them has not
4918 if Out_Present
(Current_Parameter
)
4920 Etype
(Parameter_Type
(Current_Parameter
)) /= Stub_Type
4922 Append_To
(After_Statements
,
4923 Make_Attribute_Reference
(Loc
,
4924 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4925 Attribute_Name
=> Name_Write
,
4926 Expressions
=> New_List
(
4927 Make_Selected_Component
(Loc
,
4928 Prefix
=> Request_Parameter
,
4929 Selector_Name
=> Name_Result
),
4930 New_Occurrence_Of
(Object
, Loc
))));
4933 -- For RACW controlling formals, the Etyp of Object is always
4934 -- an RACW, even if the parameter is not of an anonymous access
4935 -- type. In such case, we need to dereference it at call time.
4937 if Is_Controlling_Formal
then
4938 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
4941 Append_To
(Parameter_List
,
4942 Make_Parameter_Association
(Loc
,
4945 Defining_Identifier
(Current_Parameter
), Loc
),
4946 Explicit_Actual_Parameter
=>
4947 Make_Explicit_Dereference
(Loc
,
4948 Unchecked_Convert_To
(RACW_Type
,
4949 OK_Convert_To
(RTE
(RE_Address
),
4950 New_Occurrence_Of
(Object
, Loc
))))));
4953 Append_To
(Parameter_List
,
4954 Make_Parameter_Association
(Loc
,
4957 Defining_Identifier
(Current_Parameter
), Loc
),
4958 Explicit_Actual_Parameter
=>
4959 Unchecked_Convert_To
(RACW_Type
,
4960 OK_Convert_To
(RTE
(RE_Address
),
4961 New_Occurrence_Of
(Object
, Loc
)))));
4965 Append_To
(Parameter_List
,
4966 Make_Parameter_Association
(Loc
,
4969 Defining_Identifier
(Current_Parameter
), Loc
),
4970 Explicit_Actual_Parameter
=>
4971 New_Occurrence_Of
(Object
, Loc
)));
4974 -- If the current parameter needs an extra formal, then read it
4975 -- from the stream and set the corresponding semantic field in
4976 -- the variable. If the kind of the parameter identifier is
4977 -- E_Void, then this is a compiler generated parameter that
4978 -- doesn't need an extra constrained status.
4980 -- The case of Extra_Accessibility should also be handled ???
4982 if Need_Extra_Constrained
then
4984 Extra_Parameter
: constant Entity_Id
:=
4986 (Defining_Identifier
4987 (Current_Parameter
));
4989 Formal_Entity
: constant Entity_Id
:=
4990 Make_Defining_Identifier
4991 (Loc
, Chars
(Extra_Parameter
));
4993 Formal_Type
: constant Entity_Id
:=
4994 Etype
(Extra_Parameter
);
4998 Make_Object_Declaration
(Loc
,
4999 Defining_Identifier
=> Formal_Entity
,
5000 Object_Definition
=>
5001 New_Occurrence_Of
(Formal_Type
, Loc
)));
5003 Append_To
(Extra_Formal_Statements
,
5004 Make_Attribute_Reference
(Loc
,
5005 Prefix
=> New_Occurrence_Of
(
5007 Attribute_Name
=> Name_Read
,
5008 Expressions
=> New_List
(
5009 Make_Selected_Component
(Loc
,
5010 Prefix
=> Request_Parameter
,
5011 Selector_Name
=> Name_Params
),
5012 New_Occurrence_Of
(Formal_Entity
, Loc
))));
5014 -- Note: the call to Set_Extra_Constrained below relies
5015 -- on the fact that Object's Ekind has been set by
5016 -- Build_Actual_Object_Declaration.
5018 Set_Extra_Constrained
(Object
, Formal_Entity
);
5023 Next
(Current_Parameter
);
5026 -- Append the formal statements list at the end of regular statements
5028 Append_List_To
(Statements
, Extra_Formal_Statements
);
5030 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
5032 -- The remote subprogram is a function. We build an inner block to
5033 -- be able to hold a potentially unconstrained result in a
5037 Etyp
: constant Entity_Id
:=
5038 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
5039 Result
: constant Node_Id
:= Make_Temporary
(Loc
, 'R');
5042 Inner_Decls
:= New_List
(
5043 Make_Object_Declaration
(Loc
,
5044 Defining_Identifier
=> Result
,
5045 Constant_Present
=> True,
5046 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
5048 Make_Function_Call
(Loc
,
5049 Name
=> Called_Subprogram
,
5050 Parameter_Associations
=> Parameter_List
)));
5052 if Is_Class_Wide_Type
(Etyp
) then
5054 -- For a remote call to a function with a class-wide type,
5055 -- check that the returned value satisfies the requirements
5058 Append_To
(Inner_Decls
,
5059 Make_Transportable_Check
(Loc
,
5060 New_Occurrence_Of
(Result
, Loc
)));
5064 Append_To
(After_Statements
,
5065 Make_Attribute_Reference
(Loc
,
5066 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5067 Attribute_Name
=> Name_Output
,
5068 Expressions
=> New_List
(
5069 Make_Selected_Component
(Loc
,
5070 Prefix
=> Request_Parameter
,
5071 Selector_Name
=> Name_Result
),
5072 New_Occurrence_Of
(Result
, Loc
))));
5075 Append_To
(Statements
,
5076 Make_Block_Statement
(Loc
,
5077 Declarations
=> Inner_Decls
,
5078 Handled_Statement_Sequence
=>
5079 Make_Handled_Sequence_Of_Statements
(Loc
,
5080 Statements
=> After_Statements
)));
5083 -- The remote subprogram is a procedure. We do not need any inner
5084 -- block in this case.
5086 if Dynamically_Asynchronous
then
5088 Make_Object_Declaration
(Loc
,
5089 Defining_Identifier
=> Dynamic_Async
,
5090 Object_Definition
=>
5091 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
5093 Append_To
(Statements
,
5094 Make_Attribute_Reference
(Loc
,
5095 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
5096 Attribute_Name
=> Name_Read
,
5097 Expressions
=> New_List
(
5098 Make_Selected_Component
(Loc
,
5099 Prefix
=> Request_Parameter
,
5100 Selector_Name
=> Name_Params
),
5101 New_Occurrence_Of
(Dynamic_Async
, Loc
))));
5104 Append_To
(Statements
,
5105 Make_Procedure_Call_Statement
(Loc
,
5106 Name
=> Called_Subprogram
,
5107 Parameter_Associations
=> Parameter_List
));
5109 Append_List_To
(Statements
, After_Statements
);
5112 if Asynchronous
and then not Dynamically_Asynchronous
then
5114 -- For an asynchronous procedure, add a null exception handler
5116 Excep_Handlers
:= New_List
(
5117 Make_Implicit_Exception_Handler
(Loc
,
5118 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5119 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
5122 -- In the other cases, if an exception is raised, then the
5123 -- exception occurrence is copied into the output stream and
5124 -- no other output parameter is written.
5126 Excep_Choice
:= Make_Temporary
(Loc
, 'E');
5128 Excep_Code
:= New_List
(
5129 Make_Attribute_Reference
(Loc
,
5131 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
5132 Attribute_Name
=> Name_Write
,
5133 Expressions
=> New_List
(
5134 Make_Selected_Component
(Loc
,
5135 Prefix
=> Request_Parameter
,
5136 Selector_Name
=> Name_Result
),
5137 New_Occurrence_Of
(Excep_Choice
, Loc
))));
5139 if Dynamically_Asynchronous
then
5140 Excep_Code
:= New_List
(
5141 Make_Implicit_If_Statement
(Vis_Decl
,
5142 Condition
=> Make_Op_Not
(Loc
,
5143 New_Occurrence_Of
(Dynamic_Async
, Loc
)),
5144 Then_Statements
=> Excep_Code
));
5147 Excep_Handlers
:= New_List
(
5148 Make_Implicit_Exception_Handler
(Loc
,
5149 Choice_Parameter
=> Excep_Choice
,
5150 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5151 Statements
=> Excep_Code
));
5156 Make_Procedure_Specification
(Loc
,
5157 Defining_Unit_Name
=> Make_Temporary
(Loc
, 'F'),
5159 Parameter_Specifications
=> New_List
(
5160 Make_Parameter_Specification
(Loc
,
5161 Defining_Identifier
=> Request_Parameter
,
5163 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
5166 Make_Subprogram_Body
(Loc
,
5167 Specification
=> Subp_Spec
,
5168 Declarations
=> Decls
,
5169 Handled_Statement_Sequence
=>
5170 Make_Handled_Sequence_Of_Statements
(Loc
,
5171 Statements
=> Statements
,
5172 Exception_Handlers
=> Excep_Handlers
));
5173 end Build_Subprogram_Receiving_Stubs
;
5179 function Result
return Node_Id
is
5181 return Make_Identifier
(Loc
, Name_V
);
5184 -----------------------
5185 -- RPC_Receiver_Decl --
5186 -----------------------
5188 function RPC_Receiver_Decl
(RACW_Type
: Entity_Id
) return Node_Id
is
5189 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5190 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5193 -- No RPC receiver for remote access-to-subprogram
5200 Make_Subprogram_Declaration
(Loc
,
5201 Build_RPC_Receiver_Specification
5202 (RPC_Receiver
=> Make_Temporary
(Loc
, 'R'),
5203 Request_Parameter
=> Make_Defining_Identifier
(Loc
, Name_R
)));
5204 end RPC_Receiver_Decl
;
5206 ----------------------
5207 -- Stream_Parameter --
5208 ----------------------
5210 function Stream_Parameter
return Node_Id
is
5212 return Make_Identifier
(Loc
, Name_S
);
5213 end Stream_Parameter
;
5217 -------------------------------
5218 -- Get_And_Reset_RACW_Bodies --
5219 -------------------------------
5221 function Get_And_Reset_RACW_Bodies
(RACW_Type
: Entity_Id
) return List_Id
is
5222 Desig
: constant Entity_Id
:=
5223 Etype
(Designated_Type
(RACW_Type
));
5225 Stub_Elements
: Stub_Structure
:= Stubs_Table
.Get
(Desig
);
5227 Body_Decls
: List_Id
;
5228 -- Returned list of declarations
5231 if Stub_Elements
= Empty_Stub_Structure
then
5233 -- Stub elements may be missing as a consequence of a previously
5239 Body_Decls
:= Stub_Elements
.Body_Decls
;
5240 Stub_Elements
.Body_Decls
:= No_List
;
5241 Stubs_Table
.Set
(Desig
, Stub_Elements
);
5243 end Get_And_Reset_RACW_Bodies
;
5245 -----------------------
5246 -- Get_Stub_Elements --
5247 -----------------------
5249 function Get_Stub_Elements
(RACW_Type
: Entity_Id
) return Stub_Structure
is
5250 Desig
: constant Entity_Id
:=
5251 Etype
(Designated_Type
(RACW_Type
));
5252 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
5254 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5255 return Stub_Elements
;
5256 end Get_Stub_Elements
;
5258 -----------------------
5259 -- Get_Subprogram_Id --
5260 -----------------------
5262 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
is
5263 Result
: constant String_Id
:= Get_Subprogram_Ids
(Def
).Str_Identifier
;
5265 pragma Assert
(Result
/= No_String
);
5267 end Get_Subprogram_Id
;
5269 -----------------------
5270 -- Get_Subprogram_Id --
5271 -----------------------
5273 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
is
5275 return Get_Subprogram_Ids
(Def
).Int_Identifier
;
5276 end Get_Subprogram_Id
;
5278 ------------------------
5279 -- Get_Subprogram_Ids --
5280 ------------------------
5282 function Get_Subprogram_Ids
5283 (Def
: Entity_Id
) return Subprogram_Identifiers
5286 return Subprogram_Identifier_Table
.Get
(Def
);
5287 end Get_Subprogram_Ids
;
5293 function Hash
(F
: Entity_Id
) return Hash_Index
is
5295 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
5298 function Hash
(F
: Name_Id
) return Hash_Index
is
5300 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
5303 --------------------------
5304 -- Input_With_Tag_Check --
5305 --------------------------
5307 function Input_With_Tag_Check
5309 Var_Type
: Entity_Id
;
5310 Stream
: Node_Id
) return Node_Id
5314 Make_Subprogram_Body
(Loc
,
5316 Make_Function_Specification
(Loc
,
5317 Defining_Unit_Name
=> Make_Temporary
(Loc
, 'S'),
5318 Result_Definition
=> New_Occurrence_Of
(Var_Type
, Loc
)),
5319 Declarations
=> No_List
,
5320 Handled_Statement_Sequence
=>
5321 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
5322 Make_Tag_Check
(Loc
,
5323 Make_Simple_Return_Statement
(Loc
,
5324 Make_Attribute_Reference
(Loc
,
5325 Prefix
=> New_Occurrence_Of
(Var_Type
, Loc
),
5326 Attribute_Name
=> Name_Input
,
5328 New_List
(Stream
)))))));
5329 end Input_With_Tag_Check
;
5331 --------------------------------
5332 -- Is_RACW_Controlling_Formal --
5333 --------------------------------
5335 function Is_RACW_Controlling_Formal
5336 (Parameter
: Node_Id
;
5337 Stub_Type
: Entity_Id
) return Boolean
5342 -- If the kind of the parameter is E_Void, then it is not a controlling
5343 -- formal (this can happen in the context of RAS).
5345 if Ekind
(Defining_Identifier
(Parameter
)) = E_Void
then
5349 -- If the parameter is not a controlling formal, then it cannot be
5350 -- possibly a RACW_Controlling_Formal.
5352 if not Is_Controlling_Formal
(Defining_Identifier
(Parameter
)) then
5356 Typ
:= Parameter_Type
(Parameter
);
5357 return (Nkind
(Typ
) = N_Access_Definition
5358 and then Etype
(Subtype_Mark
(Typ
)) = Stub_Type
)
5359 or else Etype
(Typ
) = Stub_Type
;
5360 end Is_RACW_Controlling_Formal
;
5362 ------------------------------
5363 -- Make_Transportable_Check --
5364 ------------------------------
5366 function Make_Transportable_Check
5368 Expr
: Node_Id
) return Node_Id
is
5371 Make_Raise_Program_Error
(Loc
,
5374 Build_Get_Transportable
(Loc
,
5375 Make_Selected_Component
(Loc
,
5377 Selector_Name
=> Make_Identifier
(Loc
, Name_uTag
)))),
5378 Reason
=> PE_Non_Transportable_Actual
);
5379 end Make_Transportable_Check
;
5381 -----------------------------
5382 -- Make_Selected_Component --
5383 -----------------------------
5385 function Make_Selected_Component
5388 Selector_Name
: Name_Id
) return Node_Id
5391 return Make_Selected_Component
(Loc
,
5392 Prefix
=> New_Occurrence_Of
(Prefix
, Loc
),
5393 Selector_Name
=> Make_Identifier
(Loc
, Selector_Name
));
5394 end Make_Selected_Component
;
5396 --------------------
5397 -- Make_Tag_Check --
5398 --------------------
5400 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
is
5401 Occ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
5404 return Make_Block_Statement
(Loc
,
5405 Handled_Statement_Sequence
=>
5406 Make_Handled_Sequence_Of_Statements
(Loc
,
5407 Statements
=> New_List
(N
),
5409 Exception_Handlers
=> New_List
(
5410 Make_Implicit_Exception_Handler
(Loc
,
5411 Choice_Parameter
=> Occ
,
5413 Exception_Choices
=>
5414 New_List
(New_Occurrence_Of
(RTE
(RE_Tag_Error
), Loc
)),
5417 New_List
(Make_Procedure_Call_Statement
(Loc
,
5419 (RTE
(RE_Raise_Program_Error_Unknown_Tag
), Loc
),
5420 New_List
(New_Occurrence_Of
(Occ
, Loc
))))))));
5423 ----------------------------
5424 -- Need_Extra_Constrained --
5425 ----------------------------
5427 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean is
5428 Etyp
: constant Entity_Id
:= Etype
(Parameter_Type
(Parameter
));
5430 return Out_Present
(Parameter
)
5431 and then Has_Discriminants
(Etyp
)
5432 and then not Is_Constrained
(Etyp
)
5433 and then not Is_Indefinite_Subtype
(Etyp
);
5434 end Need_Extra_Constrained
;
5436 ------------------------------------
5437 -- Pack_Entity_Into_Stream_Access --
5438 ------------------------------------
5440 function Pack_Entity_Into_Stream_Access
5444 Etyp
: Entity_Id
:= Empty
) return Node_Id
5449 if Present
(Etyp
) then
5452 Typ
:= Etype
(Object
);
5456 Pack_Node_Into_Stream_Access
(Loc
,
5458 Object
=> New_Occurrence_Of
(Object
, Loc
),
5460 end Pack_Entity_Into_Stream_Access
;
5462 ---------------------------
5463 -- Pack_Node_Into_Stream --
5464 ---------------------------
5466 function Pack_Node_Into_Stream
5470 Etyp
: Entity_Id
) return Node_Id
5472 Write_Attribute
: Name_Id
:= Name_Write
;
5475 if not Is_Constrained
(Etyp
) then
5476 Write_Attribute
:= Name_Output
;
5480 Make_Attribute_Reference
(Loc
,
5481 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5482 Attribute_Name
=> Write_Attribute
,
5483 Expressions
=> New_List
(
5484 Make_Attribute_Reference
(Loc
,
5485 Prefix
=> New_Occurrence_Of
(Stream
, Loc
),
5486 Attribute_Name
=> Name_Access
),
5488 end Pack_Node_Into_Stream
;
5490 ----------------------------------
5491 -- Pack_Node_Into_Stream_Access --
5492 ----------------------------------
5494 function Pack_Node_Into_Stream_Access
5498 Etyp
: Entity_Id
) return Node_Id
5500 Write_Attribute
: Name_Id
:= Name_Write
;
5503 if not Is_Constrained
(Etyp
) then
5504 Write_Attribute
:= Name_Output
;
5508 Make_Attribute_Reference
(Loc
,
5509 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5510 Attribute_Name
=> Write_Attribute
,
5511 Expressions
=> New_List
(
5514 end Pack_Node_Into_Stream_Access
;
5516 ---------------------
5517 -- PolyORB_Support --
5518 ---------------------
5520 package body PolyORB_Support
is
5522 -- Local subprograms
5524 procedure Add_RACW_Read_Attribute
5525 (RACW_Type
: Entity_Id
;
5526 Stub_Type
: Entity_Id
;
5527 Stub_Type_Access
: Entity_Id
;
5528 Body_Decls
: List_Id
);
5529 -- Add Read attribute for the RACW type. The declaration and attribute
5530 -- definition clauses are inserted right after the declaration of
5531 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5532 -- appended to it (case where the RACW declaration is in the main unit).
5534 procedure Add_RACW_Write_Attribute
5535 (RACW_Type
: Entity_Id
;
5536 Stub_Type
: Entity_Id
;
5537 Stub_Type_Access
: Entity_Id
;
5538 Body_Decls
: List_Id
);
5539 -- Same as above for the Write attribute
5541 procedure Add_RACW_From_Any
5542 (RACW_Type
: Entity_Id
;
5543 Body_Decls
: List_Id
);
5544 -- Add the From_Any TSS for this RACW type
5546 procedure Add_RACW_To_Any
5547 (RACW_Type
: Entity_Id
;
5548 Body_Decls
: List_Id
);
5549 -- Add the To_Any TSS for this RACW type
5551 procedure Add_RACW_TypeCode
5552 (Designated_Type
: Entity_Id
;
5553 RACW_Type
: Entity_Id
;
5554 Body_Decls
: List_Id
);
5555 -- Add the TypeCode TSS for this RACW type
5557 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
);
5558 -- Add the From_Any TSS for this RAS type
5560 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
);
5561 -- Add the To_Any TSS for this RAS type
5563 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
);
5564 -- Add the TypeCode TSS for this RAS type
5566 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
5567 -- Add a subprogram body for RAS Access TSS
5569 -------------------------------------
5570 -- Add_Obj_RPC_Receiver_Completion --
5571 -------------------------------------
5573 procedure Add_Obj_RPC_Receiver_Completion
5576 RPC_Receiver
: Entity_Id
;
5577 Stub_Elements
: Stub_Structure
)
5579 Desig
: constant Entity_Id
:=
5580 Etype
(Designated_Type
(Stub_Elements
.RACW_Type
));
5583 Make_Procedure_Call_Statement
(Loc
,
5586 RTE
(RE_Register_Obj_Receiving_Stub
), Loc
),
5588 Parameter_Associations
=> New_List
(
5592 Make_String_Literal
(Loc
,
5593 Fully_Qualified_Name_String
(Desig
, Append_NUL
=> False)),
5597 Make_Attribute_Reference
(Loc
,
5600 Defining_Unit_Name
(Parent
(RPC_Receiver
)), Loc
),
5606 Make_Attribute_Reference
(Loc
,
5609 Defining_Identifier
(
5610 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5613 end Add_Obj_RPC_Receiver_Completion
;
5615 -----------------------
5616 -- Add_RACW_Features --
5617 -----------------------
5619 procedure Add_RACW_Features
5620 (RACW_Type
: Entity_Id
;
5622 Stub_Type
: Entity_Id
;
5623 Stub_Type_Access
: Entity_Id
;
5624 RPC_Receiver_Decl
: Node_Id
;
5625 Body_Decls
: List_Id
)
5627 pragma Unreferenced
(RPC_Receiver_Decl
);
5631 (RACW_Type
=> RACW_Type
,
5632 Body_Decls
=> Body_Decls
);
5635 (RACW_Type
=> RACW_Type
,
5636 Body_Decls
=> Body_Decls
);
5638 Add_RACW_Write_Attribute
5639 (RACW_Type
=> RACW_Type
,
5640 Stub_Type
=> Stub_Type
,
5641 Stub_Type_Access
=> Stub_Type_Access
,
5642 Body_Decls
=> Body_Decls
);
5644 Add_RACW_Read_Attribute
5645 (RACW_Type
=> RACW_Type
,
5646 Stub_Type
=> Stub_Type
,
5647 Stub_Type_Access
=> Stub_Type_Access
,
5648 Body_Decls
=> Body_Decls
);
5651 (Designated_Type
=> Desig
,
5652 RACW_Type
=> RACW_Type
,
5653 Body_Decls
=> Body_Decls
);
5654 end Add_RACW_Features
;
5656 -----------------------
5657 -- Add_RACW_From_Any --
5658 -----------------------
5660 procedure Add_RACW_From_Any
5661 (RACW_Type
: Entity_Id
;
5662 Body_Decls
: List_Id
)
5664 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5665 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5666 Fnam
: constant Entity_Id
:=
5667 Make_Defining_Identifier
(Loc
,
5668 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'F'));
5670 Func_Spec
: Node_Id
;
5671 Func_Decl
: Node_Id
;
5672 Func_Body
: Node_Id
;
5674 Statements
: List_Id
;
5675 -- Various parts of the subprogram
5677 Any_Parameter
: constant Entity_Id
:=
5678 Make_Defining_Identifier
(Loc
, Name_A
);
5680 Asynchronous_Flag
: constant Entity_Id
:=
5681 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5682 -- The flag object declared in Add_RACW_Asynchronous_Flag
5686 Make_Function_Specification
(Loc
,
5687 Defining_Unit_Name
=>
5689 Parameter_Specifications
=> New_List
(
5690 Make_Parameter_Specification
(Loc
,
5691 Defining_Identifier
=>
5694 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
5695 Result_Definition
=> New_Occurrence_Of
(RACW_Type
, Loc
));
5697 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5698 -- entity in the declaration spec, not those of the body spec.
5700 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5701 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5702 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_From_Any
);
5704 if No
(Body_Decls
) then
5708 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5709 -- set on the stub type if, and only if, the RACW type has a pragma
5710 -- Asynchronous. This is incorrect for RACWs that implement RAS
5711 -- types, because in that case the /designated subprogram/ (not the
5712 -- type) might be asynchronous, and that causes the stub to need to
5713 -- be asynchronous too. A solution is to transport a RAS as a struct
5714 -- containing a RACW and an asynchronous flag, and to properly alter
5715 -- the Asynchronous component in the stub type in the RAS's _From_Any
5718 Statements
:= New_List
(
5719 Make_Simple_Return_Statement
(Loc
,
5720 Expression
=> Unchecked_Convert_To
(RACW_Type
,
5721 Make_Function_Call
(Loc
,
5722 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RACW
), Loc
),
5723 Parameter_Associations
=> New_List
(
5724 Make_Function_Call
(Loc
,
5725 Name
=> New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
5726 Parameter_Associations
=> New_List
(
5727 New_Occurrence_Of
(Any_Parameter
, Loc
))),
5728 Build_Stub_Tag
(Loc
, RACW_Type
),
5729 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5730 New_Occurrence_Of
(Asynchronous_Flag
, Loc
))))));
5733 Make_Subprogram_Body
(Loc
,
5734 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
5735 Declarations
=> No_List
,
5736 Handled_Statement_Sequence
=>
5737 Make_Handled_Sequence_Of_Statements
(Loc
,
5738 Statements
=> Statements
));
5740 Append_To
(Body_Decls
, Func_Body
);
5741 end Add_RACW_From_Any
;
5743 -----------------------------
5744 -- Add_RACW_Read_Attribute --
5745 -----------------------------
5747 procedure Add_RACW_Read_Attribute
5748 (RACW_Type
: Entity_Id
;
5749 Stub_Type
: Entity_Id
;
5750 Stub_Type_Access
: Entity_Id
;
5751 Body_Decls
: List_Id
)
5753 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
5755 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5757 Proc_Decl
: Node_Id
;
5758 Attr_Decl
: Node_Id
;
5760 Body_Node
: Node_Id
;
5762 Decls
: constant List_Id
:= New_List
;
5763 Statements
: constant List_Id
:= New_List
;
5764 Reference
: constant Entity_Id
:=
5765 Make_Defining_Identifier
(Loc
, Name_R
);
5766 -- Various parts of the procedure
5768 Pnam
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
5770 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5772 Asynchronous_Flag
: constant Entity_Id
:=
5773 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5774 pragma Assert
(Present
(Asynchronous_Flag
));
5776 function Stream_Parameter
return Node_Id
;
5777 function Result
return Node_Id
;
5779 -- Functions to create occurrences of the formal parameter names
5785 function Result
return Node_Id
is
5787 return Make_Identifier
(Loc
, Name_V
);
5790 ----------------------
5791 -- Stream_Parameter --
5792 ----------------------
5794 function Stream_Parameter
return Node_Id
is
5796 return Make_Identifier
(Loc
, Name_S
);
5797 end Stream_Parameter
;
5799 -- Start of processing for Add_RACW_Read_Attribute
5802 Build_Stream_Procedure
5803 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> True);
5805 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
5806 Copy_Specification
(Loc
, Specification
(Body_Node
)));
5809 Make_Attribute_Definition_Clause
(Loc
,
5810 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
5814 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
5816 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
5817 Insert_After
(Proc_Decl
, Attr_Decl
);
5819 if No
(Body_Decls
) then
5824 Make_Object_Declaration
(Loc
,
5825 Defining_Identifier
=>
5827 Object_Definition
=>
5828 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)));
5830 Append_List_To
(Statements
, New_List
(
5831 Make_Attribute_Reference
(Loc
,
5833 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5834 Attribute_Name
=> Name_Read
,
5835 Expressions
=> New_List
(
5837 New_Occurrence_Of
(Reference
, Loc
))),
5839 Make_Assignment_Statement
(Loc
,
5843 Unchecked_Convert_To
(RACW_Type
,
5844 Make_Function_Call
(Loc
,
5846 New_Occurrence_Of
(RTE
(RE_Get_RACW
), Loc
),
5847 Parameter_Associations
=> New_List
(
5848 New_Occurrence_Of
(Reference
, Loc
),
5849 Build_Stub_Tag
(Loc
, RACW_Type
),
5850 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5851 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)))))));
5853 Set_Declarations
(Body_Node
, Decls
);
5854 Append_To
(Body_Decls
, Body_Node
);
5855 end Add_RACW_Read_Attribute
;
5857 ---------------------
5858 -- Add_RACW_To_Any --
5859 ---------------------
5861 procedure Add_RACW_To_Any
5862 (RACW_Type
: Entity_Id
;
5863 Body_Decls
: List_Id
)
5865 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5867 Fnam
: constant Entity_Id
:=
5868 Make_Defining_Identifier
(Loc
,
5869 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'T'));
5871 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5873 Stub_Elements
: constant Stub_Structure
:=
5874 Get_Stub_Elements
(RACW_Type
);
5876 Func_Spec
: Node_Id
;
5877 Func_Decl
: Node_Id
;
5878 Func_Body
: Node_Id
;
5881 Statements
: List_Id
;
5882 -- Various parts of the subprogram
5884 RACW_Parameter
: constant Entity_Id
:=
5885 Make_Defining_Identifier
(Loc
, Name_R
);
5887 Reference
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
5888 Any
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5892 Make_Function_Specification
(Loc
,
5893 Defining_Unit_Name
=>
5895 Parameter_Specifications
=> New_List
(
5896 Make_Parameter_Specification
(Loc
,
5897 Defining_Identifier
=>
5900 New_Occurrence_Of
(RACW_Type
, Loc
))),
5901 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
5903 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5904 -- entity in the declaration spec, not in the body spec.
5906 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5908 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5909 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_To_Any
);
5911 if No
(Body_Decls
) then
5917 -- R : constant Object_Ref :=
5923 -- RPC_Receiver'Access);
5927 Make_Object_Declaration
(Loc
,
5928 Defining_Identifier
=> Reference
,
5929 Constant_Present
=> True,
5930 Object_Definition
=>
5931 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5933 Make_Function_Call
(Loc
,
5934 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
5935 Parameter_Associations
=> New_List
(
5936 Unchecked_Convert_To
(RTE
(RE_Address
),
5937 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5938 Make_String_Literal
(Loc
,
5939 Strval
=> Fully_Qualified_Name_String
5940 (Etype
(Designated_Type
(RACW_Type
)),
5941 Append_NUL
=> False)),
5942 Build_Stub_Tag
(Loc
, RACW_Type
),
5943 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5944 Make_Attribute_Reference
(Loc
,
5947 (Defining_Identifier
5948 (Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5949 Attribute_Name
=> Name_Access
)))),
5951 Make_Object_Declaration
(Loc
,
5952 Defining_Identifier
=> Any
,
5953 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
5957 -- Any := TA_ObjRef (Reference);
5958 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
5961 Statements
:= New_List
(
5962 Make_Assignment_Statement
(Loc
,
5963 Name
=> New_Occurrence_Of
(Any
, Loc
),
5965 Make_Function_Call
(Loc
,
5966 Name
=> New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
5967 Parameter_Associations
=> New_List
(
5968 New_Occurrence_Of
(Reference
, Loc
)))),
5970 Make_Procedure_Call_Statement
(Loc
,
5971 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
5972 Parameter_Associations
=> New_List
(
5973 New_Occurrence_Of
(Any
, Loc
),
5974 Make_Selected_Component
(Loc
,
5976 Defining_Identifier
(
5977 Stub_Elements
.RPC_Receiver_Decl
),
5978 Selector_Name
=> Name_Obj_TypeCode
))),
5980 Make_Simple_Return_Statement
(Loc
,
5981 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
5984 Make_Subprogram_Body
(Loc
,
5985 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
5986 Declarations
=> Decls
,
5987 Handled_Statement_Sequence
=>
5988 Make_Handled_Sequence_Of_Statements
(Loc
,
5989 Statements
=> Statements
));
5990 Append_To
(Body_Decls
, Func_Body
);
5991 end Add_RACW_To_Any
;
5993 -----------------------
5994 -- Add_RACW_TypeCode --
5995 -----------------------
5997 procedure Add_RACW_TypeCode
5998 (Designated_Type
: Entity_Id
;
5999 RACW_Type
: Entity_Id
;
6000 Body_Decls
: List_Id
)
6002 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
6004 Fnam
: constant Entity_Id
:=
6005 Make_Defining_Identifier
(Loc
,
6006 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'Y'));
6008 Stub_Elements
: constant Stub_Structure
:=
6009 Stubs_Table
.Get
(Designated_Type
);
6010 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
6012 Func_Spec
: Node_Id
;
6013 Func_Decl
: Node_Id
;
6014 Func_Body
: Node_Id
;
6017 -- The spec for this subprogram has a dummy 'access RACW' argument,
6018 -- which serves only for overloading purposes.
6021 Make_Function_Specification
(Loc
,
6022 Defining_Unit_Name
=> Fnam
,
6023 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6025 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6026 -- entity in the declaration spec, not those of the body spec.
6028 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
6029 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
6030 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_TypeCode
);
6032 if No
(Body_Decls
) then
6037 Make_Subprogram_Body
(Loc
,
6038 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
6039 Declarations
=> Empty_List
,
6040 Handled_Statement_Sequence
=>
6041 Make_Handled_Sequence_Of_Statements
(Loc
,
6042 Statements
=> New_List
(
6043 Make_Simple_Return_Statement
(Loc
,
6045 Make_Selected_Component
(Loc
,
6048 (Stub_Elements
.RPC_Receiver_Decl
),
6049 Selector_Name
=> Name_Obj_TypeCode
)))));
6051 Append_To
(Body_Decls
, Func_Body
);
6052 end Add_RACW_TypeCode
;
6054 ------------------------------
6055 -- Add_RACW_Write_Attribute --
6056 ------------------------------
6058 procedure Add_RACW_Write_Attribute
6059 (RACW_Type
: Entity_Id
;
6060 Stub_Type
: Entity_Id
;
6061 Stub_Type_Access
: Entity_Id
;
6062 Body_Decls
: List_Id
)
6064 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
6066 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
6068 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
6070 Stub_Elements
: constant Stub_Structure
:=
6071 Get_Stub_Elements
(RACW_Type
);
6073 Body_Node
: Node_Id
;
6074 Proc_Decl
: Node_Id
;
6075 Attr_Decl
: Node_Id
;
6077 Statements
: constant List_Id
:= New_List
;
6078 Pnam
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
6080 function Stream_Parameter
return Node_Id
;
6081 function Object
return Node_Id
;
6082 -- Functions to create occurrences of the formal parameter names
6088 function Object
return Node_Id
is
6090 return Make_Identifier
(Loc
, Name_V
);
6093 ----------------------
6094 -- Stream_Parameter --
6095 ----------------------
6097 function Stream_Parameter
return Node_Id
is
6099 return Make_Identifier
(Loc
, Name_S
);
6100 end Stream_Parameter
;
6102 -- Start of processing for Add_RACW_Write_Attribute
6105 Build_Stream_Procedure
6106 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> False);
6109 Make_Subprogram_Declaration
(Loc
,
6110 Copy_Specification
(Loc
, Specification
(Body_Node
)));
6113 Make_Attribute_Definition_Clause
(Loc
,
6114 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
6115 Chars
=> Name_Write
,
6118 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
6120 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
6121 Insert_After
(Proc_Decl
, Attr_Decl
);
6123 if No
(Body_Decls
) then
6127 Append_To
(Statements
,
6128 Pack_Node_Into_Stream_Access
(Loc
,
6129 Stream
=> Stream_Parameter
,
6131 Make_Function_Call
(Loc
,
6132 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
6133 Parameter_Associations
=> New_List
(
6134 Unchecked_Convert_To
(RTE
(RE_Address
), Object
),
6135 Make_String_Literal
(Loc
,
6136 Strval
=> Fully_Qualified_Name_String
6137 (Etype
(Designated_Type
(RACW_Type
)),
6138 Append_NUL
=> False)),
6139 Build_Stub_Tag
(Loc
, RACW_Type
),
6140 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
6141 Make_Attribute_Reference
(Loc
,
6144 (Defining_Identifier
6145 (Stub_Elements
.RPC_Receiver_Decl
), Loc
),
6146 Attribute_Name
=> Name_Access
))),
6148 Etyp
=> RTE
(RE_Object_Ref
)));
6150 Append_To
(Body_Decls
, Body_Node
);
6151 end Add_RACW_Write_Attribute
;
6153 -----------------------
6154 -- Add_RAST_Features --
6155 -----------------------
6157 procedure Add_RAST_Features
6158 (Vis_Decl
: Node_Id
;
6159 RAS_Type
: Entity_Id
)
6162 Add_RAS_Access_TSS
(Vis_Decl
);
6164 Add_RAS_From_Any
(RAS_Type
);
6165 Add_RAS_TypeCode
(RAS_Type
);
6167 -- To_Any uses TypeCode, and therefore needs to be generated last
6169 Add_RAS_To_Any
(RAS_Type
);
6170 end Add_RAST_Features
;
6172 ------------------------
6173 -- Add_RAS_Access_TSS --
6174 ------------------------
6176 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
6177 Loc
: constant Source_Ptr
:= Sloc
(N
);
6179 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
6180 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
6181 -- Ras_Type is the access to subprogram type; Fat_Type is the
6182 -- corresponding record type.
6184 RACW_Type
: constant Entity_Id
:=
6185 Underlying_RACW_Type
(Ras_Type
);
6187 Stub_Elements
: constant Stub_Structure
:=
6188 Get_Stub_Elements
(RACW_Type
);
6190 Proc
: constant Entity_Id
:=
6191 Make_Defining_Identifier
(Loc
,
6192 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
6194 Proc_Spec
: Node_Id
;
6196 -- Formal parameters
6198 Package_Name
: constant Entity_Id
:=
6199 Make_Defining_Identifier
(Loc
,
6204 Subp_Id
: constant Entity_Id
:=
6205 Make_Defining_Identifier
(Loc
,
6208 -- Target subprogram
6210 Asynch_P
: constant Entity_Id
:=
6211 Make_Defining_Identifier
(Loc
,
6212 Chars
=> Name_Asynchronous
);
6213 -- Is the procedure to which the 'Access applies asynchronous?
6215 All_Calls_Remote
: constant Entity_Id
:=
6216 Make_Defining_Identifier
(Loc
,
6217 Chars
=> Name_All_Calls_Remote
);
6218 -- True if an All_Calls_Remote pragma applies to the RCI unit
6219 -- that contains the subprogram.
6221 -- Common local variables
6223 Proc_Decls
: List_Id
;
6224 Proc_Statements
: List_Id
;
6226 Subp_Ref
: constant Entity_Id
:=
6227 Make_Defining_Identifier
(Loc
, Name_R
);
6228 -- Reference that designates the target subprogram (returned
6229 -- by Get_RAS_Info).
6231 Is_Local
: constant Entity_Id
:=
6232 Make_Defining_Identifier
(Loc
, Name_L
);
6233 Local_Addr
: constant Entity_Id
:=
6234 Make_Defining_Identifier
(Loc
, Name_A
);
6235 -- For the call to Get_Local_Address
6237 Local_Stub
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
6238 Stub_Ptr
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
6239 -- Additional local variables for the remote case
6242 (Field_Name
: Name_Id
;
6243 Value
: Node_Id
) return Node_Id
;
6244 -- Construct an assignment that sets the named component in the
6252 (Field_Name
: Name_Id
;
6253 Value
: Node_Id
) return Node_Id
6257 Make_Assignment_Statement
(Loc
,
6259 Make_Selected_Component
(Loc
,
6261 Selector_Name
=> Field_Name
),
6262 Expression
=> Value
);
6265 -- Start of processing for Add_RAS_Access_TSS
6268 Proc_Decls
:= New_List
(
6270 -- Common declarations
6272 Make_Object_Declaration
(Loc
,
6273 Defining_Identifier
=> Subp_Ref
,
6274 Object_Definition
=>
6275 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
6277 Make_Object_Declaration
(Loc
,
6278 Defining_Identifier
=> Is_Local
,
6279 Object_Definition
=>
6280 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6282 Make_Object_Declaration
(Loc
,
6283 Defining_Identifier
=> Local_Addr
,
6284 Object_Definition
=>
6285 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
6287 Make_Object_Declaration
(Loc
,
6288 Defining_Identifier
=> Local_Stub
,
6289 Aliased_Present
=> True,
6290 Object_Definition
=>
6291 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
6293 Make_Object_Declaration
(Loc
,
6294 Defining_Identifier
=> Stub_Ptr
,
6295 Object_Definition
=>
6296 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
6298 Make_Attribute_Reference
(Loc
,
6299 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
6300 Attribute_Name
=> Name_Unchecked_Access
)));
6302 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
6303 -- Build_Get_Unique_RP_Call needs this information
6305 -- Get_RAS_Info (Pkg, Subp, R);
6306 -- Obtain a reference to the target subprogram
6308 Proc_Statements
:= New_List
(
6309 Make_Procedure_Call_Statement
(Loc
,
6310 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
6311 Parameter_Associations
=> New_List
(
6312 New_Occurrence_Of
(Package_Name
, Loc
),
6313 New_Occurrence_Of
(Subp_Id
, Loc
),
6314 New_Occurrence_Of
(Subp_Ref
, Loc
))),
6316 -- Get_Local_Address (R, L, A);
6317 -- Determine whether the subprogram is local (L), and if so
6318 -- obtain the local address of its proxy (A).
6320 Make_Procedure_Call_Statement
(Loc
,
6321 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6322 Parameter_Associations
=> New_List
(
6323 New_Occurrence_Of
(Subp_Ref
, Loc
),
6324 New_Occurrence_Of
(Is_Local
, Loc
),
6325 New_Occurrence_Of
(Local_Addr
, Loc
))));
6327 -- Note: Here we assume that the Fat_Type is a record containing just
6328 -- an access to a proxy or stub object.
6330 Append_To
(Proc_Statements
,
6334 Make_Implicit_If_Statement
(N
,
6335 Condition
=> New_Occurrence_Of
(Is_Local
, Loc
),
6337 Then_Statements
=> New_List
(
6339 -- if A.Target = null then
6341 Make_Implicit_If_Statement
(N
,
6344 Make_Selected_Component
(Loc
,
6346 Unchecked_Convert_To
6347 (RTE
(RE_RAS_Proxy_Type_Access
),
6348 New_Occurrence_Of
(Local_Addr
, Loc
)),
6349 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)),
6352 Then_Statements
=> New_List
(
6354 -- A.Target := Entity_Of (Ref);
6356 Make_Assignment_Statement
(Loc
,
6358 Make_Selected_Component
(Loc
,
6360 Unchecked_Convert_To
6361 (RTE
(RE_RAS_Proxy_Type_Access
),
6362 New_Occurrence_Of
(Local_Addr
, Loc
)),
6363 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)),
6365 Make_Function_Call
(Loc
,
6366 Name
=> New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6367 Parameter_Associations
=> New_List
(
6368 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6370 -- Inc_Usage (A.Target);
6373 Make_Procedure_Call_Statement
(Loc
,
6374 Name
=> New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6375 Parameter_Associations
=> New_List
(
6376 Make_Selected_Component
(Loc
,
6378 Unchecked_Convert_To
6379 (RTE
(RE_RAS_Proxy_Type_Access
),
6380 New_Occurrence_Of
(Local_Addr
, Loc
)),
6382 Make_Identifier
(Loc
, Name_Target
)))))),
6384 -- if not All_Calls_Remote then
6385 -- return Fat_Type!(A);
6388 Make_Implicit_If_Statement
(N
,
6392 New_Occurrence_Of
(All_Calls_Remote
, Loc
)),
6394 Then_Statements
=> New_List
(
6395 Make_Simple_Return_Statement
(Loc
,
6397 Unchecked_Convert_To
6398 (Fat_Type
, New_Occurrence_Of
(Local_Addr
, Loc
))))))));
6400 Append_List_To
(Proc_Statements
, New_List
(
6402 -- Stub.Target := Entity_Of (Ref);
6404 Set_Field
(Name_Target
,
6405 Make_Function_Call
(Loc
,
6406 Name
=> New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6407 Parameter_Associations
=> New_List
(
6408 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6410 -- Inc_Usage (Stub.Target);
6412 Make_Procedure_Call_Statement
(Loc
,
6413 Name
=> New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6414 Parameter_Associations
=> New_List
(
6415 Make_Selected_Component
(Loc
,
6417 Selector_Name
=> Name_Target
))),
6419 -- E.4.1(9) A remote call is asynchronous if it is a call to
6420 -- a procedure, or a call through a value of an access-to-procedure
6421 -- type, to which a pragma Asynchronous applies.
6423 -- Parameter Asynch_P is true when the procedure is asynchronous;
6424 -- Expression Asynch_T is true when the type is asynchronous.
6426 Set_Field
(Name_Asynchronous
,
6428 Left_Opnd
=> New_Occurrence_Of
(Asynch_P
, Loc
),
6431 (Boolean_Literals
(Is_Asynchronous
(Ras_Type
)), Loc
)))));
6433 Append_List_To
(Proc_Statements
,
6434 Build_Get_Unique_RP_Call
(Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
6436 Append_To
(Proc_Statements
,
6437 Make_Simple_Return_Statement
(Loc
,
6439 Unchecked_Convert_To
(Fat_Type
,
6440 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
6443 Make_Function_Specification
(Loc
,
6444 Defining_Unit_Name
=> Proc
,
6445 Parameter_Specifications
=> New_List
(
6446 Make_Parameter_Specification
(Loc
,
6447 Defining_Identifier
=> Package_Name
,
6449 New_Occurrence_Of
(Standard_String
, Loc
)),
6451 Make_Parameter_Specification
(Loc
,
6452 Defining_Identifier
=> Subp_Id
,
6454 New_Occurrence_Of
(Standard_String
, Loc
)),
6456 Make_Parameter_Specification
(Loc
,
6457 Defining_Identifier
=> Asynch_P
,
6459 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6461 Make_Parameter_Specification
(Loc
,
6462 Defining_Identifier
=> All_Calls_Remote
,
6464 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
6466 Result_Definition
=>
6467 New_Occurrence_Of
(Fat_Type
, Loc
));
6469 -- Set the kind and return type of the function to prevent
6470 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6472 Set_Ekind
(Proc
, E_Function
);
6473 Set_Etype
(Proc
, Fat_Type
);
6476 Make_Subprogram_Body
(Loc
,
6477 Specification
=> Proc_Spec
,
6478 Declarations
=> Proc_Decls
,
6479 Handled_Statement_Sequence
=>
6480 Make_Handled_Sequence_Of_Statements
(Loc
,
6481 Statements
=> Proc_Statements
)));
6483 Set_TSS
(Fat_Type
, Proc
);
6484 end Add_RAS_Access_TSS
;
6486 ----------------------
6487 -- Add_RAS_From_Any --
6488 ----------------------
6490 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
) is
6491 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6493 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6494 Make_TSS_Name
(RAS_Type
, TSS_From_Any
));
6496 Func_Spec
: Node_Id
;
6498 Statements
: List_Id
;
6500 Any_Parameter
: constant Entity_Id
:=
6501 Make_Defining_Identifier
(Loc
, Name_A
);
6504 Statements
:= New_List
(
6505 Make_Simple_Return_Statement
(Loc
,
6507 Make_Aggregate
(Loc
,
6508 Component_Associations
=> New_List
(
6509 Make_Component_Association
(Loc
,
6510 Choices
=> New_List
(Make_Identifier
(Loc
, Name_Ras
)),
6512 PolyORB_Support
.Helpers
.Build_From_Any_Call
6513 (Underlying_RACW_Type
(RAS_Type
),
6514 New_Occurrence_Of
(Any_Parameter
, Loc
),
6518 Make_Function_Specification
(Loc
,
6519 Defining_Unit_Name
=> Fnam
,
6520 Parameter_Specifications
=> New_List
(
6521 Make_Parameter_Specification
(Loc
,
6522 Defining_Identifier
=> Any_Parameter
,
6523 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
6524 Result_Definition
=> New_Occurrence_Of
(RAS_Type
, Loc
));
6527 Make_Subprogram_Body
(Loc
,
6528 Specification
=> Func_Spec
,
6529 Declarations
=> No_List
,
6530 Handled_Statement_Sequence
=>
6531 Make_Handled_Sequence_Of_Statements
(Loc
,
6532 Statements
=> Statements
)));
6533 Set_TSS
(RAS_Type
, Fnam
);
6534 end Add_RAS_From_Any
;
6536 --------------------
6537 -- Add_RAS_To_Any --
6538 --------------------
6540 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
) is
6541 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6543 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6544 Make_TSS_Name
(RAS_Type
, TSS_To_Any
));
6547 Statements
: List_Id
;
6549 Func_Spec
: Node_Id
;
6551 Any
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
6552 RAS_Parameter
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
6553 RACW_Parameter
: constant Node_Id
:=
6554 Make_Selected_Component
(Loc
,
6555 Prefix
=> RAS_Parameter
,
6556 Selector_Name
=> Name_Ras
);
6559 -- Object declarations
6561 Set_Etype
(RACW_Parameter
, Underlying_RACW_Type
(RAS_Type
));
6563 Make_Object_Declaration
(Loc
,
6564 Defining_Identifier
=> Any
,
6565 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
6567 PolyORB_Support
.Helpers
.Build_To_Any_Call
6568 (Loc
, RACW_Parameter
, No_List
)));
6570 Statements
:= New_List
(
6571 Make_Procedure_Call_Statement
(Loc
,
6572 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
6573 Parameter_Associations
=> New_List
(
6574 New_Occurrence_Of
(Any
, Loc
),
6575 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
6578 Make_Simple_Return_Statement
(Loc
,
6579 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
6582 Make_Function_Specification
(Loc
,
6583 Defining_Unit_Name
=> Fnam
,
6584 Parameter_Specifications
=> New_List
(
6585 Make_Parameter_Specification
(Loc
,
6586 Defining_Identifier
=> RAS_Parameter
,
6587 Parameter_Type
=> New_Occurrence_Of
(RAS_Type
, Loc
))),
6588 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
6591 Make_Subprogram_Body
(Loc
,
6592 Specification
=> Func_Spec
,
6593 Declarations
=> Decls
,
6594 Handled_Statement_Sequence
=>
6595 Make_Handled_Sequence_Of_Statements
(Loc
,
6596 Statements
=> Statements
)));
6597 Set_TSS
(RAS_Type
, Fnam
);
6600 ----------------------
6601 -- Add_RAS_TypeCode --
6602 ----------------------
6604 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
) is
6605 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6607 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6608 Make_TSS_Name
(RAS_Type
, TSS_TypeCode
));
6610 Func_Spec
: Node_Id
;
6611 Decls
: constant List_Id
:= New_List
;
6612 Name_String
: String_Id
;
6613 Repo_Id_String
: String_Id
;
6617 Make_Function_Specification
(Loc
,
6618 Defining_Unit_Name
=> Fnam
,
6619 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6621 PolyORB_Support
.Helpers
.Build_Name_And_Repository_Id
6622 (RAS_Type
, Name_Str
=> Name_String
, Repo_Id_Str
=> Repo_Id_String
);
6625 Make_Subprogram_Body
(Loc
,
6626 Specification
=> Func_Spec
,
6627 Declarations
=> Decls
,
6628 Handled_Statement_Sequence
=>
6629 Make_Handled_Sequence_Of_Statements
(Loc
,
6630 Statements
=> New_List
(
6631 Make_Simple_Return_Statement
(Loc
,
6633 Make_Function_Call
(Loc
,
6635 New_Occurrence_Of
(RTE
(RE_Build_Complex_TC
), Loc
),
6636 Parameter_Associations
=> New_List
(
6637 New_Occurrence_Of
(RTE
(RE_Tk_Objref
), Loc
),
6638 Make_Aggregate
(Loc
,
6641 Make_Function_Call
(Loc
,
6644 (RTE
(RE_TA_Std_String
), Loc
),
6645 Parameter_Associations
=> New_List
(
6646 Make_String_Literal
(Loc
, Name_String
))),
6647 Make_Function_Call
(Loc
,
6650 (RTE
(RE_TA_Std_String
), Loc
),
6651 Parameter_Associations
=> New_List
(
6652 Make_String_Literal
(Loc
,
6653 Strval
=> Repo_Id_String
))))))))))));
6654 Set_TSS
(RAS_Type
, Fnam
);
6655 end Add_RAS_TypeCode
;
6657 -----------------------------------------
6658 -- Add_Receiving_Stubs_To_Declarations --
6659 -----------------------------------------
6661 procedure Add_Receiving_Stubs_To_Declarations
6662 (Pkg_Spec
: Node_Id
;
6666 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
6668 Pkg_RPC_Receiver
: constant Entity_Id
:=
6669 Make_Temporary
(Loc
, 'H');
6670 Pkg_RPC_Receiver_Object
: Node_Id
;
6671 Pkg_RPC_Receiver_Body
: Node_Id
;
6672 Pkg_RPC_Receiver_Decls
: List_Id
;
6673 Pkg_RPC_Receiver_Statements
: List_Id
;
6675 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
6676 -- A Pkg_RPC_Receiver is built to decode the request
6679 -- Request object received from neutral layer
6681 Subp_Id
: Entity_Id
;
6682 -- Subprogram identifier as received from the neutral distribution
6685 Subp_Index
: Entity_Id
;
6686 -- Internal index as determined by matching either the method name
6687 -- from the request structure, or the local subprogram address (in
6690 Is_Local
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
6692 Local_Address
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
6693 -- Address of a local subprogram designated by a reference
6694 -- corresponding to a RAS.
6696 Dispatch_On_Address
: constant List_Id
:= New_List
;
6697 Dispatch_On_Name
: constant List_Id
:= New_List
;
6699 Current_Subp_Number
: Int
:= First_RCI_Subprogram_Id
;
6701 Subp_Info_Array
: constant Entity_Id
:= Make_Temporary
(Loc
, 'I');
6702 Subp_Info_List
: constant List_Id
:= New_List
;
6704 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
6706 All_Calls_Remote_E
: Entity_Id
;
6708 procedure Append_Stubs_To
6709 (RPC_Receiver_Cases
: List_Id
;
6710 Declaration
: Node_Id
;
6713 Subp_Dist_Name
: Entity_Id
;
6714 Subp_Proxy_Addr
: Entity_Id
);
6715 -- Add one case to the specified RPC receiver case list associating
6716 -- Subprogram_Number with the subprogram declared by Declaration, for
6717 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6718 -- subprogram index. Subp_Dist_Name is the string used to call the
6719 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6720 -- object, used in the context of calls through remote
6721 -- access-to-subprogram types.
6723 procedure Visit_Subprogram
(Decl
: Node_Id
);
6724 -- Generate receiving stub for one remote subprogram
6726 ---------------------
6727 -- Append_Stubs_To --
6728 ---------------------
6730 procedure Append_Stubs_To
6731 (RPC_Receiver_Cases
: List_Id
;
6732 Declaration
: Node_Id
;
6735 Subp_Dist_Name
: Entity_Id
;
6736 Subp_Proxy_Addr
: Entity_Id
)
6738 Case_Stmts
: List_Id
;
6740 Case_Stmts
:= New_List
(
6741 Make_Procedure_Call_Statement
(Loc
,
6744 Defining_Entity
(Stubs
), Loc
),
6745 Parameter_Associations
=>
6746 New_List
(New_Occurrence_Of
(Request
, Loc
))));
6748 if Nkind
(Specification
(Declaration
)) = N_Function_Specification
6750 Is_Asynchronous
(Defining_Entity
(Specification
(Declaration
)))
6752 Append_To
(Case_Stmts
, Make_Simple_Return_Statement
(Loc
));
6755 Append_To
(RPC_Receiver_Cases
,
6756 Make_Case_Statement_Alternative
(Loc
,
6758 New_List
(Make_Integer_Literal
(Loc
, Subp_Number
)),
6759 Statements
=> Case_Stmts
));
6761 Append_To
(Dispatch_On_Name
,
6762 Make_Elsif_Part
(Loc
,
6764 Make_Function_Call
(Loc
,
6766 New_Occurrence_Of
(RTE
(RE_Caseless_String_Eq
), Loc
),
6767 Parameter_Associations
=> New_List
(
6768 New_Occurrence_Of
(Subp_Id
, Loc
),
6769 New_Occurrence_Of
(Subp_Dist_Name
, Loc
))),
6771 Then_Statements
=> New_List
(
6772 Make_Assignment_Statement
(Loc
,
6773 New_Occurrence_Of
(Subp_Index
, Loc
),
6774 Make_Integer_Literal
(Loc
, Subp_Number
)))));
6776 Append_To
(Dispatch_On_Address
,
6777 Make_Elsif_Part
(Loc
,
6780 Left_Opnd
=> New_Occurrence_Of
(Local_Address
, Loc
),
6781 Right_Opnd
=> New_Occurrence_Of
(Subp_Proxy_Addr
, Loc
)),
6783 Then_Statements
=> New_List
(
6784 Make_Assignment_Statement
(Loc
,
6785 New_Occurrence_Of
(Subp_Index
, Loc
),
6786 Make_Integer_Literal
(Loc
, Subp_Number
)))));
6787 end Append_Stubs_To
;
6789 ----------------------
6790 -- Visit_Subprogram --
6791 ----------------------
6793 procedure Visit_Subprogram
(Decl
: Node_Id
) is
6794 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
6795 Spec
: constant Node_Id
:= Specification
(Decl
);
6796 Subp_Def
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
6798 Subp_Val
: String_Id
;
6800 Subp_Dist_Name
: constant Entity_Id
:=
6801 Make_Defining_Identifier
(Loc
,
6804 (Related_Id
=> Chars
(Subp_Def
),
6806 Suffix_Index
=> -1));
6808 Current_Stubs
: Node_Id
;
6809 Proxy_Obj_Addr
: Entity_Id
;
6812 -- Disable expansion of stubs if serious errors have been
6813 -- diagnosed, because otherwise some illegal remote subprogram
6814 -- declarations could cause cascaded errors in stubs.
6816 if Serious_Errors_Detected
/= 0 then
6820 -- Build receiving stub
6823 Build_Subprogram_Receiving_Stubs
6825 Asynchronous
=> Nkind
(Spec
) = N_Procedure_Specification
6826 and then Is_Asynchronous
(Subp_Def
));
6828 Append_To
(Decls
, Current_Stubs
);
6829 Analyze
(Current_Stubs
);
6833 Add_RAS_Proxy_And_Analyze
(Decls
,
6835 All_Calls_Remote_E
=> All_Calls_Remote_E
,
6836 Proxy_Object_Addr
=> Proxy_Obj_Addr
);
6838 -- Compute distribution identifier
6840 Assign_Subprogram_Identifier
6841 (Subp_Def
, Current_Subp_Number
, Subp_Val
);
6844 (Current_Subp_Number
= Get_Subprogram_Id
(Subp_Def
));
6847 Make_Object_Declaration
(Loc
,
6848 Defining_Identifier
=> Subp_Dist_Name
,
6849 Constant_Present
=> True,
6850 Object_Definition
=>
6851 New_Occurrence_Of
(Standard_String
, Loc
),
6853 Make_String_Literal
(Loc
, Subp_Val
)));
6854 Analyze
(Last
(Decls
));
6856 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
6857 -- table for this receiver. The aggregate below must be kept
6858 -- consistent with the declaration of RCI_Subp_Info in
6859 -- System.Partition_Interface.
6861 Append_To
(Subp_Info_List
,
6862 Make_Component_Association
(Loc
,
6864 New_List
(Make_Integer_Literal
(Loc
, Current_Subp_Number
)),
6867 Make_Aggregate
(Loc
,
6868 Expressions
=> New_List
(
6872 Make_Attribute_Reference
(Loc
,
6874 New_Occurrence_Of
(Subp_Dist_Name
, Loc
),
6875 Attribute_Name
=> Name_Address
),
6879 Make_Attribute_Reference
(Loc
,
6881 New_Occurrence_Of
(Subp_Dist_Name
, Loc
),
6882 Attribute_Name
=> Name_Length
),
6886 New_Occurrence_Of
(Proxy_Obj_Addr
, Loc
)))));
6888 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
6889 Declaration
=> Decl
,
6890 Stubs
=> Current_Stubs
,
6891 Subp_Number
=> Current_Subp_Number
,
6892 Subp_Dist_Name
=> Subp_Dist_Name
,
6893 Subp_Proxy_Addr
=> Proxy_Obj_Addr
);
6895 Current_Subp_Number
:= Current_Subp_Number
+ 1;
6896 end Visit_Subprogram
;
6898 procedure Visit_Spec
is new Build_Package_Stubs
(Visit_Subprogram
);
6900 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6903 -- Building receiving stubs consist in several operations:
6905 -- - a package RPC receiver must be built. This subprogram will get
6906 -- a Subprogram_Id from the incoming stream and will dispatch the
6907 -- call to the right subprogram;
6909 -- - a receiving stub for each subprogram visible in the package
6910 -- spec. This stub will read all the parameters from the stream,
6911 -- and put the result as well as the exception occurrence in the
6914 Build_RPC_Receiver_Body
(
6915 RPC_Receiver
=> Pkg_RPC_Receiver
,
6918 Subp_Index
=> Subp_Index
,
6919 Stmts
=> Pkg_RPC_Receiver_Statements
,
6920 Decl
=> Pkg_RPC_Receiver_Body
);
6921 Pkg_RPC_Receiver_Decls
:= Declarations
(Pkg_RPC_Receiver_Body
);
6923 -- Extract local address information from the target reference:
6924 -- if non-null, that means that this is a reference that denotes
6925 -- one particular operation, and hence that the operation name
6926 -- must not be taken into account for dispatching.
6928 Append_To
(Pkg_RPC_Receiver_Decls
,
6929 Make_Object_Declaration
(Loc
,
6930 Defining_Identifier
=> Is_Local
,
6931 Object_Definition
=>
6932 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
6934 Append_To
(Pkg_RPC_Receiver_Decls
,
6935 Make_Object_Declaration
(Loc
,
6936 Defining_Identifier
=> Local_Address
,
6937 Object_Definition
=>
6938 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6940 Append_To
(Pkg_RPC_Receiver_Statements
,
6941 Make_Procedure_Call_Statement
(Loc
,
6942 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6943 Parameter_Associations
=> New_List
(
6944 Make_Selected_Component
(Loc
,
6946 Selector_Name
=> Name_Target
),
6947 New_Occurrence_Of
(Is_Local
, Loc
),
6948 New_Occurrence_Of
(Local_Address
, Loc
))));
6950 -- For each subprogram, the receiving stub will be built and a case
6951 -- statement will be made on the Subprogram_Id to dispatch to the
6952 -- right subprogram.
6954 All_Calls_Remote_E
:= Boolean_Literals
(
6955 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
6957 Overload_Counter_Table
.Reset
;
6958 Reserve_NamingContext_Methods
;
6960 Visit_Spec
(Pkg_Spec
);
6963 Make_Object_Declaration
(Loc
,
6964 Defining_Identifier
=> Subp_Info_Array
,
6965 Constant_Present
=> True,
6966 Aliased_Present
=> True,
6967 Object_Definition
=>
6968 Make_Subtype_Indication
(Loc
,
6970 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
6972 Make_Index_Or_Discriminant_Constraint
(Loc
,
6976 Make_Integer_Literal
(Loc
,
6977 Intval
=> First_RCI_Subprogram_Id
),
6979 Make_Integer_Literal
(Loc
,
6981 First_RCI_Subprogram_Id
6982 + List_Length
(Subp_Info_List
) - 1)))))));
6984 if Present
(First
(Subp_Info_List
)) then
6985 Set_Expression
(Last
(Decls
),
6986 Make_Aggregate
(Loc
,
6987 Component_Associations
=> Subp_Info_List
));
6989 -- Generate the dispatch statement to determine the subprogram id
6990 -- of the called subprogram.
6992 -- We first test whether the reference that was used to make the
6993 -- call was the base RCI reference (in which case Local_Address is
6994 -- zero, and the method identifier from the request must be used
6995 -- to determine which subprogram is called) or a reference
6996 -- identifying one particular subprogram (in which case
6997 -- Local_Address is the address of that subprogram, and the
6998 -- method name from the request is ignored). The latter occurs
6999 -- for the case of a call through a remote access-to-subprogram.
7001 -- In each case, cascaded elsifs are used to determine the proper
7002 -- subprogram index. Using hash tables might be more efficient.
7004 Append_To
(Pkg_RPC_Receiver_Statements
,
7005 Make_Implicit_If_Statement
(Pkg_Spec
,
7008 Left_Opnd
=> New_Occurrence_Of
(Local_Address
, Loc
),
7009 Right_Opnd
=> New_Occurrence_Of
7010 (RTE
(RE_Null_Address
), Loc
)),
7012 Then_Statements
=> New_List
(
7013 Make_Implicit_If_Statement
(Pkg_Spec
,
7014 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
7015 Then_Statements
=> New_List
(
7016 Make_Null_Statement
(Loc
)),
7017 Elsif_Parts
=> Dispatch_On_Address
)),
7019 Else_Statements
=> New_List
(
7020 Make_Implicit_If_Statement
(Pkg_Spec
,
7021 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
7022 Then_Statements
=> New_List
(Make_Null_Statement
(Loc
)),
7023 Elsif_Parts
=> Dispatch_On_Name
))));
7026 -- For a degenerate RCI with no visible subprograms,
7027 -- Subp_Info_List has zero length, and the declaration is for an
7028 -- empty array, in which case no initialization aggregate must be
7029 -- generated. We do not generate a Dispatch_Statement either.
7031 -- No initialization provided: remove CONSTANT so that the
7032 -- declaration is not an incomplete deferred constant.
7034 Set_Constant_Present
(Last
(Decls
), False);
7037 -- Analyze Subp_Info_Array declaration
7039 Analyze
(Last
(Decls
));
7041 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7042 -- rather than raising an exception since we do not want someone
7043 -- to crash a remote partition by sending invalid subprogram ids.
7044 -- This is consistent with the other parts of the case statement
7045 -- since even in presence of incorrect parameters in the stream,
7046 -- every exception will be caught and (if the subprogram is not an
7047 -- APC) put into the result stream and sent away.
7049 Append_To
(Pkg_RPC_Receiver_Cases
,
7050 Make_Case_Statement_Alternative
(Loc
,
7051 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7052 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
7054 Append_To
(Pkg_RPC_Receiver_Statements
,
7055 Make_Case_Statement
(Loc
,
7056 Expression
=> New_Occurrence_Of
(Subp_Index
, Loc
),
7057 Alternatives
=> Pkg_RPC_Receiver_Cases
));
7059 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7062 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
7063 Analyze
(Last
(Decls
));
7065 Pkg_RPC_Receiver_Object
:=
7066 Make_Object_Declaration
(Loc
,
7067 Defining_Identifier
=> Make_Temporary
(Loc
, 'R'),
7068 Aliased_Present
=> True,
7069 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7070 Append_To
(Decls
, Pkg_RPC_Receiver_Object
);
7071 Analyze
(Last
(Decls
));
7075 Append_To
(Register_Pkg_Actuals
,
7076 Make_String_Literal
(Loc
,
7078 Fully_Qualified_Name_String
7079 (Defining_Entity
(Pkg_Spec
), Append_NUL
=> False)));
7083 Append_To
(Register_Pkg_Actuals
,
7084 Make_Attribute_Reference
(Loc
,
7087 (Defining_Entity
(Pkg_Spec
), Loc
),
7088 Attribute_Name
=> Name_Version
));
7092 Append_To
(Register_Pkg_Actuals
,
7093 Make_Attribute_Reference
(Loc
,
7095 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
7096 Attribute_Name
=> Name_Access
));
7100 Append_To
(Register_Pkg_Actuals
,
7101 Make_Attribute_Reference
(Loc
,
7104 Defining_Identifier
(Pkg_RPC_Receiver_Object
), Loc
),
7105 Attribute_Name
=> Name_Access
));
7109 Append_To
(Register_Pkg_Actuals
,
7110 Make_Attribute_Reference
(Loc
,
7111 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
7112 Attribute_Name
=> Name_Address
));
7116 Append_To
(Register_Pkg_Actuals
,
7117 Make_Attribute_Reference
(Loc
,
7118 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
7119 Attribute_Name
=> Name_Length
));
7121 -- Is_All_Calls_Remote
7123 Append_To
(Register_Pkg_Actuals
,
7124 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
));
7126 -- Finally call Register_Pkg_Receiving_Stub with the above parameters
7129 Make_Procedure_Call_Statement
(Loc
,
7131 New_Occurrence_Of
(RTE
(RE_Register_Pkg_Receiving_Stub
), Loc
),
7132 Parameter_Associations
=> Register_Pkg_Actuals
));
7133 Analyze
(Last
(Stmts
));
7134 end Add_Receiving_Stubs_To_Declarations
;
7136 ---------------------------------
7137 -- Build_General_Calling_Stubs --
7138 ---------------------------------
7140 procedure Build_General_Calling_Stubs
7142 Statements
: List_Id
;
7143 Target_Object
: Node_Id
;
7144 Subprogram_Id
: Node_Id
;
7145 Asynchronous
: Node_Id
:= Empty
;
7146 Is_Known_Asynchronous
: Boolean := False;
7147 Is_Known_Non_Asynchronous
: Boolean := False;
7148 Is_Function
: Boolean;
7150 Stub_Type
: Entity_Id
:= Empty
;
7151 RACW_Type
: Entity_Id
:= Empty
;
7154 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
7156 Request
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
7157 -- The request object constructed by these stubs
7158 -- Could we use Name_R instead??? (see GLADE client stubs)
7160 function Make_Request_RTE_Call
7162 Actuals
: List_Id
:= New_List
) return Node_Id
;
7163 -- Generate a procedure call statement calling RE with the given
7164 -- actuals. Request'Access is appended to the list.
7166 ---------------------------
7167 -- Make_Request_RTE_Call --
7168 ---------------------------
7170 function Make_Request_RTE_Call
7172 Actuals
: List_Id
:= New_List
) return Node_Id
7176 Make_Attribute_Reference
(Loc
,
7177 Prefix
=> New_Occurrence_Of
(Request
, Loc
),
7178 Attribute_Name
=> Name_Access
));
7179 return Make_Procedure_Call_Statement
(Loc
,
7181 New_Occurrence_Of
(RTE
(RE
), Loc
),
7182 Parameter_Associations
=> Actuals
);
7183 end Make_Request_RTE_Call
;
7185 Arguments
: Node_Id
;
7186 -- Name of the named values list used to transmit parameters
7187 -- to the remote package
7190 -- Name of the result named value (in non-APC cases) which get the
7191 -- result of the remote subprogram.
7193 Result_TC
: Node_Id
;
7194 -- Typecode expression for the result of the request (void
7195 -- typecode for procedures).
7197 Exception_Return_Parameter
: Node_Id
;
7198 -- Name of the parameter which will hold the exception sent by the
7199 -- remote subprogram.
7201 Current_Parameter
: Node_Id
;
7202 -- Current parameter being handled
7204 Ordered_Parameters_List
: constant List_Id
:=
7205 Build_Ordered_Parameters_List
(Spec
);
7207 Asynchronous_P
: Node_Id
;
7208 -- A Boolean expression indicating whether this call is asynchronous
7210 Asynchronous_Statements
: List_Id
:= No_List
;
7211 Non_Asynchronous_Statements
: List_Id
:= No_List
;
7212 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7214 Extra_Formal_Statements
: constant List_Id
:= New_List
;
7215 -- List of statements for extra formal parameters. It will appear
7216 -- after the regular statements for writing out parameters.
7218 After_Statements
: constant List_Id
:= New_List
;
7219 -- Statements to be executed after call returns (to assign IN OUT or
7220 -- OUT parameter values).
7223 -- The type of the formal parameter being processed
7225 Is_Controlling_Formal
: Boolean;
7226 Is_First_Controlling_Formal
: Boolean;
7227 First_Controlling_Formal_Seen
: Boolean := False;
7228 -- Controlling formal parameters of distributed object primitives
7229 -- require special handling, and the first such parameter needs even
7230 -- more special handling.
7233 -- ??? document general form of stub subprograms for the PolyORB case
7236 Make_Object_Declaration
(Loc
,
7237 Defining_Identifier
=> Request
,
7238 Aliased_Present
=> True,
7239 Object_Definition
=>
7240 New_Occurrence_Of
(RTE
(RE_Request
), Loc
)));
7242 Result
:= Make_Temporary
(Loc
, 'R');
7246 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7247 (Loc
, Etype
(Result_Definition
(Spec
)), Decls
);
7249 Result_TC
:= New_Occurrence_Of
(RTE
(RE_TC_Void
), Loc
);
7253 Make_Object_Declaration
(Loc
,
7254 Defining_Identifier
=> Result
,
7255 Aliased_Present
=> False,
7256 Object_Definition
=>
7257 New_Occurrence_Of
(RTE
(RE_NamedValue
), Loc
),
7259 Make_Aggregate
(Loc
,
7260 Component_Associations
=> New_List
(
7261 Make_Component_Association
(Loc
,
7262 Choices
=> New_List
(Make_Identifier
(Loc
, Name_Name
)),
7264 New_Occurrence_Of
(RTE
(RE_Result_Name
), Loc
)),
7265 Make_Component_Association
(Loc
,
7266 Choices
=> New_List
(
7267 Make_Identifier
(Loc
, Name_Argument
)),
7269 Make_Function_Call
(Loc
,
7270 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7271 Parameter_Associations
=> New_List
(Result_TC
))),
7272 Make_Component_Association
(Loc
,
7273 Choices
=> New_List
(
7274 Make_Identifier
(Loc
, Name_Arg_Modes
)),
7275 Expression
=> Make_Integer_Literal
(Loc
, 0))))));
7277 if not Is_Known_Asynchronous
then
7278 Exception_Return_Parameter
:= Make_Temporary
(Loc
, 'E');
7281 Make_Object_Declaration
(Loc
,
7282 Defining_Identifier
=> Exception_Return_Parameter
,
7283 Object_Definition
=>
7284 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
7287 Exception_Return_Parameter
:= Empty
;
7290 -- Initialize and fill in arguments list
7292 Arguments
:= Make_Temporary
(Loc
, 'A');
7293 Declare_Create_NVList
(Loc
, Arguments
, Decls
, Statements
);
7295 Current_Parameter
:= First
(Ordered_Parameters_List
);
7296 while Present
(Current_Parameter
) loop
7297 if Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
) then
7298 Is_Controlling_Formal
:= True;
7299 Is_First_Controlling_Formal
:=
7300 not First_Controlling_Formal_Seen
;
7301 First_Controlling_Formal_Seen
:= True;
7304 Is_Controlling_Formal
:= False;
7305 Is_First_Controlling_Formal
:= False;
7308 if Is_Controlling_Formal
then
7310 -- For a controlling formal argument, we send its reference
7315 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7318 -- The first controlling formal parameter is treated specially:
7319 -- it is used to set the target object of the call.
7321 if not Is_First_Controlling_Formal
then
7323 Constrained
: constant Boolean :=
7324 Is_Constrained
(Etyp
)
7325 or else Is_Elementary_Type
(Etyp
);
7327 Any
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
7329 Actual_Parameter
: Node_Id
:=
7331 Defining_Identifier
(
7332 Current_Parameter
), Loc
);
7337 if Is_Controlling_Formal
then
7339 -- For a controlling formal parameter (other than the
7340 -- first one), use the corresponding RACW. If the
7341 -- parameter is not an anonymous access parameter, that
7342 -- involves taking its 'Unrestricted_Access.
7344 if Nkind
(Parameter_Type
(Current_Parameter
))
7345 = N_Access_Definition
7347 Actual_Parameter
:= OK_Convert_To
7348 (Etyp
, Actual_Parameter
);
7350 Actual_Parameter
:= OK_Convert_To
(Etyp
,
7351 Make_Attribute_Reference
(Loc
,
7352 Prefix
=> Actual_Parameter
,
7353 Attribute_Name
=> Name_Unrestricted_Access
));
7358 if In_Present
(Current_Parameter
)
7359 or else not Out_Present
(Current_Parameter
)
7360 or else not Constrained
7361 or else Is_Controlling_Formal
7363 -- The parameter has an input value, is constrained at
7364 -- runtime by an input value, or is a controlling formal
7365 -- parameter (always passed as a reference) other than
7368 Expr
:= PolyORB_Support
.Helpers
.Build_To_Any_Call
7369 (Loc
, Actual_Parameter
, Decls
);
7372 Expr
:= Make_Function_Call
(Loc
,
7373 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7374 Parameter_Associations
=> New_List
(
7375 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7376 (Loc
, Etyp
, Decls
)));
7380 Make_Object_Declaration
(Loc
,
7381 Defining_Identifier
=> Any
,
7382 Aliased_Present
=> False,
7383 Object_Definition
=>
7384 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7385 Expression
=> Expr
));
7387 Append_To
(Statements
,
7388 Add_Parameter_To_NVList
(Loc
,
7389 Parameter
=> Current_Parameter
,
7390 NVList
=> Arguments
,
7391 Constrained
=> Constrained
,
7394 if Out_Present
(Current_Parameter
)
7395 and then not Is_Controlling_Formal
7397 if Is_Limited_Type
(Etyp
) then
7398 Helpers
.Assign_Opaque_From_Any
(Loc
,
7399 Stms
=> After_Statements
,
7401 N
=> New_Occurrence_Of
(Any
, Loc
),
7403 Defining_Identifier
(Current_Parameter
));
7405 Append_To
(After_Statements
,
7406 Make_Assignment_Statement
(Loc
,
7409 Defining_Identifier
(Current_Parameter
), Loc
),
7411 PolyORB_Support
.Helpers
.Build_From_Any_Call
7413 New_Occurrence_Of
(Any
, Loc
),
7420 -- If the current parameter has a dynamic constrained status, then
7421 -- this status is transmitted as well.
7423 -- This should be done for accessibility as well ???
7425 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7427 and then Need_Extra_Constrained
(Current_Parameter
)
7429 -- In this block, we do not use the extra formal that has been
7430 -- created because it does not exist at the time of expansion
7431 -- when building calling stubs for remote access to subprogram
7432 -- types. We create an extra variable of this type and push it
7433 -- in the stream after the regular parameters.
7436 Extra_Any_Parameter
: constant Entity_Id
:=
7437 Make_Temporary
(Loc
, 'P');
7439 Parameter_Exp
: constant Node_Id
:=
7440 Make_Attribute_Reference
(Loc
,
7441 Prefix
=> New_Occurrence_Of
(
7442 Defining_Identifier
(Current_Parameter
), Loc
),
7443 Attribute_Name
=> Name_Constrained
);
7446 Set_Etype
(Parameter_Exp
, Etype
(Standard_Boolean
));
7449 Make_Object_Declaration
(Loc
,
7450 Defining_Identifier
=> Extra_Any_Parameter
,
7451 Aliased_Present
=> False,
7452 Object_Definition
=>
7453 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7455 PolyORB_Support
.Helpers
.Build_To_Any_Call
7456 (Loc
, Parameter_Exp
, Decls
)));
7458 Append_To
(Extra_Formal_Statements
,
7459 Add_Parameter_To_NVList
(Loc
,
7460 Parameter
=> Extra_Any_Parameter
,
7461 NVList
=> Arguments
,
7462 Constrained
=> True,
7463 Any
=> Extra_Any_Parameter
));
7467 Next
(Current_Parameter
);
7470 -- Append the formal statements list to the statements
7472 Append_List_To
(Statements
, Extra_Formal_Statements
);
7474 Append_To
(Statements
,
7475 Make_Procedure_Call_Statement
(Loc
,
7477 New_Occurrence_Of
(RTE
(RE_Request_Setup
), Loc
),
7478 Parameter_Associations
=> New_List
(
7479 New_Occurrence_Of
(Request
, Loc
),
7482 New_Occurrence_Of
(Arguments
, Loc
),
7483 New_Occurrence_Of
(Result
, Loc
),
7484 New_Occurrence_Of
(RTE
(RE_Nil_Exc_List
), Loc
))));
7487 (not (Is_Known_Non_Asynchronous
and Is_Known_Asynchronous
));
7489 if Is_Known_Non_Asynchronous
or Is_Known_Asynchronous
then
7492 (Boolean_Literals
(Is_Known_Asynchronous
), Loc
);
7495 pragma Assert
(Present
(Asynchronous
));
7496 Asynchronous_P
:= New_Copy_Tree
(Asynchronous
);
7498 -- The expression node Asynchronous will be used to build an 'if'
7499 -- statement at the end of Build_General_Calling_Stubs: we need to
7500 -- make a copy here.
7503 Append_To
(Parameter_Associations
(Last
(Statements
)),
7504 Make_Indexed_Component
(Loc
,
7507 RTE
(RE_Asynchronous_P_To_Sync_Scope
), Loc
),
7508 Expressions
=> New_List
(Asynchronous_P
)));
7510 Append_To
(Statements
, Make_Request_RTE_Call
(RE_Request_Invoke
));
7512 -- Asynchronous case
7514 if not Is_Known_Non_Asynchronous
then
7515 Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7518 -- Non-asynchronous case
7520 if not Is_Known_Asynchronous
then
7521 -- Reraise an exception occurrence from the completed request.
7522 -- If the exception occurrence is empty, this is a no-op.
7524 Non_Asynchronous_Statements
:= New_List
(
7525 Make_Procedure_Call_Statement
(Loc
,
7527 New_Occurrence_Of
(RTE
(RE_Request_Raise_Occurrence
), Loc
),
7528 Parameter_Associations
=> New_List
(
7529 New_Occurrence_Of
(Request
, Loc
))));
7532 -- If this is a function call, read the value and return it
7534 Append_To
(Non_Asynchronous_Statements
,
7535 Make_Tag_Check
(Loc
,
7536 Make_Simple_Return_Statement
(Loc
,
7537 PolyORB_Support
.Helpers
.Build_From_Any_Call
7538 (Etype
(Result_Definition
(Spec
)),
7539 Make_Selected_Component
(Loc
,
7541 Selector_Name
=> Name_Argument
),
7546 -- Case of a procedure: deal with IN OUT and OUT formals
7548 Append_List_To
(Non_Asynchronous_Statements
, After_Statements
);
7552 if Is_Known_Asynchronous
then
7553 Append_List_To
(Statements
, Asynchronous_Statements
);
7555 elsif Is_Known_Non_Asynchronous
then
7556 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
7559 pragma Assert
(Present
(Asynchronous
));
7560 Append_To
(Statements
,
7561 Make_Implicit_If_Statement
(Nod
,
7562 Condition
=> Asynchronous
,
7563 Then_Statements
=> Asynchronous_Statements
,
7564 Else_Statements
=> Non_Asynchronous_Statements
));
7566 end Build_General_Calling_Stubs
;
7568 -----------------------
7569 -- Build_Stub_Target --
7570 -----------------------
7572 function Build_Stub_Target
7575 RCI_Locator
: Entity_Id
;
7576 Controlling_Parameter
: Entity_Id
) return RPC_Target
7578 Target_Info
: RPC_Target
(PCS_Kind
=> Name_PolyORB_DSA
);
7579 Target_Reference
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
7582 if Present
(Controlling_Parameter
) then
7584 Make_Object_Declaration
(Loc
,
7585 Defining_Identifier
=> Target_Reference
,
7587 Object_Definition
=>
7588 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
7591 Make_Function_Call
(Loc
,
7593 New_Occurrence_Of
(RTE
(RE_Make_Ref
), Loc
),
7594 Parameter_Associations
=> New_List
(
7595 Make_Selected_Component
(Loc
,
7596 Prefix
=> Controlling_Parameter
,
7597 Selector_Name
=> Name_Target
)))));
7599 -- Note: Controlling_Parameter has the same components as
7600 -- System.Partition_Interface.RACW_Stub_Type.
7602 Target_Info
.Object
:= New_Occurrence_Of
(Target_Reference
, Loc
);
7605 Target_Info
.Object
:=
7606 Make_Selected_Component
(Loc
,
7608 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
7610 Make_Identifier
(Loc
, Name_Get_RCI_Package_Ref
));
7614 end Build_Stub_Target
;
7616 -----------------------------
7617 -- Build_RPC_Receiver_Body --
7618 -----------------------------
7620 procedure Build_RPC_Receiver_Body
7621 (RPC_Receiver
: Entity_Id
;
7622 Request
: out Entity_Id
;
7623 Subp_Id
: out Entity_Id
;
7624 Subp_Index
: out Entity_Id
;
7625 Stmts
: out List_Id
;
7628 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
7630 RPC_Receiver_Spec
: Node_Id
;
7631 RPC_Receiver_Decls
: List_Id
;
7634 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
7636 RPC_Receiver_Spec
:=
7637 Build_RPC_Receiver_Specification
7638 (RPC_Receiver
=> RPC_Receiver
,
7639 Request_Parameter
=> Request
);
7641 Subp_Id
:= Make_Defining_Identifier
(Loc
, Name_P
);
7642 Subp_Index
:= Make_Defining_Identifier
(Loc
, Name_I
);
7644 RPC_Receiver_Decls
:= New_List
(
7645 Make_Object_Renaming_Declaration
(Loc
,
7646 Defining_Identifier
=> Subp_Id
,
7647 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
7649 Make_Explicit_Dereference
(Loc
,
7651 Make_Selected_Component
(Loc
,
7653 Selector_Name
=> Name_Operation
))),
7655 Make_Object_Declaration
(Loc
,
7656 Defining_Identifier
=> Subp_Index
,
7657 Object_Definition
=>
7658 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7660 Make_Attribute_Reference
(Loc
,
7662 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7663 Attribute_Name
=> Name_Last
)));
7668 Make_Subprogram_Body
(Loc
,
7669 Specification
=> RPC_Receiver_Spec
,
7670 Declarations
=> RPC_Receiver_Decls
,
7671 Handled_Statement_Sequence
=>
7672 Make_Handled_Sequence_Of_Statements
(Loc
,
7673 Statements
=> Stmts
));
7674 end Build_RPC_Receiver_Body
;
7676 --------------------------------------
7677 -- Build_Subprogram_Receiving_Stubs --
7678 --------------------------------------
7680 function Build_Subprogram_Receiving_Stubs
7681 (Vis_Decl
: Node_Id
;
7682 Asynchronous
: Boolean;
7683 Dynamically_Asynchronous
: Boolean := False;
7684 Stub_Type
: Entity_Id
:= Empty
;
7685 RACW_Type
: Entity_Id
:= Empty
;
7686 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
7688 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
7690 Request_Parameter
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
7691 -- Formal parameter for receiving stubs: a descriptor for an incoming
7694 Outer_Decls
: constant List_Id
:= New_List
;
7695 -- At the outermost level, an NVList and Any's are declared for all
7696 -- parameters. The Dynamic_Async flag also needs to be declared there
7697 -- to be visible from the exception handling code.
7699 Outer_Statements
: constant List_Id
:= New_List
;
7700 -- Statements that occur prior to the declaration of the actual
7701 -- parameter variables.
7703 Outer_Extra_Formal_Statements
: constant List_Id
:= New_List
;
7704 -- Statements concerning extra formal parameters, prior to the
7705 -- declaration of the actual parameter variables.
7707 Decls
: constant List_Id
:= New_List
;
7708 -- All the parameters will get declared before calling the real
7709 -- subprograms. Also the out parameters will be declared. At this
7710 -- level, parameters may be unconstrained.
7712 Statements
: constant List_Id
:= New_List
;
7714 After_Statements
: constant List_Id
:= New_List
;
7715 -- Statements to be executed after the subprogram call
7717 Inner_Decls
: List_Id
:= No_List
;
7718 -- In case of a function, the inner declarations are needed since
7719 -- the result may be unconstrained.
7721 Excep_Handlers
: List_Id
:= No_List
;
7723 Parameter_List
: constant List_Id
:= New_List
;
7724 -- List of parameters to be passed to the subprogram
7726 First_Controlling_Formal_Seen
: Boolean := False;
7728 Current_Parameter
: Node_Id
;
7730 Ordered_Parameters_List
: constant List_Id
:=
7731 Build_Ordered_Parameters_List
7732 (Specification
(Vis_Decl
));
7734 Arguments
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
7735 -- Name of the named values list used to retrieve parameters
7737 Subp_Spec
: Node_Id
;
7738 -- Subprogram specification
7740 Called_Subprogram
: Node_Id
;
7741 -- The subprogram to call
7744 if Present
(RACW_Type
) then
7745 Called_Subprogram
:=
7746 New_Occurrence_Of
(Parent_Primitive
, Loc
);
7748 Called_Subprogram
:=
7750 (Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
7753 Declare_Create_NVList
(Loc
, Arguments
, Outer_Decls
, Outer_Statements
);
7755 -- Loop through every parameter and get its value from the stream. If
7756 -- the parameter is unconstrained, then the parameter is read using
7757 -- 'Input at the point of declaration.
7759 Current_Parameter
:= First
(Ordered_Parameters_List
);
7760 while Present
(Current_Parameter
) loop
7763 Constrained
: Boolean;
7764 Any
: Entity_Id
:= Empty
;
7765 Object
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
7766 Expr
: Node_Id
:= Empty
;
7768 Is_Controlling_Formal
: constant Boolean :=
7769 Is_RACW_Controlling_Formal
7770 (Current_Parameter
, Stub_Type
);
7772 Is_First_Controlling_Formal
: Boolean := False;
7774 Need_Extra_Constrained
: Boolean;
7775 -- True when an extra constrained actual is required
7778 if Is_Controlling_Formal
then
7780 -- Controlling formals in distributed object primitive
7781 -- operations are handled specially:
7783 -- - the first controlling formal is used as the
7784 -- target of the call;
7786 -- - the remaining controlling formals are transmitted
7790 Is_First_Controlling_Formal
:=
7791 not First_Controlling_Formal_Seen
;
7792 First_Controlling_Formal_Seen
:= True;
7795 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7799 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
7801 if not Is_First_Controlling_Formal
then
7802 Any
:= Make_Temporary
(Loc
, 'A');
7804 Append_To
(Outer_Decls
,
7805 Make_Object_Declaration
(Loc
,
7806 Defining_Identifier
=> Any
,
7807 Object_Definition
=>
7808 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7810 Make_Function_Call
(Loc
,
7811 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7812 Parameter_Associations
=> New_List
(
7813 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7814 (Loc
, Etyp
, Outer_Decls
)))));
7816 Append_To
(Outer_Statements
,
7817 Add_Parameter_To_NVList
(Loc
,
7818 Parameter
=> Current_Parameter
,
7819 NVList
=> Arguments
,
7820 Constrained
=> Constrained
,
7824 if Is_First_Controlling_Formal
then
7826 Addr
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
7828 Is_Local
: constant Entity_Id
:=
7829 Make_Temporary
(Loc
, 'L');
7832 -- Special case: obtain the first controlling formal
7833 -- from the target of the remote call, instead of the
7836 Append_To
(Outer_Decls
,
7837 Make_Object_Declaration
(Loc
,
7838 Defining_Identifier
=> Addr
,
7839 Object_Definition
=>
7840 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
7842 Append_To
(Outer_Decls
,
7843 Make_Object_Declaration
(Loc
,
7844 Defining_Identifier
=> Is_Local
,
7845 Object_Definition
=>
7846 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7848 Append_To
(Outer_Statements
,
7849 Make_Procedure_Call_Statement
(Loc
,
7851 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
7852 Parameter_Associations
=> New_List
(
7853 Make_Selected_Component
(Loc
,
7856 Request_Parameter
, Loc
),
7858 Make_Identifier
(Loc
, Name_Target
)),
7859 New_Occurrence_Of
(Is_Local
, Loc
),
7860 New_Occurrence_Of
(Addr
, Loc
))));
7862 Expr
:= Unchecked_Convert_To
(RACW_Type
,
7863 New_Occurrence_Of
(Addr
, Loc
));
7866 elsif In_Present
(Current_Parameter
)
7867 or else not Out_Present
(Current_Parameter
)
7868 or else not Constrained
7870 -- If an input parameter is constrained, then its reading is
7871 -- deferred until the beginning of the subprogram body. If
7872 -- it is unconstrained, then an expression is built for
7873 -- the object declaration and the variable is set using
7874 -- 'Input instead of 'Read.
7876 if Constrained
and then Is_Limited_Type
(Etyp
) then
7877 Helpers
.Assign_Opaque_From_Any
(Loc
,
7880 N
=> New_Occurrence_Of
(Any
, Loc
),
7884 Expr
:= Helpers
.Build_From_Any_Call
7885 (Etyp
, New_Occurrence_Of
(Any
, Loc
), Decls
);
7888 Append_To
(Statements
,
7889 Make_Assignment_Statement
(Loc
,
7890 Name
=> New_Occurrence_Of
(Object
, Loc
),
7891 Expression
=> Expr
));
7895 -- Expr will be used to initialize (and constrain) the
7896 -- parameter when it is declared.
7904 Need_Extra_Constrained
:=
7905 Nkind
(Parameter_Type
(Current_Parameter
)) /=
7908 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
7910 Present
(Extra_Constrained
7911 (Defining_Identifier
(Current_Parameter
)));
7913 -- We may not associate an extra constrained actual to a
7914 -- constant object, so if one is needed, declare the actual
7915 -- as a variable even if it won't be modified.
7917 Build_Actual_Object_Declaration
7920 Variable
=> Need_Extra_Constrained
7921 or else Out_Present
(Current_Parameter
),
7924 Set_Etype
(Object
, Etyp
);
7926 -- An out parameter may be written back using a 'Write
7927 -- attribute instead of a 'Output because it has been
7928 -- constrained by the parameter given to the caller. Note that
7929 -- out controlling arguments in the case of a RACW are not put
7930 -- back in the stream because the pointer on them has not
7933 if Out_Present
(Current_Parameter
)
7934 and then not Is_Controlling_Formal
7936 Append_To
(After_Statements
,
7937 Make_Procedure_Call_Statement
(Loc
,
7938 Name
=> New_Occurrence_Of
(RTE
(RE_Move_Any_Value
), Loc
),
7939 Parameter_Associations
=> New_List
(
7940 New_Occurrence_Of
(Any
, Loc
),
7941 PolyORB_Support
.Helpers
.Build_To_Any_Call
7942 (Loc
, New_Occurrence_Of
(Object
, Loc
), Decls
))));
7945 -- For RACW controlling formals, the Etyp of Object is always
7946 -- an RACW, even if the parameter is not of an anonymous access
7947 -- type. In such case, we need to dereference it at call time.
7949 if Is_Controlling_Formal
then
7950 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7953 Append_To
(Parameter_List
,
7954 Make_Parameter_Association
(Loc
,
7957 (Defining_Identifier
(Current_Parameter
), Loc
),
7958 Explicit_Actual_Parameter
=>
7959 Make_Explicit_Dereference
(Loc
,
7960 Prefix
=> New_Occurrence_Of
(Object
, Loc
))));
7963 Append_To
(Parameter_List
,
7964 Make_Parameter_Association
(Loc
,
7967 (Defining_Identifier
(Current_Parameter
), Loc
),
7969 Explicit_Actual_Parameter
=>
7970 New_Occurrence_Of
(Object
, Loc
)));
7974 Append_To
(Parameter_List
,
7975 Make_Parameter_Association
(Loc
,
7978 Defining_Identifier
(Current_Parameter
), Loc
),
7979 Explicit_Actual_Parameter
=>
7980 New_Occurrence_Of
(Object
, Loc
)));
7983 -- If the current parameter needs an extra formal, then read it
7984 -- from the stream and set the corresponding semantic field in
7985 -- the variable. If the kind of the parameter identifier is
7986 -- E_Void, then this is a compiler generated parameter that
7987 -- doesn't need an extra constrained status.
7989 -- The case of Extra_Accessibility should also be handled ???
7991 if Need_Extra_Constrained
then
7993 Extra_Parameter
: constant Entity_Id
:=
7995 (Defining_Identifier
7996 (Current_Parameter
));
7998 Extra_Any
: constant Entity_Id
:=
7999 Make_Temporary
(Loc
, 'A');
8001 Formal_Entity
: constant Entity_Id
:=
8002 Make_Defining_Identifier
(Loc
,
8003 Chars
=> Chars
(Extra_Parameter
));
8005 Formal_Type
: constant Entity_Id
:=
8006 Etype
(Extra_Parameter
);
8009 Append_To
(Outer_Decls
,
8010 Make_Object_Declaration
(Loc
,
8011 Defining_Identifier
=> Extra_Any
,
8012 Object_Definition
=>
8013 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8015 Make_Function_Call
(Loc
,
8017 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
8018 Parameter_Associations
=> New_List
(
8019 PolyORB_Support
.Helpers
.Build_TypeCode_Call
8020 (Loc
, Formal_Type
, Outer_Decls
)))));
8022 Append_To
(Outer_Extra_Formal_Statements
,
8023 Add_Parameter_To_NVList
(Loc
,
8024 Parameter
=> Extra_Parameter
,
8025 NVList
=> Arguments
,
8026 Constrained
=> True,
8030 Make_Object_Declaration
(Loc
,
8031 Defining_Identifier
=> Formal_Entity
,
8032 Object_Definition
=>
8033 New_Occurrence_Of
(Formal_Type
, Loc
)));
8035 Append_To
(Statements
,
8036 Make_Assignment_Statement
(Loc
,
8037 Name
=> New_Occurrence_Of
(Formal_Entity
, Loc
),
8039 PolyORB_Support
.Helpers
.Build_From_Any_Call
8041 New_Occurrence_Of
(Extra_Any
, Loc
),
8043 Set_Extra_Constrained
(Object
, Formal_Entity
);
8048 Next
(Current_Parameter
);
8051 -- Extra Formals should go after all the other parameters
8053 Append_List_To
(Outer_Statements
, Outer_Extra_Formal_Statements
);
8055 Append_To
(Outer_Statements
,
8056 Make_Procedure_Call_Statement
(Loc
,
8057 Name
=> New_Occurrence_Of
(RTE
(RE_Request_Arguments
), Loc
),
8058 Parameter_Associations
=> New_List
(
8059 New_Occurrence_Of
(Request_Parameter
, Loc
),
8060 New_Occurrence_Of
(Arguments
, Loc
))));
8062 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
8064 -- The remote subprogram is a function: Build an inner block to be
8065 -- able to hold a potentially unconstrained result in a variable.
8068 Etyp
: constant Entity_Id
:=
8069 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
8070 Result
: constant Node_Id
:= Make_Temporary
(Loc
, 'R');
8073 Inner_Decls
:= New_List
(
8074 Make_Object_Declaration
(Loc
,
8075 Defining_Identifier
=> Result
,
8076 Constant_Present
=> True,
8077 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
8079 Make_Function_Call
(Loc
,
8080 Name
=> Called_Subprogram
,
8081 Parameter_Associations
=> Parameter_List
)));
8083 if Is_Class_Wide_Type
(Etyp
) then
8085 -- For a remote call to a function with a class-wide type,
8086 -- check that the returned value satisfies the requirements
8089 Append_To
(Inner_Decls
,
8090 Make_Transportable_Check
(Loc
,
8091 New_Occurrence_Of
(Result
, Loc
)));
8095 Set_Etype
(Result
, Etyp
);
8096 Append_To
(After_Statements
,
8097 Make_Procedure_Call_Statement
(Loc
,
8098 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Result
), Loc
),
8099 Parameter_Associations
=> New_List
(
8100 New_Occurrence_Of
(Request_Parameter
, Loc
),
8101 PolyORB_Support
.Helpers
.Build_To_Any_Call
8102 (Loc
, New_Occurrence_Of
(Result
, Loc
), Decls
))));
8104 -- A DSA function does not have out or inout arguments
8107 Append_To
(Statements
,
8108 Make_Block_Statement
(Loc
,
8109 Declarations
=> Inner_Decls
,
8110 Handled_Statement_Sequence
=>
8111 Make_Handled_Sequence_Of_Statements
(Loc
,
8112 Statements
=> After_Statements
)));
8115 -- The remote subprogram is a procedure. We do not need any inner
8116 -- block in this case. No specific processing is required here for
8117 -- the dynamically asynchronous case: the indication of whether
8118 -- call is asynchronous or not is managed by the Sync_Scope
8119 -- attibute of the request, and is handled entirely in the
8122 Append_To
(After_Statements
,
8123 Make_Procedure_Call_Statement
(Loc
,
8124 Name
=> New_Occurrence_Of
(RTE
(RE_Request_Set_Out
), Loc
),
8125 Parameter_Associations
=> New_List
(
8126 New_Occurrence_Of
(Request_Parameter
, Loc
))));
8128 Append_To
(Statements
,
8129 Make_Procedure_Call_Statement
(Loc
,
8130 Name
=> Called_Subprogram
,
8131 Parameter_Associations
=> Parameter_List
));
8133 Append_List_To
(Statements
, After_Statements
);
8137 Make_Procedure_Specification
(Loc
,
8138 Defining_Unit_Name
=> Make_Temporary
(Loc
, 'F'),
8140 Parameter_Specifications
=> New_List
(
8141 Make_Parameter_Specification
(Loc
,
8142 Defining_Identifier
=> Request_Parameter
,
8144 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
8146 -- An exception raised during the execution of an incoming remote
8147 -- subprogram call and that needs to be sent back to the caller is
8148 -- propagated by the receiving stubs, and will be handled by the
8149 -- caller (the distribution runtime).
8151 if Asynchronous
and then not Dynamically_Asynchronous
then
8153 -- For an asynchronous procedure, add a null exception handler
8155 Excep_Handlers
:= New_List
(
8156 Make_Implicit_Exception_Handler
(Loc
,
8157 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8158 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
8161 -- In the other cases, if an exception is raised, then the
8162 -- exception occurrence is propagated.
8167 Append_To
(Outer_Statements
,
8168 Make_Block_Statement
(Loc
,
8169 Declarations
=> Decls
,
8170 Handled_Statement_Sequence
=>
8171 Make_Handled_Sequence_Of_Statements
(Loc
,
8172 Statements
=> Statements
)));
8175 Make_Subprogram_Body
(Loc
,
8176 Specification
=> Subp_Spec
,
8177 Declarations
=> Outer_Decls
,
8178 Handled_Statement_Sequence
=>
8179 Make_Handled_Sequence_Of_Statements
(Loc
,
8180 Statements
=> Outer_Statements
,
8181 Exception_Handlers
=> Excep_Handlers
));
8182 end Build_Subprogram_Receiving_Stubs
;
8188 package body Helpers
is
8190 -----------------------
8191 -- Local Subprograms --
8192 -----------------------
8194 function Find_Numeric_Representation
8195 (Typ
: Entity_Id
) return Entity_Id
;
8196 -- Given a numeric type Typ, return the smallest integer or modular
8197 -- type from Interfaces, or the smallest floating point type from
8198 -- Standard whose range encompasses that of Typ.
8200 function Make_Helper_Function_Name
8203 Nam
: Name_Id
) return Entity_Id
;
8204 -- Return the name to be assigned for helper subprogram Nam of Typ
8206 ------------------------------------------------------------
8207 -- Common subprograms for building various tree fragments --
8208 ------------------------------------------------------------
8210 function Build_Get_Aggregate_Element
8214 Idx
: Node_Id
) return Node_Id
;
8215 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8216 -- returning the Idx'th element.
8219 Subprogram
: Entity_Id
;
8220 -- Reference location for constructed nodes
8223 -- For 'Range and Etype
8226 -- For the construction of the innermost element expression
8228 with procedure Add_Process_Element
8231 Counter
: Entity_Id
;
8234 procedure Append_Array_Traversal
8237 Counter
: Entity_Id
:= Empty
;
8239 -- Build nested loop statements that iterate over the elements of an
8240 -- array Arry. The statement(s) built by Add_Process_Element are
8241 -- executed for each element; Indexes is the list of indexes to be
8242 -- used in the construction of the indexed component that denotes the
8243 -- current element. Subprogram is the entity for the subprogram for
8244 -- which this iterator is generated. The generated statements are
8245 -- appended to Stmts.
8249 -- The record entity being dealt with
8251 with procedure Add_Process_Element
8253 Container
: Node_Or_Entity_Id
;
8254 Counter
: in out Int
;
8257 -- Rec is the instance of the record type, or Empty.
8258 -- Field is either the N_Defining_Identifier for a component,
8259 -- or an N_Variant_Part.
8261 procedure Append_Record_Traversal
8264 Container
: Node_Or_Entity_Id
;
8265 Counter
: in out Int
);
8266 -- Process component list Clist. Individual fields are passed
8267 -- to Field_Processing. Each variant part is also processed.
8268 -- Container is the outer Any (for From_Any/To_Any),
8269 -- the outer typecode (for TC) to which the operation applies.
8271 -----------------------------
8272 -- Append_Record_Traversal --
8273 -----------------------------
8275 procedure Append_Record_Traversal
8278 Container
: Node_Or_Entity_Id
;
8279 Counter
: in out Int
)
8283 -- Clist's Component_Items and Variant_Part
8293 CI
:= Component_Items
(Clist
);
8294 VP
:= Variant_Part
(Clist
);
8297 while Present
(Item
) loop
8298 Def
:= Defining_Identifier
(Item
);
8300 if not Is_Internal_Name
(Chars
(Def
)) then
8302 (Stmts
, Container
, Counter
, Rec
, Def
);
8308 if Present
(VP
) then
8309 Add_Process_Element
(Stmts
, Container
, Counter
, Rec
, VP
);
8311 end Append_Record_Traversal
;
8313 -----------------------------
8314 -- Assign_Opaque_From_Any --
8315 -----------------------------
8317 procedure Assign_Opaque_From_Any
8324 Strm
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
8327 Read_Call_List
: List_Id
;
8328 -- List on which to place the 'Read attribute reference
8331 -- Strm : Buffer_Stream_Type;
8334 Make_Object_Declaration
(Loc
,
8335 Defining_Identifier
=> Strm
,
8336 Aliased_Present
=> True,
8337 Object_Definition
=>
8338 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
8340 -- Any_To_BS (Strm, A);
8343 Make_Procedure_Call_Statement
(Loc
,
8344 Name
=> New_Occurrence_Of
(RTE
(RE_Any_To_BS
), Loc
),
8345 Parameter_Associations
=> New_List
(
8347 New_Occurrence_Of
(Strm
, Loc
))));
8349 if Transmit_As_Unconstrained
(Typ
) then
8351 Make_Attribute_Reference
(Loc
,
8352 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
8353 Attribute_Name
=> Name_Input
,
8354 Expressions
=> New_List
(
8355 Make_Attribute_Reference
(Loc
,
8356 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
8357 Attribute_Name
=> Name_Access
)));
8359 -- Target := Typ'Input (Strm'Access)
8361 if Present
(Target
) then
8363 Make_Assignment_Statement
(Loc
,
8364 Name
=> New_Occurrence_Of
(Target
, Loc
),
8365 Expression
=> Expr
));
8367 -- return Typ'Input (Strm'Access);
8371 Make_Simple_Return_Statement
(Loc
,
8372 Expression
=> Expr
));
8376 if Present
(Target
) then
8377 Read_Call_List
:= Stms
;
8378 Expr
:= New_Occurrence_Of
(Target
, Loc
);
8382 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
8385 Read_Call_List
:= New_List
;
8386 Expr
:= New_Occurrence_Of
(Temp
, Loc
);
8388 Append_To
(Stms
, Make_Block_Statement
(Loc
,
8389 Declarations
=> New_List
(
8390 Make_Object_Declaration
(Loc
,
8391 Defining_Identifier
=>
8393 Object_Definition
=>
8394 New_Occurrence_Of
(Typ
, Loc
))),
8396 Handled_Statement_Sequence
=>
8397 Make_Handled_Sequence_Of_Statements
(Loc
,
8398 Statements
=> Read_Call_List
)));
8402 -- Typ'Read (Strm'Access, [Target|Temp])
8404 Append_To
(Read_Call_List
,
8405 Make_Attribute_Reference
(Loc
,
8406 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
8407 Attribute_Name
=> Name_Read
,
8408 Expressions
=> New_List
(
8409 Make_Attribute_Reference
(Loc
,
8410 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
8411 Attribute_Name
=> Name_Access
),
8418 Append_To
(Read_Call_List
,
8419 Make_Simple_Return_Statement
(Loc
,
8420 Expression
=> New_Copy
(Expr
)));
8423 end Assign_Opaque_From_Any
;
8425 -------------------------
8426 -- Build_From_Any_Call --
8427 -------------------------
8429 function Build_From_Any_Call
8432 Decls
: List_Id
) return Node_Id
8434 Loc
: constant Source_Ptr
:= Sloc
(N
);
8436 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
8438 Fnam
: Entity_Id
:= Empty
;
8439 Lib_RE
: RE_Id
:= RE_Null
;
8443 -- First simple case where the From_Any function is present
8444 -- in the type's TSS.
8446 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_From_Any
);
8448 -- For the subtype representing a generic actual type, go to the
8451 if Is_Generic_Actual_Type
(U_Type
) then
8452 U_Type
:= Underlying_Type
(Base_Type
(U_Type
));
8455 -- For a standard subtype, go to the base type
8457 if Sloc
(U_Type
) <= Standard_Location
then
8458 U_Type
:= Base_Type
(U_Type
);
8460 -- For a user subtype, go to first subtype
8462 elsif Comes_From_Source
(U_Type
)
8463 and then Nkind
(Declaration_Node
(U_Type
))
8464 = N_Subtype_Declaration
8466 U_Type
:= First_Subtype
(U_Type
);
8469 -- Check first for Boolean and Character. These are enumeration
8470 -- types, but we treat them specially, since they may require
8471 -- special handling in the transfer protocol. However, this
8472 -- special handling only applies if they have standard
8473 -- representation, otherwise they are treated like any other
8474 -- enumeration type.
8476 if Present
(Fnam
) then
8479 elsif U_Type
= Standard_Boolean
then
8482 elsif U_Type
= Standard_Character
then
8485 elsif U_Type
= Standard_Wide_Character
then
8488 elsif U_Type
= Standard_Wide_Wide_Character
then
8489 Lib_RE
:= RE_FA_WWC
;
8491 -- Floating point types
8493 elsif U_Type
= Standard_Short_Float
then
8496 elsif U_Type
= Standard_Float
then
8499 elsif U_Type
= Standard_Long_Float
then
8502 elsif U_Type
= Standard_Long_Long_Float
then
8503 Lib_RE
:= RE_FA_LLF
;
8507 elsif U_Type
= RTE
(RE_Integer_8
) then
8510 elsif U_Type
= RTE
(RE_Integer_16
) then
8511 Lib_RE
:= RE_FA_I16
;
8513 elsif U_Type
= RTE
(RE_Integer_32
) then
8514 Lib_RE
:= RE_FA_I32
;
8516 elsif U_Type
= RTE
(RE_Integer_64
) then
8517 Lib_RE
:= RE_FA_I64
;
8519 -- Unsigned integer types
8521 elsif U_Type
= RTE
(RE_Unsigned_8
) then
8524 elsif U_Type
= RTE
(RE_Unsigned_16
) then
8525 Lib_RE
:= RE_FA_U16
;
8527 elsif U_Type
= RTE
(RE_Unsigned_32
) then
8528 Lib_RE
:= RE_FA_U32
;
8530 elsif U_Type
= RTE
(RE_Unsigned_64
) then
8531 Lib_RE
:= RE_FA_U64
;
8533 elsif Is_RTE
(U_Type
, RE_Unbounded_String
) then
8534 Lib_RE
:= RE_FA_String
;
8536 -- Special DSA types
8538 elsif Is_RTE
(U_Type
, RE_Any_Container_Ptr
) then
8541 -- Other (non-primitive) types
8548 Build_From_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
8549 Append_To
(Decls
, Decl
);
8553 -- Call the function
8555 if Lib_RE
/= RE_Null
then
8556 pragma Assert
(No
(Fnam
));
8557 Fnam
:= RTE
(Lib_RE
);
8561 Make_Function_Call
(Loc
,
8562 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
8563 Parameter_Associations
=> New_List
(N
));
8565 -- We must set the type of Result, so the unchecked conversion
8566 -- from the underlying type to the base type is properly done.
8568 Set_Etype
(Result
, U_Type
);
8570 return Unchecked_Convert_To
(Typ
, Result
);
8571 end Build_From_Any_Call
;
8573 -----------------------------
8574 -- Build_From_Any_Function --
8575 -----------------------------
8577 procedure Build_From_Any_Function
8581 Fnam
: out Entity_Id
)
8584 Decls
: constant List_Id
:= New_List
;
8585 Stms
: constant List_Id
:= New_List
;
8587 Any_Parameter
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
8589 Use_Opaque_Representation
: Boolean;
8592 -- For a derived type, we can't go past the base type (to the
8593 -- parent type) here, because that would cause the attribute's
8594 -- formal parameter to have the wrong type; hence the Base_Type
8597 if Is_Itype
(Typ
) and then Typ
/= Base_Type
(Typ
) then
8598 Build_From_Any_Function
8606 Fnam
:= Make_Helper_Function_Name
(Loc
, Typ
, Name_From_Any
);
8609 Make_Function_Specification
(Loc
,
8610 Defining_Unit_Name
=> Fnam
,
8611 Parameter_Specifications
=> New_List
(
8612 Make_Parameter_Specification
(Loc
,
8613 Defining_Identifier
=> Any_Parameter
,
8614 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
8615 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
8617 -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any
8620 (not (Is_Remote_Access_To_Class_Wide_Type
(Typ
)));
8622 Use_Opaque_Representation
:= False;
8624 if Has_Stream_Attribute_Definition
8625 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
8627 Has_Stream_Attribute_Definition
8628 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
8630 -- If user-defined stream attributes are specified for this
8631 -- type, use them and transmit data as an opaque sequence of
8634 Use_Opaque_Representation
:= True;
8636 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
8638 Make_Simple_Return_Statement
(Loc
,
8643 New_Occurrence_Of
(Any_Parameter
, Loc
),
8646 elsif Is_Record_Type
(Typ
)
8647 and then not Is_Derived_Type
(Typ
)
8648 and then not Is_Tagged_Type
(Typ
)
8650 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
8652 Make_Simple_Return_Statement
(Loc
,
8656 New_Occurrence_Of
(Any_Parameter
, Loc
),
8661 Disc
: Entity_Id
:= Empty
;
8662 Discriminant_Associations
: List_Id
;
8663 Rdef
: constant Node_Id
:=
8665 (Declaration_Node
(Typ
));
8666 Component_Counter
: Int
:= 0;
8668 -- The returned object
8670 Res
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
8672 Res_Definition
: Node_Id
:= New_Occurrence_Of
(Typ
, Loc
);
8674 procedure FA_Rec_Add_Process_Element
8677 Counter
: in out Int
;
8681 procedure FA_Append_Record_Traversal
is
8682 new Append_Record_Traversal
8684 Add_Process_Element
=> FA_Rec_Add_Process_Element
);
8686 --------------------------------
8687 -- FA_Rec_Add_Process_Element --
8688 --------------------------------
8690 procedure FA_Rec_Add_Process_Element
8693 Counter
: in out Int
;
8699 if Nkind
(Field
) = N_Defining_Identifier
then
8700 -- A regular component
8702 Ctyp
:= Etype
(Field
);
8705 Make_Assignment_Statement
(Loc
,
8706 Name
=> Make_Selected_Component
(Loc
,
8708 New_Occurrence_Of
(Rec
, Loc
),
8710 New_Occurrence_Of
(Field
, Loc
)),
8713 Build_From_Any_Call
(Ctyp
,
8714 Build_Get_Aggregate_Element
(Loc
,
8717 Build_TypeCode_Call
(Loc
, Ctyp
, Decls
),
8719 Make_Integer_Literal
(Loc
, Counter
)),
8727 Struct_Counter
: Int
:= 0;
8729 Block_Decls
: constant List_Id
:= New_List
;
8730 Block_Stmts
: constant List_Id
:= New_List
;
8733 Alt_List
: constant List_Id
:= New_List
;
8734 Choice_List
: List_Id
;
8736 Struct_Any
: constant Entity_Id
:=
8737 Make_Temporary
(Loc
, 'S');
8741 Make_Object_Declaration
(Loc
,
8742 Defining_Identifier
=> Struct_Any
,
8743 Constant_Present
=> True,
8744 Object_Definition
=>
8745 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8747 Make_Function_Call
(Loc
,
8750 (RTE
(RE_Extract_Union_Value
), Loc
),
8752 Parameter_Associations
=> New_List
(
8753 Build_Get_Aggregate_Element
(Loc
,
8756 Make_Function_Call
(Loc
,
8757 Name
=> New_Occurrence_Of
(
8758 RTE
(RE_Any_Member_Type
), Loc
),
8759 Parameter_Associations
=>
8761 New_Occurrence_Of
(Any
, Loc
),
8762 Make_Integer_Literal
(Loc
,
8763 Intval
=> Counter
))),
8765 Make_Integer_Literal
(Loc
,
8766 Intval
=> Counter
))))));
8769 Make_Block_Statement
(Loc
,
8770 Declarations
=> Block_Decls
,
8771 Handled_Statement_Sequence
=>
8772 Make_Handled_Sequence_Of_Statements
(Loc
,
8773 Statements
=> Block_Stmts
)));
8775 Append_To
(Block_Stmts
,
8776 Make_Case_Statement
(Loc
,
8778 Make_Selected_Component
(Loc
,
8780 Selector_Name
=> Chars
(Name
(Field
))),
8781 Alternatives
=> Alt_List
));
8783 Variant
:= First_Non_Pragma
(Variants
(Field
));
8784 while Present
(Variant
) loop
8787 (Discrete_Choices
(Variant
));
8789 VP_Stmts
:= New_List
;
8791 -- Struct_Counter should be reset before
8792 -- handling a variant part. Indeed only one
8793 -- of the case statement alternatives will be
8794 -- executed at run time, so the counter must
8795 -- start at 0 for every case statement.
8797 Struct_Counter
:= 0;
8799 FA_Append_Record_Traversal
(
8801 Clist
=> Component_List
(Variant
),
8802 Container
=> Struct_Any
,
8803 Counter
=> Struct_Counter
);
8805 Append_To
(Alt_List
,
8806 Make_Case_Statement_Alternative
(Loc
,
8807 Discrete_Choices
=> Choice_List
,
8808 Statements
=> VP_Stmts
));
8809 Next_Non_Pragma
(Variant
);
8814 Counter
:= Counter
+ 1;
8815 end FA_Rec_Add_Process_Element
;
8818 -- First all discriminants
8820 if Has_Discriminants
(Typ
) then
8821 Discriminant_Associations
:= New_List
;
8823 Disc
:= First_Discriminant
(Typ
);
8824 while Present
(Disc
) loop
8826 Disc_Var_Name
: constant Entity_Id
:=
8827 Make_Defining_Identifier
(Loc
,
8828 Chars
=> Chars
(Disc
));
8829 Disc_Type
: constant Entity_Id
:=
8834 Make_Object_Declaration
(Loc
,
8835 Defining_Identifier
=> Disc_Var_Name
,
8836 Constant_Present
=> True,
8837 Object_Definition
=>
8838 New_Occurrence_Of
(Disc_Type
, Loc
),
8841 Build_From_Any_Call
(Disc_Type
,
8842 Build_Get_Aggregate_Element
(Loc
,
8843 Any
=> Any_Parameter
,
8844 TC
=> Build_TypeCode_Call
8845 (Loc
, Disc_Type
, Decls
),
8846 Idx
=> Make_Integer_Literal
(Loc
,
8847 Intval
=> Component_Counter
)),
8850 Component_Counter
:= Component_Counter
+ 1;
8852 Append_To
(Discriminant_Associations
,
8853 Make_Discriminant_Association
(Loc
,
8854 Selector_Names
=> New_List
(
8855 New_Occurrence_Of
(Disc
, Loc
)),
8857 New_Occurrence_Of
(Disc_Var_Name
, Loc
)));
8859 Next_Discriminant
(Disc
);
8863 Make_Subtype_Indication
(Loc
,
8864 Subtype_Mark
=> Res_Definition
,
8866 Make_Index_Or_Discriminant_Constraint
(Loc
,
8867 Discriminant_Associations
));
8870 -- Now we have all the discriminants in variables, we can
8871 -- declared a constrained object. Note that we are not
8872 -- initializing (non-discriminant) components directly in
8873 -- the object declarations, because which fields to
8874 -- initialize depends (at run time) on the discriminant
8878 Make_Object_Declaration
(Loc
,
8879 Defining_Identifier
=> Res
,
8880 Object_Definition
=> Res_Definition
));
8882 -- ... then all components
8884 FA_Append_Record_Traversal
(Stms
,
8885 Clist
=> Component_List
(Rdef
),
8886 Container
=> Any_Parameter
,
8887 Counter
=> Component_Counter
);
8890 Make_Simple_Return_Statement
(Loc
,
8891 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
8895 elsif Is_Array_Type
(Typ
) then
8897 Constrained
: constant Boolean := Is_Constrained
(Typ
);
8899 procedure FA_Ary_Add_Process_Element
8902 Counter
: Entity_Id
;
8904 -- Assign the current element (as identified by Counter) of
8905 -- Any to the variable denoted by name Datum, and advance
8906 -- Counter by 1. If Datum is not an Any, a call to From_Any
8907 -- for its type is inserted.
8909 --------------------------------
8910 -- FA_Ary_Add_Process_Element --
8911 --------------------------------
8913 procedure FA_Ary_Add_Process_Element
8916 Counter
: Entity_Id
;
8919 Assignment
: constant Node_Id
:=
8920 Make_Assignment_Statement
(Loc
,
8922 Expression
=> Empty
);
8924 Element_Any
: Node_Id
;
8928 Element_TC
: Node_Id
;
8931 if Etype
(Datum
) = RTE
(RE_Any
) then
8933 -- When Datum is an Any the Etype field is not
8934 -- sufficient to determine the typecode of Datum
8935 -- (which can be a TC_SEQUENCE or TC_ARRAY
8936 -- depending on the value of Constrained).
8938 -- Therefore we retrieve the typecode which has
8939 -- been constructed in Append_Array_Traversal with
8940 -- a call to Get_Any_Type.
8943 Make_Function_Call
(Loc
,
8944 Name
=> New_Occurrence_Of
(
8945 RTE
(RE_Get_Any_Type
), Loc
),
8946 Parameter_Associations
=> New_List
(
8947 New_Occurrence_Of
(Entity
(Datum
), Loc
)));
8949 -- For non Any Datum we simply construct a typecode
8950 -- matching the Etype of the Datum.
8952 Element_TC
:= Build_TypeCode_Call
8953 (Loc
, Etype
(Datum
), Decls
);
8957 Build_Get_Aggregate_Element
(Loc
,
8960 Idx
=> New_Occurrence_Of
(Counter
, Loc
));
8963 -- Note: here we *prepend* statements to Stmts, so
8964 -- we must do it in reverse order.
8967 Make_Assignment_Statement
(Loc
,
8969 New_Occurrence_Of
(Counter
, Loc
),
8972 Left_Opnd
=> New_Occurrence_Of
(Counter
, Loc
),
8973 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
8975 if Nkind
(Datum
) /= N_Attribute_Reference
then
8977 -- We ignore the value of the length of each
8978 -- dimension, since the target array has already been
8979 -- constrained anyway.
8981 if Etype
(Datum
) /= RTE
(RE_Any
) then
8982 Set_Expression
(Assignment
,
8984 (Component_Type
(Typ
), Element_Any
, Decls
));
8986 Set_Expression
(Assignment
, Element_Any
);
8989 Prepend_To
(Stmts
, Assignment
);
8991 end FA_Ary_Add_Process_Element
;
8993 ------------------------
8994 -- Local Declarations --
8995 ------------------------
8997 Counter
: constant Entity_Id
:=
8998 Make_Defining_Identifier
(Loc
, Name_J
);
9000 Initial_Counter_Value
: Int
:= 0;
9002 Component_TC
: constant Entity_Id
:=
9003 Make_Defining_Identifier
(Loc
, Name_T
);
9005 Res
: constant Entity_Id
:=
9006 Make_Defining_Identifier
(Loc
, Name_R
);
9008 procedure Append_From_Any_Array_Iterator
is
9009 new Append_Array_Traversal
(
9012 Indexes
=> New_List
,
9013 Add_Process_Element
=> FA_Ary_Add_Process_Element
);
9015 Res_Subtype_Indication
: Node_Id
:=
9016 New_Occurrence_Of
(Typ
, Loc
);
9019 if not Constrained
then
9021 Ndim
: constant Int
:= Number_Dimensions
(Typ
);
9024 Indx
: Node_Id
:= First_Index
(Typ
);
9027 Ranges
: constant List_Id
:= New_List
;
9030 for J
in 1 .. Ndim
loop
9031 Lnam
:= New_External_Name
('L', J
);
9032 Hnam
:= New_External_Name
('H', J
);
9034 -- Note, for empty arrays bounds may be out of
9035 -- the range of Etype (Indx).
9037 Indt
:= Base_Type
(Etype
(Indx
));
9040 Make_Object_Declaration
(Loc
,
9041 Defining_Identifier
=>
9042 Make_Defining_Identifier
(Loc
, Lnam
),
9043 Constant_Present
=> True,
9044 Object_Definition
=>
9045 New_Occurrence_Of
(Indt
, Loc
),
9049 Build_Get_Aggregate_Element
(Loc
,
9050 Any
=> Any_Parameter
,
9051 TC
=> Build_TypeCode_Call
9054 Make_Integer_Literal
(Loc
, J
- 1)),
9058 Make_Object_Declaration
(Loc
,
9059 Defining_Identifier
=>
9060 Make_Defining_Identifier
(Loc
, Hnam
),
9062 Constant_Present
=> True,
9064 Object_Definition
=>
9065 New_Occurrence_Of
(Indt
, Loc
),
9067 Expression
=> Make_Attribute_Reference
(Loc
,
9069 New_Occurrence_Of
(Indt
, Loc
),
9071 Attribute_Name
=> Name_Val
,
9073 Expressions
=> New_List
(
9074 Make_Op_Subtract
(Loc
,
9079 (Standard_Long_Integer
,
9080 Make_Identifier
(Loc
, Lnam
)),
9084 (Standard_Long_Integer
,
9085 Make_Function_Call
(Loc
,
9087 New_Occurrence_Of
(RTE
(
9088 RE_Get_Nested_Sequence_Length
9090 Parameter_Associations
=>
9093 Any_Parameter
, Loc
),
9094 Make_Integer_Literal
(Loc
,
9098 Make_Integer_Literal
(Loc
, 1))))));
9102 Low_Bound
=> Make_Identifier
(Loc
, Lnam
),
9103 High_Bound
=> Make_Identifier
(Loc
, Hnam
)));
9108 -- Now we have all the necessary bound information:
9109 -- apply the set of range constraints to the
9110 -- (unconstrained) nominal subtype of Res.
9112 Initial_Counter_Value
:= Ndim
;
9113 Res_Subtype_Indication
:= Make_Subtype_Indication
(Loc
,
9114 Subtype_Mark
=> Res_Subtype_Indication
,
9116 Make_Index_Or_Discriminant_Constraint
(Loc
,
9117 Constraints
=> Ranges
));
9122 Make_Object_Declaration
(Loc
,
9123 Defining_Identifier
=> Res
,
9124 Object_Definition
=> Res_Subtype_Indication
));
9125 Set_Etype
(Res
, Typ
);
9128 Make_Object_Declaration
(Loc
,
9129 Defining_Identifier
=> Counter
,
9130 Object_Definition
=>
9131 New_Occurrence_Of
(RTE
(RE_Unsigned_32
), Loc
),
9133 Make_Integer_Literal
(Loc
, Initial_Counter_Value
)));
9136 Make_Object_Declaration
(Loc
,
9137 Defining_Identifier
=> Component_TC
,
9138 Constant_Present
=> True,
9139 Object_Definition
=>
9140 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
),
9142 Build_TypeCode_Call
(Loc
,
9143 Component_Type
(Typ
), Decls
)));
9145 Append_From_Any_Array_Iterator
9146 (Stms
, Any_Parameter
, Counter
);
9149 Make_Simple_Return_Statement
(Loc
,
9150 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
9153 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9155 Make_Simple_Return_Statement
(Loc
,
9157 Unchecked_Convert_To
(Typ
,
9159 (Find_Numeric_Representation
(Typ
),
9160 New_Occurrence_Of
(Any_Parameter
, Loc
),
9164 Use_Opaque_Representation
:= True;
9167 if Use_Opaque_Representation
then
9168 Assign_Opaque_From_Any
(Loc
,
9171 N
=> New_Occurrence_Of
(Any_Parameter
, Loc
),
9176 Make_Subprogram_Body
(Loc
,
9177 Specification
=> Spec
,
9178 Declarations
=> Decls
,
9179 Handled_Statement_Sequence
=>
9180 Make_Handled_Sequence_Of_Statements
(Loc
,
9181 Statements
=> Stms
));
9182 end Build_From_Any_Function
;
9184 ---------------------------------
9185 -- Build_Get_Aggregate_Element --
9186 ---------------------------------
9188 function Build_Get_Aggregate_Element
9192 Idx
: Node_Id
) return Node_Id
9195 return Make_Function_Call
(Loc
,
9197 New_Occurrence_Of
(RTE
(RE_Get_Aggregate_Element
), Loc
),
9198 Parameter_Associations
=> New_List
(
9199 New_Occurrence_Of
(Any
, Loc
),
9202 end Build_Get_Aggregate_Element
;
9204 -------------------------
9205 -- Build_Reposiroty_Id --
9206 -------------------------
9208 procedure Build_Name_And_Repository_Id
9210 Name_Str
: out String_Id
;
9211 Repo_Id_Str
: out String_Id
)
9214 Name_Str
:= Fully_Qualified_Name_String
(E
, Append_NUL
=> False);
9216 Store_String_Chars
("DSA:");
9217 Store_String_Chars
(Name_Str
);
9218 Store_String_Chars
(":1.0");
9219 Repo_Id_Str
:= End_String
;
9220 end Build_Name_And_Repository_Id
;
9222 -----------------------
9223 -- Build_To_Any_Call --
9224 -----------------------
9226 function Build_To_Any_Call
9229 Decls
: List_Id
) return Node_Id
9231 Typ
: Entity_Id
:= Etype
(N
);
9234 Fnam
: Entity_Id
:= Empty
;
9235 Lib_RE
: RE_Id
:= RE_Null
;
9238 -- If N is a selected component, then maybe its Etype has not been
9239 -- set yet: try to use Etype of the selector_name in that case.
9241 if No
(Typ
) and then Nkind
(N
) = N_Selected_Component
then
9242 Typ
:= Etype
(Selector_Name
(N
));
9245 pragma Assert
(Present
(Typ
));
9247 -- Get full view for private type, completion for incomplete type
9249 U_Type
:= Underlying_Type
(Typ
);
9251 -- First simple case where the To_Any function is present in the
9254 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_To_Any
);
9256 -- For the subtype representing a generic actual type, go to the
9259 if Is_Generic_Actual_Type
(U_Type
) then
9260 U_Type
:= Underlying_Type
(Base_Type
(U_Type
));
9263 -- For a standard subtype, go to the base type
9265 if Sloc
(U_Type
) <= Standard_Location
then
9266 U_Type
:= Base_Type
(U_Type
);
9268 -- For a user subtype, go to first subtype
9270 elsif Comes_From_Source
(U_Type
)
9271 and then Nkind
(Declaration_Node
(U_Type
))
9272 = N_Subtype_Declaration
9274 U_Type
:= First_Subtype
(U_Type
);
9277 if Present
(Fnam
) then
9280 -- Check first for Boolean and Character. These are enumeration
9281 -- types, but we treat them specially, since they may require
9282 -- special handling in the transfer protocol. However, this
9283 -- special handling only applies if they have standard
9284 -- representation, otherwise they are treated like any other
9285 -- enumeration type.
9287 elsif U_Type
= Standard_Boolean
then
9290 elsif U_Type
= Standard_Character
then
9293 elsif U_Type
= Standard_Wide_Character
then
9296 elsif U_Type
= Standard_Wide_Wide_Character
then
9297 Lib_RE
:= RE_TA_WWC
;
9299 -- Floating point types
9301 elsif U_Type
= Standard_Short_Float
then
9304 elsif U_Type
= Standard_Float
then
9307 elsif U_Type
= Standard_Long_Float
then
9310 elsif U_Type
= Standard_Long_Long_Float
then
9311 Lib_RE
:= RE_TA_LLF
;
9315 elsif U_Type
= RTE
(RE_Integer_8
) then
9318 elsif U_Type
= RTE
(RE_Integer_16
) then
9319 Lib_RE
:= RE_TA_I16
;
9321 elsif U_Type
= RTE
(RE_Integer_32
) then
9322 Lib_RE
:= RE_TA_I32
;
9324 elsif U_Type
= RTE
(RE_Integer_64
) then
9325 Lib_RE
:= RE_TA_I64
;
9327 -- Unsigned integer types
9329 elsif U_Type
= RTE
(RE_Unsigned_8
) then
9332 elsif U_Type
= RTE
(RE_Unsigned_16
) then
9333 Lib_RE
:= RE_TA_U16
;
9335 elsif U_Type
= RTE
(RE_Unsigned_32
) then
9336 Lib_RE
:= RE_TA_U32
;
9338 elsif U_Type
= RTE
(RE_Unsigned_64
) then
9339 Lib_RE
:= RE_TA_U64
;
9341 elsif Is_RTE
(U_Type
, RE_Unbounded_String
) then
9342 Lib_RE
:= RE_TA_String
;
9344 -- Special DSA types
9346 elsif Is_RTE
(U_Type
, RE_Any_Container_Ptr
) then
9350 elsif U_Type
= Underlying_Type
(RTE
(RE_TypeCode
)) then
9352 -- No corresponding FA_TC ???
9356 -- Other (non-primitive) types
9362 Build_To_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
9363 Append_To
(Decls
, Decl
);
9367 -- Call the function
9369 if Lib_RE
/= RE_Null
then
9370 pragma Assert
(No
(Fnam
));
9371 Fnam
:= RTE
(Lib_RE
);
9374 -- If Fnam is already analyzed, find the proper expected type,
9375 -- else we have a newly constructed To_Any function and we know
9376 -- that the expected type of its parameter is U_Type.
9378 if Ekind
(Fnam
) = E_Function
9379 and then Present
(First_Formal
(Fnam
))
9381 C_Type
:= Etype
(First_Formal
(Fnam
));
9387 Make_Function_Call
(Loc
,
9388 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
9389 Parameter_Associations
=>
9390 New_List
(OK_Convert_To
(C_Type
, N
)));
9391 end Build_To_Any_Call
;
9393 ---------------------------
9394 -- Build_To_Any_Function --
9395 ---------------------------
9397 procedure Build_To_Any_Function
9401 Fnam
: out Entity_Id
)
9404 Decls
: constant List_Id
:= New_List
;
9405 Stms
: constant List_Id
:= New_List
;
9407 Expr_Parameter
: Entity_Id
;
9409 Result_TC
: Node_Id
;
9413 Use_Opaque_Representation
: Boolean;
9414 -- When True, use stream attributes and represent type as an
9415 -- opaque sequence of bytes.
9418 -- For a derived type, we can't go past the base type (to the
9419 -- parent type) here, because that would cause the attribute's
9420 -- formal parameter to have the wrong type; hence the Base_Type
9423 if Is_Itype
(Typ
) and then Typ
/= Base_Type
(Typ
) then
9424 Build_To_Any_Function
9432 Expr_Parameter
:= Make_Defining_Identifier
(Loc
, Name_E
);
9433 Any
:= Make_Defining_Identifier
(Loc
, Name_A
);
9434 Result_TC
:= Build_TypeCode_Call
(Loc
, Typ
, Decls
);
9436 Fnam
:= Make_Helper_Function_Name
(Loc
, Typ
, Name_To_Any
);
9439 Make_Function_Specification
(Loc
,
9440 Defining_Unit_Name
=> Fnam
,
9441 Parameter_Specifications
=> New_List
(
9442 Make_Parameter_Specification
(Loc
,
9443 Defining_Identifier
=> Expr_Parameter
,
9444 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
9445 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9446 Set_Etype
(Expr_Parameter
, Typ
);
9449 Make_Object_Declaration
(Loc
,
9450 Defining_Identifier
=> Any
,
9451 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9453 Use_Opaque_Representation
:= False;
9455 if Has_Stream_Attribute_Definition
9456 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
9458 Has_Stream_Attribute_Definition
9459 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
9461 -- If user-defined stream attributes are specified for this
9462 -- type, use them and transmit data as an opaque sequence of
9465 Use_Opaque_Representation
:= True;
9467 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9469 -- Non-tagged derived type: convert to root type
9472 Rt_Type
: constant Entity_Id
:= Root_Type
(Typ
);
9473 Expr
: constant Node_Id
:=
9476 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9478 Set_Expression
(Any_Decl
,
9479 Build_To_Any_Call
(Loc
, Expr
, Decls
));
9482 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9484 -- Non-tagged record type
9486 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
9488 Rt_Type
: constant Entity_Id
:= Etype
(Typ
);
9489 Expr
: constant Node_Id
:=
9490 OK_Convert_To
(Rt_Type
,
9491 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9495 (Any_Decl
, Build_To_Any_Call
(Loc
, Expr
, Decls
));
9498 -- Comment needed here (and label on declare block ???)
9502 Disc
: Entity_Id
:= Empty
;
9503 Rdef
: constant Node_Id
:=
9504 Type_Definition
(Declaration_Node
(Typ
));
9506 Elements
: constant List_Id
:= New_List
;
9508 procedure TA_Rec_Add_Process_Element
9510 Container
: Node_Or_Entity_Id
;
9511 Counter
: in out Int
;
9514 -- Processing routine for traversal below
9516 procedure TA_Append_Record_Traversal
is
9517 new Append_Record_Traversal
9518 (Rec
=> Expr_Parameter
,
9519 Add_Process_Element
=> TA_Rec_Add_Process_Element
);
9521 --------------------------------
9522 -- TA_Rec_Add_Process_Element --
9523 --------------------------------
9525 procedure TA_Rec_Add_Process_Element
9527 Container
: Node_Or_Entity_Id
;
9528 Counter
: in out Int
;
9532 Field_Ref
: Node_Id
;
9535 if Nkind
(Field
) = N_Defining_Identifier
then
9537 -- A regular component
9539 Field_Ref
:= Make_Selected_Component
(Loc
,
9540 Prefix
=> New_Occurrence_Of
(Rec
, Loc
),
9541 Selector_Name
=> New_Occurrence_Of
(Field
, Loc
));
9542 Set_Etype
(Field_Ref
, Etype
(Field
));
9545 Make_Procedure_Call_Statement
(Loc
,
9548 RTE
(RE_Add_Aggregate_Element
), Loc
),
9549 Parameter_Associations
=> New_List
(
9550 New_Occurrence_Of
(Container
, Loc
),
9551 Build_To_Any_Call
(Loc
, Field_Ref
, Decls
))));
9556 Variant_Part
: declare
9558 Struct_Counter
: Int
:= 0;
9560 Block_Decls
: constant List_Id
:= New_List
;
9561 Block_Stmts
: constant List_Id
:= New_List
;
9564 Alt_List
: constant List_Id
:= New_List
;
9565 Choice_List
: List_Id
;
9567 Union_Any
: constant Entity_Id
:=
9568 Make_Temporary
(Loc
, 'V');
9570 Struct_Any
: constant Entity_Id
:=
9571 Make_Temporary
(Loc
, 'S');
9573 function Make_Discriminant_Reference
9575 -- Build reference to the discriminant for this
9578 ---------------------------------
9579 -- Make_Discriminant_Reference --
9580 ---------------------------------
9582 function Make_Discriminant_Reference
9585 Nod
: constant Node_Id
:=
9586 Make_Selected_Component
(Loc
,
9589 Chars
(Name
(Field
)));
9591 Set_Etype
(Nod
, Etype
(Name
(Field
)));
9593 end Make_Discriminant_Reference
;
9595 -- Start of processing for Variant_Part
9599 Make_Block_Statement
(Loc
,
9602 Handled_Statement_Sequence
=>
9603 Make_Handled_Sequence_Of_Statements
(Loc
,
9604 Statements
=> Block_Stmts
)));
9606 -- Declare variant part aggregate (Union_Any).
9607 -- Knowing the position of this VP in the
9608 -- variant record, we can fetch the VP typecode
9611 Append_To
(Block_Decls
,
9612 Make_Object_Declaration
(Loc
,
9613 Defining_Identifier
=> Union_Any
,
9614 Object_Definition
=>
9615 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9617 Make_Function_Call
(Loc
,
9618 Name
=> New_Occurrence_Of
(
9619 RTE
(RE_Create_Any
), Loc
),
9620 Parameter_Associations
=> New_List
(
9621 Make_Function_Call
(Loc
,
9624 RTE
(RE_Any_Member_Type
), Loc
),
9625 Parameter_Associations
=> New_List
(
9626 New_Occurrence_Of
(Container
, Loc
),
9627 Make_Integer_Literal
(Loc
,
9630 -- Declare inner struct aggregate (which
9631 -- contains the components of this VP).
9633 Append_To
(Block_Decls
,
9634 Make_Object_Declaration
(Loc
,
9635 Defining_Identifier
=> Struct_Any
,
9636 Object_Definition
=>
9637 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9639 Make_Function_Call
(Loc
,
9640 Name
=> New_Occurrence_Of
(
9641 RTE
(RE_Create_Any
), Loc
),
9642 Parameter_Associations
=> New_List
(
9643 Make_Function_Call
(Loc
,
9646 RTE
(RE_Any_Member_Type
), Loc
),
9647 Parameter_Associations
=> New_List
(
9648 New_Occurrence_Of
(Union_Any
, Loc
),
9649 Make_Integer_Literal
(Loc
,
9652 -- Build case statement
9654 Append_To
(Block_Stmts
,
9655 Make_Case_Statement
(Loc
,
9656 Expression
=> Make_Discriminant_Reference
,
9657 Alternatives
=> Alt_List
));
9659 Variant
:= First_Non_Pragma
(Variants
(Field
));
9660 while Present
(Variant
) loop
9661 Choice_List
:= New_Copy_List_Tree
9662 (Discrete_Choices
(Variant
));
9664 VP_Stmts
:= New_List
;
9666 -- Append discriminant val to union aggregate
9668 Append_To
(VP_Stmts
,
9669 Make_Procedure_Call_Statement
(Loc
,
9672 RTE
(RE_Add_Aggregate_Element
), Loc
),
9673 Parameter_Associations
=> New_List
(
9674 New_Occurrence_Of
(Union_Any
, Loc
),
9677 Make_Discriminant_Reference
,
9680 -- Populate inner struct aggregate
9682 -- Struct_Counter should be reset before
9683 -- handling a variant part. Indeed only one
9684 -- of the case statement alternatives will be
9685 -- executed at run time, so the counter must
9686 -- start at 0 for every case statement.
9688 Struct_Counter
:= 0;
9690 TA_Append_Record_Traversal
9692 Clist
=> Component_List
(Variant
),
9693 Container
=> Struct_Any
,
9694 Counter
=> Struct_Counter
);
9696 -- Append inner struct to union aggregate
9698 Append_To
(VP_Stmts
,
9699 Make_Procedure_Call_Statement
(Loc
,
9702 (RTE
(RE_Add_Aggregate_Element
), Loc
),
9703 Parameter_Associations
=> New_List
(
9704 New_Occurrence_Of
(Union_Any
, Loc
),
9705 New_Occurrence_Of
(Struct_Any
, Loc
))));
9707 -- Append union to outer aggregate
9709 Append_To
(VP_Stmts
,
9710 Make_Procedure_Call_Statement
(Loc
,
9713 (RTE
(RE_Add_Aggregate_Element
), Loc
),
9714 Parameter_Associations
=> New_List
(
9715 New_Occurrence_Of
(Container
, Loc
),
9717 (Union_Any
, Loc
))));
9719 Append_To
(Alt_List
,
9720 Make_Case_Statement_Alternative
(Loc
,
9721 Discrete_Choices
=> Choice_List
,
9722 Statements
=> VP_Stmts
));
9724 Next_Non_Pragma
(Variant
);
9729 Counter
:= Counter
+ 1;
9730 end TA_Rec_Add_Process_Element
;
9733 -- Records are encoded in a TC_STRUCT aggregate:
9735 -- -- Outer aggregate (TC_STRUCT)
9736 -- | [discriminant1]
9737 -- | [discriminant2]
9744 -- A component can be a common component or variant part
9746 -- A variant part is encoded as a TC_UNION aggregate:
9748 -- -- Variant Part Aggregate (TC_UNION)
9749 -- | [discriminant choice for this Variant Part]
9751 -- | -- Inner struct (TC_STRUCT)
9756 -- Let's start by building the outer aggregate. First we
9757 -- construct Elements array containing all discriminants.
9759 if Has_Discriminants
(Typ
) then
9760 Disc
:= First_Discriminant
(Typ
);
9761 while Present
(Disc
) loop
9763 Discriminant
: constant Entity_Id
:=
9764 Make_Selected_Component
(Loc
,
9771 Set_Etype
(Discriminant
, Etype
(Disc
));
9773 Append_To
(Elements
,
9774 Make_Component_Association
(Loc
,
9775 Choices
=> New_List
(
9776 Make_Integer_Literal
(Loc
, Counter
)),
9778 Build_To_Any_Call
(Loc
,
9779 Discriminant
, Decls
)));
9782 Counter
:= Counter
+ 1;
9783 Next_Discriminant
(Disc
);
9787 -- If there are no discriminants, we declare an empty
9791 Dummy_Any
: constant Entity_Id
:=
9792 Make_Temporary
(Loc
, 'A');
9796 Make_Object_Declaration
(Loc
,
9797 Defining_Identifier
=> Dummy_Any
,
9798 Object_Definition
=>
9799 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
9801 Append_To
(Elements
,
9802 Make_Component_Association
(Loc
,
9803 Choices
=> New_List
(
9806 Make_Integer_Literal
(Loc
, 1),
9808 Make_Integer_Literal
(Loc
, 0))),
9810 New_Occurrence_Of
(Dummy_Any
, Loc
)));
9814 -- We build the result aggregate with discriminants
9815 -- as the first elements.
9817 Set_Expression
(Any_Decl
,
9818 Make_Function_Call
(Loc
,
9819 Name
=> New_Occurrence_Of
9820 (RTE
(RE_Any_Aggregate_Build
), Loc
),
9821 Parameter_Associations
=> New_List
(
9823 Make_Aggregate
(Loc
,
9824 Component_Associations
=> Elements
))));
9827 -- Then we append all the components to the result
9830 TA_Append_Record_Traversal
(Stms
,
9831 Clist
=> Component_List
(Rdef
),
9833 Counter
=> Counter
);
9837 elsif Is_Array_Type
(Typ
) then
9839 -- Constrained and unconstrained array types
9842 Constrained
: constant Boolean := Is_Constrained
(Typ
);
9844 procedure TA_Ary_Add_Process_Element
9847 Counter
: Entity_Id
;
9850 --------------------------------
9851 -- TA_Ary_Add_Process_Element --
9852 --------------------------------
9854 procedure TA_Ary_Add_Process_Element
9857 Counter
: Entity_Id
;
9860 pragma Unreferenced
(Counter
);
9862 Element_Any
: Node_Id
;
9865 if Etype
(Datum
) = RTE
(RE_Any
) then
9866 Element_Any
:= Datum
;
9868 Element_Any
:= Build_To_Any_Call
(Loc
, Datum
, Decls
);
9872 Make_Procedure_Call_Statement
(Loc
,
9873 Name
=> New_Occurrence_Of
(
9874 RTE
(RE_Add_Aggregate_Element
), Loc
),
9875 Parameter_Associations
=> New_List
(
9876 New_Occurrence_Of
(Any
, Loc
),
9878 end TA_Ary_Add_Process_Element
;
9880 procedure Append_To_Any_Array_Iterator
is
9881 new Append_Array_Traversal
(
9883 Arry
=> Expr_Parameter
,
9884 Indexes
=> New_List
,
9885 Add_Process_Element
=> TA_Ary_Add_Process_Element
);
9890 Set_Expression
(Any_Decl
,
9891 Make_Function_Call
(Loc
,
9893 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
9894 Parameter_Associations
=> New_List
(Result_TC
)));
9897 if not Constrained
then
9898 Index
:= First_Index
(Typ
);
9899 for J
in 1 .. Number_Dimensions
(Typ
) loop
9901 Make_Procedure_Call_Statement
(Loc
,
9904 RTE
(RE_Add_Aggregate_Element
), Loc
),
9905 Parameter_Associations
=> New_List
(
9906 New_Occurrence_Of
(Any
, Loc
),
9907 Build_To_Any_Call
(Loc
,
9908 OK_Convert_To
(Etype
(Index
),
9909 Make_Attribute_Reference
(Loc
,
9911 New_Occurrence_Of
(Expr_Parameter
, Loc
),
9912 Attribute_Name
=> Name_First
,
9913 Expressions
=> New_List
(
9914 Make_Integer_Literal
(Loc
, J
)))),
9920 Append_To_Any_Array_Iterator
(Stms
, Any
);
9923 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9927 Set_Expression
(Any_Decl
,
9928 Build_To_Any_Call
(Loc
,
9930 Find_Numeric_Representation
(Typ
),
9931 New_Occurrence_Of
(Expr_Parameter
, Loc
)),
9935 -- Default case, including tagged types: opaque representation
9937 Use_Opaque_Representation
:= True;
9940 if Use_Opaque_Representation
then
9942 Strm
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
9943 -- Stream used to store data representation produced by
9944 -- stream attribute.
9948 -- Strm : aliased Buffer_Stream_Type;
9951 Make_Object_Declaration
(Loc
,
9952 Defining_Identifier
=>
9956 Object_Definition
=>
9957 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
9960 -- T'Output (Strm'Access, E);
9963 Make_Attribute_Reference
(Loc
,
9964 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
9965 Attribute_Name
=> Name_Output
,
9966 Expressions
=> New_List
(
9967 Make_Attribute_Reference
(Loc
,
9968 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
9969 Attribute_Name
=> Name_Access
),
9970 New_Occurrence_Of
(Expr_Parameter
, Loc
))));
9973 -- BS_To_Any (Strm, A);
9976 Make_Procedure_Call_Statement
(Loc
,
9977 Name
=> New_Occurrence_Of
(RTE
(RE_BS_To_Any
), Loc
),
9978 Parameter_Associations
=> New_List
(
9979 New_Occurrence_Of
(Strm
, Loc
),
9980 New_Occurrence_Of
(Any
, Loc
))));
9983 -- Release_Buffer (Strm);
9986 Make_Procedure_Call_Statement
(Loc
,
9987 Name
=> New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
9988 Parameter_Associations
=> New_List
(
9989 New_Occurrence_Of
(Strm
, Loc
))));
9993 Append_To
(Decls
, Any_Decl
);
9995 if Present
(Result_TC
) then
9997 Make_Procedure_Call_Statement
(Loc
,
9998 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
9999 Parameter_Associations
=> New_List
(
10000 New_Occurrence_Of
(Any
, Loc
),
10005 Make_Simple_Return_Statement
(Loc
,
10006 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
10009 Make_Subprogram_Body
(Loc
,
10010 Specification
=> Spec
,
10011 Declarations
=> Decls
,
10012 Handled_Statement_Sequence
=>
10013 Make_Handled_Sequence_Of_Statements
(Loc
,
10014 Statements
=> Stms
));
10015 end Build_To_Any_Function
;
10017 -------------------------
10018 -- Build_TypeCode_Call --
10019 -------------------------
10021 function Build_TypeCode_Call
10024 Decls
: List_Id
) return Node_Id
10026 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
10027 -- The full view, if Typ is private; the completion,
10028 -- if Typ is incomplete.
10030 Fnam
: Entity_Id
:= Empty
;
10031 Lib_RE
: RE_Id
:= RE_Null
;
10035 -- Special case System.PolyORB.Interface.Any: its primitives have
10036 -- not been set yet, so can't call Find_Inherited_TSS.
10038 if Typ
= RTE
(RE_Any
) then
10039 Fnam
:= RTE
(RE_TC_A
);
10042 -- First simple case where the TypeCode is present
10043 -- in the type's TSS.
10045 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_TypeCode
);
10048 -- For the subtype representing a generic actual type, go to the
10051 if Is_Generic_Actual_Type
(U_Type
) then
10052 U_Type
:= Underlying_Type
(Base_Type
(U_Type
));
10055 -- For a standard subtype, go to the base type
10057 if Sloc
(U_Type
) <= Standard_Location
then
10058 U_Type
:= Base_Type
(U_Type
);
10060 -- For a user subtype, go to first subtype
10062 elsif Comes_From_Source
(U_Type
)
10063 and then Nkind
(Declaration_Node
(U_Type
))
10064 = N_Subtype_Declaration
10066 U_Type
:= First_Subtype
(U_Type
);
10070 if U_Type
= Standard_Boolean
then
10073 elsif U_Type
= Standard_Character
then
10076 elsif U_Type
= Standard_Wide_Character
then
10077 Lib_RE
:= RE_TC_WC
;
10079 elsif U_Type
= Standard_Wide_Wide_Character
then
10080 Lib_RE
:= RE_TC_WWC
;
10082 -- Floating point types
10084 elsif U_Type
= Standard_Short_Float
then
10085 Lib_RE
:= RE_TC_SF
;
10087 elsif U_Type
= Standard_Float
then
10090 elsif U_Type
= Standard_Long_Float
then
10091 Lib_RE
:= RE_TC_LF
;
10093 elsif U_Type
= Standard_Long_Long_Float
then
10094 Lib_RE
:= RE_TC_LLF
;
10096 -- Integer types (walk back to the base type)
10098 elsif U_Type
= RTE
(RE_Integer_8
) then
10099 Lib_RE
:= RE_TC_I8
;
10101 elsif U_Type
= RTE
(RE_Integer_16
) then
10102 Lib_RE
:= RE_TC_I16
;
10104 elsif U_Type
= RTE
(RE_Integer_32
) then
10105 Lib_RE
:= RE_TC_I32
;
10107 elsif U_Type
= RTE
(RE_Integer_64
) then
10108 Lib_RE
:= RE_TC_I64
;
10110 -- Unsigned integer types
10112 elsif U_Type
= RTE
(RE_Unsigned_8
) then
10113 Lib_RE
:= RE_TC_U8
;
10115 elsif U_Type
= RTE
(RE_Unsigned_16
) then
10116 Lib_RE
:= RE_TC_U16
;
10118 elsif U_Type
= RTE
(RE_Unsigned_32
) then
10119 Lib_RE
:= RE_TC_U32
;
10121 elsif U_Type
= RTE
(RE_Unsigned_64
) then
10122 Lib_RE
:= RE_TC_U64
;
10124 elsif Is_RTE
(U_Type
, RE_Unbounded_String
) then
10125 Lib_RE
:= RE_TC_String
;
10127 -- Special DSA types
10129 elsif Is_RTE
(U_Type
, RE_Any_Container_Ptr
) then
10132 -- Other (non-primitive) types
10138 Build_TypeCode_Function
(Loc
, U_Type
, Decl
, Fnam
);
10139 Append_To
(Decls
, Decl
);
10143 if Lib_RE
/= RE_Null
then
10144 Fnam
:= RTE
(Lib_RE
);
10148 -- Call the function
10151 Make_Function_Call
(Loc
, Name
=> New_Occurrence_Of
(Fnam
, Loc
));
10153 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10155 Set_Etype
(Expr
, RTE
(RE_TypeCode
));
10158 end Build_TypeCode_Call
;
10160 -----------------------------
10161 -- Build_TypeCode_Function --
10162 -----------------------------
10164 procedure Build_TypeCode_Function
10167 Decl
: out Node_Id
;
10168 Fnam
: out Entity_Id
)
10171 Decls
: constant List_Id
:= New_List
;
10172 Stms
: constant List_Id
:= New_List
;
10174 TCNam
: constant Entity_Id
:=
10175 Make_Helper_Function_Name
(Loc
, Typ
, Name_TypeCode
);
10177 Parameters
: List_Id
;
10179 procedure Add_String_Parameter
10181 Parameter_List
: List_Id
);
10182 -- Add a literal for S to Parameters
10184 procedure Add_TypeCode_Parameter
10185 (TC_Node
: Node_Id
;
10186 Parameter_List
: List_Id
);
10187 -- Add the typecode for Typ to Parameters
10189 procedure Add_Long_Parameter
10190 (Expr_Node
: Node_Id
;
10191 Parameter_List
: List_Id
);
10192 -- Add a signed long integer expression to Parameters
10194 procedure Initialize_Parameter_List
10195 (Name_String
: String_Id
;
10196 Repo_Id_String
: String_Id
;
10197 Parameter_List
: out List_Id
);
10198 -- Return a list that contains the first two parameters
10199 -- for a parameterized typecode: name and repository id.
10201 function Make_Constructed_TypeCode
10203 Parameters
: List_Id
) return Node_Id
;
10204 -- Call Build_Complex_TC with the given kind and parameters
10206 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
);
10207 -- Make a return statement that calls Build_Complex_TC with the
10208 -- given typecode kind, and the constructed parameters list.
10210 procedure Return_Alias_TypeCode
(Base_TypeCode
: Node_Id
);
10211 -- Return a typecode that is a TC_Alias for the given typecode
10213 --------------------------
10214 -- Add_String_Parameter --
10215 --------------------------
10217 procedure Add_String_Parameter
10219 Parameter_List
: List_Id
)
10222 Append_To
(Parameter_List
,
10223 Make_Function_Call
(Loc
,
10224 Name
=> New_Occurrence_Of
(RTE
(RE_TA_Std_String
), Loc
),
10225 Parameter_Associations
=> New_List
(
10226 Make_String_Literal
(Loc
, S
))));
10227 end Add_String_Parameter
;
10229 ----------------------------
10230 -- Add_TypeCode_Parameter --
10231 ----------------------------
10233 procedure Add_TypeCode_Parameter
10234 (TC_Node
: Node_Id
;
10235 Parameter_List
: List_Id
)
10238 Append_To
(Parameter_List
,
10239 Make_Function_Call
(Loc
,
10240 Name
=> New_Occurrence_Of
(RTE
(RE_TA_TC
), Loc
),
10241 Parameter_Associations
=> New_List
(TC_Node
)));
10242 end Add_TypeCode_Parameter
;
10244 ------------------------
10245 -- Add_Long_Parameter --
10246 ------------------------
10248 procedure Add_Long_Parameter
10249 (Expr_Node
: Node_Id
;
10250 Parameter_List
: List_Id
)
10253 Append_To
(Parameter_List
,
10254 Make_Function_Call
(Loc
,
10256 New_Occurrence_Of
(RTE
(RE_TA_I32
), Loc
),
10257 Parameter_Associations
=> New_List
(Expr_Node
)));
10258 end Add_Long_Parameter
;
10260 -------------------------------
10261 -- Initialize_Parameter_List --
10262 -------------------------------
10264 procedure Initialize_Parameter_List
10265 (Name_String
: String_Id
;
10266 Repo_Id_String
: String_Id
;
10267 Parameter_List
: out List_Id
)
10270 Parameter_List
:= New_List
;
10271 Add_String_Parameter
(Name_String
, Parameter_List
);
10272 Add_String_Parameter
(Repo_Id_String
, Parameter_List
);
10273 end Initialize_Parameter_List
;
10275 ---------------------------
10276 -- Return_Alias_TypeCode --
10277 ---------------------------
10279 procedure Return_Alias_TypeCode
(Base_TypeCode
: Node_Id
) is
10281 Add_TypeCode_Parameter
(Base_TypeCode
, Parameters
);
10282 Return_Constructed_TypeCode
(RTE
(RE_Tk_Alias
));
10283 end Return_Alias_TypeCode
;
10285 -------------------------------
10286 -- Make_Constructed_TypeCode --
10287 -------------------------------
10289 function Make_Constructed_TypeCode
10291 Parameters
: List_Id
) return Node_Id
10293 Constructed_TC
: constant Node_Id
:=
10294 Make_Function_Call
(Loc
,
10296 New_Occurrence_Of
(RTE
(RE_Build_Complex_TC
), Loc
),
10297 Parameter_Associations
=> New_List
(
10298 New_Occurrence_Of
(Kind
, Loc
),
10299 Make_Aggregate
(Loc
,
10300 Expressions
=> Parameters
)));
10302 Set_Etype
(Constructed_TC
, RTE
(RE_TypeCode
));
10303 return Constructed_TC
;
10304 end Make_Constructed_TypeCode
;
10306 ---------------------------------
10307 -- Return_Constructed_TypeCode --
10308 ---------------------------------
10310 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
) is
10313 Make_Simple_Return_Statement
(Loc
,
10315 Make_Constructed_TypeCode
(Kind
, Parameters
)));
10316 end Return_Constructed_TypeCode
;
10322 procedure TC_Rec_Add_Process_Element
10325 Counter
: in out Int
;
10329 procedure TC_Append_Record_Traversal
is
10330 new Append_Record_Traversal
(
10332 Add_Process_Element
=> TC_Rec_Add_Process_Element
);
10334 --------------------------------
10335 -- TC_Rec_Add_Process_Element --
10336 --------------------------------
10338 procedure TC_Rec_Add_Process_Element
10341 Counter
: in out Int
;
10345 pragma Unreferenced
(Any
, Counter
, Rec
);
10348 if Nkind
(Field
) = N_Defining_Identifier
then
10350 -- A regular component
10352 Add_TypeCode_Parameter
10353 (Build_TypeCode_Call
(Loc
, Etype
(Field
), Decls
), Params
);
10354 Get_Name_String
(Chars
(Field
));
10355 Add_String_Parameter
(String_From_Name_Buffer
, Params
);
10361 Variant_Part
: declare
10362 Disc_Type
: constant Entity_Id
:= Etype
(Name
(Field
));
10364 Is_Enum
: constant Boolean :=
10365 Is_Enumeration_Type
(Disc_Type
);
10367 Union_TC_Params
: List_Id
;
10369 U_Name
: constant Name_Id
:=
10370 New_External_Name
(Chars
(Typ
), 'V', -1);
10372 Name_Str
: String_Id
;
10373 Struct_TC_Params
: List_Id
;
10377 Default
: constant Node_Id
:=
10378 Make_Integer_Literal
(Loc
, -1);
10380 Dummy_Counter
: Int
:= 0;
10382 Choice_Index
: Int
:= 0;
10383 -- Index of current choice in TypeCode, used to identify
10384 -- it as the default choice if it is a "when others".
10386 procedure Add_Params_For_Variant_Components
;
10387 -- Add a struct TypeCode and a corresponding member name
10388 -- to the union parameter list.
10390 -- Ordering of declarations is a complete mess in this
10391 -- area, it is supposed to be types/variables, then
10392 -- subprogram specs, then subprogram bodies ???
10394 ---------------------------------------
10395 -- Add_Params_For_Variant_Components --
10396 ---------------------------------------
10398 procedure Add_Params_For_Variant_Components
is
10399 S_Name
: constant Name_Id
:=
10400 New_External_Name
(U_Name
, 'S', -1);
10403 Get_Name_String
(S_Name
);
10404 Name_Str
:= String_From_Name_Buffer
;
10405 Initialize_Parameter_List
10406 (Name_Str
, Name_Str
, Struct_TC_Params
);
10408 -- Build struct parameters
10410 TC_Append_Record_Traversal
(Struct_TC_Params
,
10411 Component_List
(Variant
),
10415 Add_TypeCode_Parameter
10416 (Make_Constructed_TypeCode
10417 (RTE
(RE_Tk_Struct
), Struct_TC_Params
),
10420 Add_String_Parameter
(Name_Str
, Union_TC_Params
);
10421 end Add_Params_For_Variant_Components
;
10423 -- Start of processing for Variant_Part
10426 Get_Name_String
(U_Name
);
10427 Name_Str
:= String_From_Name_Buffer
;
10429 Initialize_Parameter_List
10430 (Name_Str
, Name_Str
, Union_TC_Params
);
10432 -- Add union in enclosing parameter list
10434 Add_TypeCode_Parameter
10435 (Make_Constructed_TypeCode
10436 (RTE
(RE_Tk_Union
), Union_TC_Params
),
10439 Add_String_Parameter
(Name_Str
, Params
);
10441 -- Build union parameters
10443 Add_TypeCode_Parameter
10444 (Build_TypeCode_Call
(Loc
, Disc_Type
, Decls
),
10447 Add_Long_Parameter
(Default
, Union_TC_Params
);
10449 Variant
:= First_Non_Pragma
(Variants
(Field
));
10450 while Present
(Variant
) loop
10451 Choice
:= First
(Discrete_Choices
(Variant
));
10452 while Present
(Choice
) loop
10453 case Nkind
(Choice
) is
10456 L
: constant Uint
:=
10457 Expr_Value
(Low_Bound
(Choice
));
10458 H
: constant Uint
:=
10459 Expr_Value
(High_Bound
(Choice
));
10461 -- 3.8.1(8) guarantees that the bounds of
10462 -- this range are static.
10469 Expr
:= Get_Enum_Lit_From_Pos
10470 (Disc_Type
, J
, Loc
);
10473 Make_Integer_Literal
(Loc
, J
);
10476 Set_Etype
(Expr
, Disc_Type
);
10477 Append_To
(Union_TC_Params
,
10478 Build_To_Any_Call
(Loc
, Expr
, Decls
));
10480 Add_Params_For_Variant_Components
;
10485 Choice_Index
+ UI_To_Int
(H
- L
) + 1;
10488 when N_Others_Choice
=>
10490 -- This variant has a default choice. We must
10491 -- therefore set the default parameter to the
10492 -- current choice index. This parameter is by
10493 -- construction the 4th in Union_TC_Params.
10496 (Pick
(Union_TC_Params
, 4),
10497 Make_Function_Call
(Loc
,
10500 (RTE
(RE_TA_I32
), Loc
),
10501 Parameter_Associations
=>
10503 Make_Integer_Literal
(Loc
,
10504 Intval
=> Choice_Index
))));
10506 -- Add a placeholder member label for the
10507 -- default case, which must have the
10508 -- discriminant type.
10511 Exp
: constant Node_Id
:=
10512 Make_Attribute_Reference
(Loc
,
10513 Prefix
=> New_Occurrence_Of
10515 Attribute_Name
=> Name_First
);
10517 Set_Etype
(Exp
, Disc_Type
);
10518 Append_To
(Union_TC_Params
,
10519 Build_To_Any_Call
(Loc
, Exp
, Decls
));
10522 Add_Params_For_Variant_Components
;
10523 Choice_Index
:= Choice_Index
+ 1;
10525 -- Case of an explicit choice
10529 Exp
: constant Node_Id
:=
10530 New_Copy_Tree
(Choice
);
10532 Append_To
(Union_TC_Params
,
10533 Build_To_Any_Call
(Loc
, Exp
, Decls
));
10536 Add_Params_For_Variant_Components
;
10537 Choice_Index
:= Choice_Index
+ 1;
10543 Next_Non_Pragma
(Variant
);
10547 end TC_Rec_Add_Process_Element
;
10549 Type_Name_Str
: String_Id
;
10550 Type_Repo_Id_Str
: String_Id
;
10552 -- Start of processing for Build_TypeCode_Function
10555 -- For a derived type, we can't go past the base type (to the
10556 -- parent type) here, because that would cause the attribute's
10557 -- formal parameter to have the wrong type; hence the Base_Type
10560 if Is_Itype
(Typ
) and then Typ
/= Base_Type
(Typ
) then
10561 Build_TypeCode_Function
10563 Typ
=> Etype
(Typ
),
10572 Make_Function_Specification
(Loc
,
10573 Defining_Unit_Name
=> Fnam
,
10574 Parameter_Specifications
=> Empty_List
,
10575 Result_Definition
=>
10576 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
10578 Build_Name_And_Repository_Id
(Typ
,
10579 Name_Str
=> Type_Name_Str
, Repo_Id_Str
=> Type_Repo_Id_Str
);
10581 Initialize_Parameter_List
10582 (Type_Name_Str
, Type_Repo_Id_Str
, Parameters
);
10584 if Has_Stream_Attribute_Definition
10585 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
10587 Has_Stream_Attribute_Definition
10588 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
10590 -- If user-defined stream attributes are specified for this
10591 -- type, use them and transmit data as an opaque sequence of
10592 -- stream elements.
10594 Return_Alias_TypeCode
10595 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10597 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
10598 Return_Alias_TypeCode
(
10599 Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10601 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
10602 Return_Alias_TypeCode
(
10603 Build_TypeCode_Call
(Loc
,
10604 Find_Numeric_Representation
(Typ
), Decls
));
10606 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
10608 -- Record typecodes are encoded as follows:
10612 -- | [Repository Id]
10614 -- Then for each discriminant:
10616 -- | [Discriminant Type Code]
10617 -- | [Discriminant Name]
10620 -- Then for each component:
10622 -- | [Component Type Code]
10623 -- | [Component Name]
10626 -- Variants components type codes are encoded as follows:
10630 -- | [Repository Id]
10631 -- | [Discriminant Type Code]
10632 -- | [Index of Default Variant Part or -1 for no default]
10634 -- Then for each Variant Part :
10639 -- | | [Variant Part Name]
10640 -- | | [Variant Part Repository Id]
10642 -- | Then for each VP component:
10643 -- | | [VP component Typecode]
10644 -- | | [VP component Name]
10650 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
10651 Return_Alias_TypeCode
10652 (Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10656 Disc
: Entity_Id
:= Empty
;
10657 Rdef
: constant Node_Id
:=
10658 Type_Definition
(Declaration_Node
(Typ
));
10659 Dummy_Counter
: Int
:= 0;
10662 -- Construct the discriminants typecodes
10664 if Has_Discriminants
(Typ
) then
10665 Disc
:= First_Discriminant
(Typ
);
10668 while Present
(Disc
) loop
10669 Add_TypeCode_Parameter
(
10670 Build_TypeCode_Call
(Loc
, Etype
(Disc
), Decls
),
10672 Get_Name_String
(Chars
(Disc
));
10673 Add_String_Parameter
(
10674 String_From_Name_Buffer
,
10676 Next_Discriminant
(Disc
);
10679 -- then the components typecodes
10681 TC_Append_Record_Traversal
10682 (Parameters
, Component_List
(Rdef
),
10683 Empty
, Dummy_Counter
);
10684 Return_Constructed_TypeCode
(RTE
(RE_Tk_Struct
));
10688 elsif Is_Array_Type
(Typ
) then
10690 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10691 Inner_TypeCode
: Node_Id
;
10692 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10693 Indx
: Node_Id
:= First_Index
(Typ
);
10697 Build_TypeCode_Call
(Loc
, Component_Type
(Typ
), Decls
);
10699 for J
in 1 .. Ndim
loop
10700 if Constrained
then
10701 Inner_TypeCode
:= Make_Constructed_TypeCode
10702 (RTE
(RE_Tk_Array
), New_List
(
10703 Build_To_Any_Call
(Loc
,
10704 OK_Convert_To
(RTE
(RE_Unsigned_32
),
10705 Make_Attribute_Reference
(Loc
,
10706 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
10707 Attribute_Name
=> Name_Length
,
10708 Expressions
=> New_List
(
10709 Make_Integer_Literal
(Loc
,
10710 Intval
=> Ndim
- J
+ 1)))),
10712 Build_To_Any_Call
(Loc
, Inner_TypeCode
, Decls
)));
10715 -- Unconstrained case: add low bound for each
10718 Add_TypeCode_Parameter
10719 (Build_TypeCode_Call
(Loc
, Etype
(Indx
), Decls
),
10721 Get_Name_String
(New_External_Name
('L', J
));
10722 Add_String_Parameter
(
10723 String_From_Name_Buffer
,
10727 Inner_TypeCode
:= Make_Constructed_TypeCode
10728 (RTE
(RE_Tk_Sequence
), New_List
(
10729 Build_To_Any_Call
(Loc
,
10730 OK_Convert_To
(RTE
(RE_Unsigned_32
),
10731 Make_Integer_Literal
(Loc
, 0)),
10733 Build_To_Any_Call
(Loc
, Inner_TypeCode
, Decls
)));
10737 if Constrained
then
10738 Return_Alias_TypeCode
(Inner_TypeCode
);
10740 Add_TypeCode_Parameter
(Inner_TypeCode
, Parameters
);
10742 Store_String_Char
('V');
10743 Add_String_Parameter
(End_String
, Parameters
);
10744 Return_Constructed_TypeCode
(RTE
(RE_Tk_Struct
));
10749 -- Default: type is represented as an opaque sequence of bytes
10751 Return_Alias_TypeCode
10752 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10756 Make_Subprogram_Body
(Loc
,
10757 Specification
=> Spec
,
10758 Declarations
=> Decls
,
10759 Handled_Statement_Sequence
=>
10760 Make_Handled_Sequence_Of_Statements
(Loc
,
10761 Statements
=> Stms
));
10762 end Build_TypeCode_Function
;
10764 ---------------------------------
10765 -- Find_Numeric_Representation --
10766 ---------------------------------
10768 function Find_Numeric_Representation
10769 (Typ
: Entity_Id
) return Entity_Id
10771 FST
: constant Entity_Id
:= First_Subtype
(Typ
);
10772 P_Size
: constant Uint
:= Esize
(FST
);
10775 -- Special case: for Stream_Element_Offset and Storage_Offset,
10776 -- always force transmission as a 64-bit value.
10778 if Is_RTE
(FST
, RE_Stream_Element_Offset
)
10780 Is_RTE
(FST
, RE_Storage_Offset
)
10782 return RTE
(RE_Unsigned_64
);
10785 if Is_Unsigned_Type
(Typ
) then
10786 if P_Size
<= 8 then
10787 return RTE
(RE_Unsigned_8
);
10789 elsif P_Size
<= 16 then
10790 return RTE
(RE_Unsigned_16
);
10792 elsif P_Size
<= 32 then
10793 return RTE
(RE_Unsigned_32
);
10796 return RTE
(RE_Unsigned_64
);
10799 elsif Is_Integer_Type
(Typ
) then
10800 if P_Size
<= 8 then
10801 return RTE
(RE_Integer_8
);
10803 elsif P_Size
<= Standard_Short_Integer_Size
then
10804 return RTE
(RE_Integer_16
);
10806 elsif P_Size
<= Standard_Integer_Size
then
10807 return RTE
(RE_Integer_32
);
10810 return RTE
(RE_Integer_64
);
10813 elsif Is_Floating_Point_Type
(Typ
) then
10814 if P_Size
<= Standard_Short_Float_Size
then
10815 return Standard_Short_Float
;
10817 elsif P_Size
<= Standard_Float_Size
then
10818 return Standard_Float
;
10820 elsif P_Size
<= Standard_Long_Float_Size
then
10821 return Standard_Long_Float
;
10824 return Standard_Long_Long_Float
;
10828 raise Program_Error
;
10831 -- TBD: fixed point types???
10832 -- TBverified numeric types with a biased representation???
10834 end Find_Numeric_Representation
;
10836 ---------------------------
10837 -- Append_Array_Traversal --
10838 ---------------------------
10840 procedure Append_Array_Traversal
10843 Counter
: Entity_Id
:= Empty
;
10846 Loc
: constant Source_Ptr
:= Sloc
(Subprogram
);
10847 Typ
: constant Entity_Id
:= Etype
(Arry
);
10848 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10849 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10851 Inner_Any
, Inner_Counter
: Entity_Id
;
10853 Loop_Stm
: Node_Id
;
10854 Inner_Stmts
: constant List_Id
:= New_List
;
10857 if Depth
> Ndim
then
10859 -- Processing for one element of an array
10862 Element_Expr
: constant Node_Id
:=
10863 Make_Indexed_Component
(Loc
,
10864 New_Occurrence_Of
(Arry
, Loc
),
10867 Set_Etype
(Element_Expr
, Component_Type
(Typ
));
10868 Add_Process_Element
(Stmts
,
10870 Counter
=> Counter
,
10871 Datum
=> Element_Expr
);
10877 Append_To
(Indexes
,
10878 Make_Identifier
(Loc
, New_External_Name
('L', Depth
)));
10880 if not Constrained
or else Depth
> 1 then
10881 Inner_Any
:= Make_Defining_Identifier
(Loc
,
10882 New_External_Name
('A', Depth
));
10883 Set_Etype
(Inner_Any
, RTE
(RE_Any
));
10885 Inner_Any
:= Empty
;
10888 if Present
(Counter
) then
10889 Inner_Counter
:= Make_Defining_Identifier
(Loc
,
10890 New_External_Name
('J', Depth
));
10892 Inner_Counter
:= Empty
;
10896 Loop_Any
: Node_Id
:= Inner_Any
;
10899 -- For the first dimension of a constrained array, we add
10900 -- elements directly in the corresponding Any; there is no
10901 -- intervening inner Any.
10903 if No
(Loop_Any
) then
10907 Append_Array_Traversal
(Inner_Stmts
,
10909 Counter
=> Inner_Counter
,
10910 Depth
=> Depth
+ 1);
10914 Make_Implicit_Loop_Statement
(Subprogram
,
10915 Iteration_Scheme
=>
10916 Make_Iteration_Scheme
(Loc
,
10917 Loop_Parameter_Specification
=>
10918 Make_Loop_Parameter_Specification
(Loc
,
10919 Defining_Identifier
=>
10920 Make_Defining_Identifier
(Loc
,
10921 Chars
=> New_External_Name
('L', Depth
)),
10923 Discrete_Subtype_Definition
=>
10924 Make_Attribute_Reference
(Loc
,
10925 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10926 Attribute_Name
=> Name_Range
,
10928 Expressions
=> New_List
(
10929 Make_Integer_Literal
(Loc
, Depth
))))),
10930 Statements
=> Inner_Stmts
);
10933 Decls
: constant List_Id
:= New_List
;
10934 Dimen_Stmts
: constant List_Id
:= New_List
;
10935 Length_Node
: Node_Id
;
10937 Inner_Any_TypeCode
: constant Entity_Id
:=
10938 Make_Defining_Identifier
(Loc
,
10939 New_External_Name
('T', Depth
));
10941 Inner_Any_TypeCode_Expr
: Node_Id
;
10945 if Constrained
then
10946 Inner_Any_TypeCode_Expr
:=
10947 Make_Function_Call
(Loc
,
10948 Name
=> New_Occurrence_Of
(RTE
(RE_Get_TC
), Loc
),
10949 Parameter_Associations
=> New_List
(
10950 New_Occurrence_Of
(Any
, Loc
)));
10953 Inner_Any_TypeCode_Expr
:=
10954 Make_Function_Call
(Loc
,
10956 New_Occurrence_Of
(RTE
(RE_Any_Member_Type
), Loc
),
10957 Parameter_Associations
=> New_List
(
10958 New_Occurrence_Of
(Any
, Loc
),
10959 Make_Integer_Literal
(Loc
, Ndim
)));
10963 Inner_Any_TypeCode_Expr
:=
10964 Make_Function_Call
(Loc
,
10965 Name
=> New_Occurrence_Of
(RTE
(RE_Content_Type
), Loc
),
10966 Parameter_Associations
=> New_List
(
10967 Make_Identifier
(Loc
,
10968 Chars
=> New_External_Name
('T', Depth
- 1))));
10972 Make_Object_Declaration
(Loc
,
10973 Defining_Identifier
=> Inner_Any_TypeCode
,
10974 Constant_Present
=> True,
10975 Object_Definition
=> New_Occurrence_Of
(
10976 RTE
(RE_TypeCode
), Loc
),
10977 Expression
=> Inner_Any_TypeCode_Expr
));
10979 if Present
(Inner_Any
) then
10981 Make_Object_Declaration
(Loc
,
10982 Defining_Identifier
=> Inner_Any
,
10983 Object_Definition
=>
10984 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
10986 Make_Function_Call
(Loc
,
10988 New_Occurrence_Of
(
10989 RTE
(RE_Create_Any
), Loc
),
10990 Parameter_Associations
=> New_List
(
10991 New_Occurrence_Of
(Inner_Any_TypeCode
, Loc
)))));
10994 if Present
(Inner_Counter
) then
10996 Make_Object_Declaration
(Loc
,
10997 Defining_Identifier
=> Inner_Counter
,
10998 Object_Definition
=>
10999 New_Occurrence_Of
(RTE
(RE_Unsigned_32
), Loc
),
11001 Make_Integer_Literal
(Loc
, 0)));
11004 if not Constrained
then
11005 Length_Node
:= Make_Attribute_Reference
(Loc
,
11006 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
11007 Attribute_Name
=> Name_Length
,
11009 New_List
(Make_Integer_Literal
(Loc
, Depth
)));
11010 Set_Etype
(Length_Node
, RTE
(RE_Unsigned_32
));
11012 Add_Process_Element
(Dimen_Stmts
,
11013 Datum
=> Length_Node
,
11015 Counter
=> Inner_Counter
);
11018 -- Loop_Stm does appropriate processing for each element
11021 Append_To
(Dimen_Stmts
, Loop_Stm
);
11023 -- Link outer and inner any
11025 if Present
(Inner_Any
) then
11026 Add_Process_Element
(Dimen_Stmts
,
11028 Counter
=> Counter
,
11029 Datum
=> New_Occurrence_Of
(Inner_Any
, Loc
));
11033 Make_Block_Statement
(Loc
,
11036 Handled_Statement_Sequence
=>
11037 Make_Handled_Sequence_Of_Statements
(Loc
,
11038 Statements
=> Dimen_Stmts
)));
11040 end Append_Array_Traversal
;
11042 -------------------------------
11043 -- Make_Helper_Function_Name --
11044 -------------------------------
11046 function Make_Helper_Function_Name
11049 Nam
: Name_Id
) return Entity_Id
11054 -- For tagged types that aren't frozen yet, generate the helper
11055 -- under its canonical name so that it matches the primitive
11056 -- spec. For all other cases, we use a serialized name so that
11057 -- multiple generations of the same procedure do not clash.
11060 if Is_Tagged_Type
(Typ
) and then not Is_Frozen
(Typ
) then
11063 Serial
:= Increment_Serial_Number
;
11066 -- Use prefixed underscore to avoid potential clash with user
11067 -- identifier (we use attribute names for Nam).
11070 Make_Defining_Identifier
(Loc
,
11073 (Related_Id
=> Nam
,
11075 Suffix_Index
=> Serial
,
11078 end Make_Helper_Function_Name
;
11081 -----------------------------------
11082 -- Reserve_NamingContext_Methods --
11083 -----------------------------------
11085 procedure Reserve_NamingContext_Methods
is
11086 Str_Resolve
: constant String := "resolve";
11088 Name_Buffer
(1 .. Str_Resolve
'Length) := Str_Resolve
;
11089 Name_Len
:= Str_Resolve
'Length;
11090 Overload_Counter_Table
.Set
(Name_Find
, 1);
11091 end Reserve_NamingContext_Methods
;
11093 -----------------------
11094 -- RPC_Receiver_Decl --
11095 -----------------------
11097 function RPC_Receiver_Decl
(RACW_Type
: Entity_Id
) return Node_Id
is
11098 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
11101 Make_Object_Declaration
(Loc
,
11102 Defining_Identifier
=> Make_Temporary
(Loc
, 'R'),
11103 Aliased_Present
=> True,
11104 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
11105 end RPC_Receiver_Decl
;
11107 end PolyORB_Support
;
11109 -------------------------------
11110 -- RACW_Type_Is_Asynchronous --
11111 -------------------------------
11113 procedure RACW_Type_Is_Asynchronous
(RACW_Type
: Entity_Id
) is
11114 Asynchronous_Flag
: constant Entity_Id
:=
11115 Asynchronous_Flags_Table
.Get
(RACW_Type
);
11117 Replace
(Expression
(Parent
(Asynchronous_Flag
)),
11118 New_Occurrence_Of
(Standard_True
, Sloc
(Asynchronous_Flag
)));
11119 end RACW_Type_Is_Asynchronous
;
11121 -------------------------
11122 -- RCI_Package_Locator --
11123 -------------------------
11125 function RCI_Package_Locator
11127 Package_Spec
: Node_Id
) return Node_Id
11130 Pkg_Name
: constant String_Id
:=
11131 Fully_Qualified_Name_String
11132 (Defining_Entity
(Package_Spec
), Append_NUL
=> False);
11136 Make_Package_Instantiation
(Loc
,
11137 Defining_Unit_Name
=> Make_Temporary
(Loc
, 'R'),
11140 New_Occurrence_Of
(RTE
(RE_RCI_Locator
), Loc
),
11142 Generic_Associations
=> New_List
(
11143 Make_Generic_Association
(Loc
,
11145 Make_Identifier
(Loc
, Name_RCI_Name
),
11146 Explicit_Generic_Actual_Parameter
=>
11147 Make_String_Literal
(Loc
,
11148 Strval
=> Pkg_Name
)),
11150 Make_Generic_Association
(Loc
,
11152 Make_Identifier
(Loc
, Name_Version
),
11153 Explicit_Generic_Actual_Parameter
=>
11154 Make_Attribute_Reference
(Loc
,
11156 New_Occurrence_Of
(Defining_Entity
(Package_Spec
), Loc
),
11160 RCI_Locator_Table
.Set
11161 (Defining_Unit_Name
(Package_Spec
),
11162 Defining_Unit_Name
(Inst
));
11164 end RCI_Package_Locator
;
11166 -----------------------------------------------
11167 -- Remote_Types_Tagged_Full_View_Encountered --
11168 -----------------------------------------------
11170 procedure Remote_Types_Tagged_Full_View_Encountered
11171 (Full_View
: Entity_Id
)
11173 Stub_Elements
: constant Stub_Structure
:=
11174 Stubs_Table
.Get
(Full_View
);
11177 -- For an RACW encountered before the freeze point of its designated
11178 -- type, the stub type is generated at the point of the RACW declaration
11179 -- but the primitives are generated only once the designated type is
11180 -- frozen. That freeze can occur in another scope, for example when the
11181 -- RACW is declared in a nested package. In that case we need to
11182 -- reestablish the stub type's scope prior to generating its primitive
11185 if Stub_Elements
/= Empty_Stub_Structure
then
11187 Saved_Scope
: constant Entity_Id
:= Current_Scope
;
11188 Stubs_Scope
: constant Entity_Id
:=
11189 Scope
(Stub_Elements
.Stub_Type
);
11192 if Current_Scope
/= Stubs_Scope
then
11193 Push_Scope
(Stubs_Scope
);
11196 Add_RACW_Primitive_Declarations_And_Bodies
11198 Stub_Elements
.RPC_Receiver_Decl
,
11199 Stub_Elements
.Body_Decls
);
11201 if Current_Scope
/= Saved_Scope
then
11206 end Remote_Types_Tagged_Full_View_Encountered
;
11208 -------------------
11209 -- Scope_Of_Spec --
11210 -------------------
11212 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
is
11213 Unit_Name
: Node_Id
;
11216 Unit_Name
:= Defining_Unit_Name
(Spec
);
11217 while Nkind
(Unit_Name
) /= N_Defining_Identifier
loop
11218 Unit_Name
:= Defining_Identifier
(Unit_Name
);
11224 ----------------------
11225 -- Set_Renaming_TSS --
11226 ----------------------
11228 procedure Set_Renaming_TSS
11231 TSS_Nam
: TSS_Name_Type
)
11233 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
11234 Spec
: constant Node_Id
:= Parent
(Nam
);
11236 TSS_Node
: constant Node_Id
:=
11237 Make_Subprogram_Renaming_Declaration
(Loc
,
11239 Copy_Specification
(Loc
,
11241 New_Name
=> Make_TSS_Name
(Typ
, TSS_Nam
)),
11242 Name
=> New_Occurrence_Of
(Nam
, Loc
));
11244 Snam
: constant Entity_Id
:=
11245 Defining_Unit_Name
(Specification
(TSS_Node
));
11248 if Nkind
(Spec
) = N_Function_Specification
then
11249 Set_Ekind
(Snam
, E_Function
);
11250 Set_Etype
(Snam
, Entity
(Result_Definition
(Spec
)));
11252 Set_Ekind
(Snam
, E_Procedure
);
11253 Set_Etype
(Snam
, Standard_Void_Type
);
11256 Set_TSS
(Typ
, Snam
);
11257 end Set_Renaming_TSS
;
11259 ----------------------------------------------
11260 -- Specific_Add_Obj_RPC_Receiver_Completion --
11261 ----------------------------------------------
11263 procedure Specific_Add_Obj_RPC_Receiver_Completion
11266 RPC_Receiver
: Entity_Id
;
11267 Stub_Elements
: Stub_Structure
)
11270 case Get_PCS_Name
is
11271 when Name_PolyORB_DSA
=>
11272 PolyORB_Support
.Add_Obj_RPC_Receiver_Completion
11273 (Loc
, Decls
, RPC_Receiver
, Stub_Elements
);
11275 GARLIC_Support
.Add_Obj_RPC_Receiver_Completion
11276 (Loc
, Decls
, RPC_Receiver
, Stub_Elements
);
11278 end Specific_Add_Obj_RPC_Receiver_Completion
;
11280 --------------------------------
11281 -- Specific_Add_RACW_Features --
11282 --------------------------------
11284 procedure Specific_Add_RACW_Features
11285 (RACW_Type
: Entity_Id
;
11287 Stub_Type
: Entity_Id
;
11288 Stub_Type_Access
: Entity_Id
;
11289 RPC_Receiver_Decl
: Node_Id
;
11290 Body_Decls
: List_Id
)
11293 case Get_PCS_Name
is
11294 when Name_PolyORB_DSA
=>
11295 PolyORB_Support
.Add_RACW_Features
11304 GARLIC_Support
.Add_RACW_Features
11311 end Specific_Add_RACW_Features
;
11313 --------------------------------
11314 -- Specific_Add_RAST_Features --
11315 --------------------------------
11317 procedure Specific_Add_RAST_Features
11318 (Vis_Decl
: Node_Id
;
11319 RAS_Type
: Entity_Id
)
11322 case Get_PCS_Name
is
11323 when Name_PolyORB_DSA
=>
11324 PolyORB_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
11326 GARLIC_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
11328 end Specific_Add_RAST_Features
;
11330 --------------------------------------------------
11331 -- Specific_Add_Receiving_Stubs_To_Declarations --
11332 --------------------------------------------------
11334 procedure Specific_Add_Receiving_Stubs_To_Declarations
11335 (Pkg_Spec
: Node_Id
;
11340 case Get_PCS_Name
is
11341 when Name_PolyORB_DSA
=>
11342 PolyORB_Support
.Add_Receiving_Stubs_To_Declarations
11343 (Pkg_Spec
, Decls
, Stmts
);
11345 GARLIC_Support
.Add_Receiving_Stubs_To_Declarations
11346 (Pkg_Spec
, Decls
, Stmts
);
11348 end Specific_Add_Receiving_Stubs_To_Declarations
;
11350 ------------------------------------------
11351 -- Specific_Build_General_Calling_Stubs --
11352 ------------------------------------------
11354 procedure Specific_Build_General_Calling_Stubs
11356 Statements
: List_Id
;
11357 Target
: RPC_Target
;
11358 Subprogram_Id
: Node_Id
;
11359 Asynchronous
: Node_Id
:= Empty
;
11360 Is_Known_Asynchronous
: Boolean := False;
11361 Is_Known_Non_Asynchronous
: Boolean := False;
11362 Is_Function
: Boolean;
11364 Stub_Type
: Entity_Id
:= Empty
;
11365 RACW_Type
: Entity_Id
:= Empty
;
11369 case Get_PCS_Name
is
11370 when Name_PolyORB_DSA
=>
11371 PolyORB_Support
.Build_General_Calling_Stubs
11377 Is_Known_Asynchronous
,
11378 Is_Known_Non_Asynchronous
,
11386 GARLIC_Support
.Build_General_Calling_Stubs
11390 Target
.RPC_Receiver
,
11393 Is_Known_Asynchronous
,
11394 Is_Known_Non_Asynchronous
,
11401 end Specific_Build_General_Calling_Stubs
;
11403 --------------------------------------
11404 -- Specific_Build_RPC_Receiver_Body --
11405 --------------------------------------
11407 procedure Specific_Build_RPC_Receiver_Body
11408 (RPC_Receiver
: Entity_Id
;
11409 Request
: out Entity_Id
;
11410 Subp_Id
: out Entity_Id
;
11411 Subp_Index
: out Entity_Id
;
11412 Stmts
: out List_Id
;
11413 Decl
: out Node_Id
)
11416 case Get_PCS_Name
is
11417 when Name_PolyORB_DSA
=>
11418 PolyORB_Support
.Build_RPC_Receiver_Body
11427 GARLIC_Support
.Build_RPC_Receiver_Body
11435 end Specific_Build_RPC_Receiver_Body
;
11437 --------------------------------
11438 -- Specific_Build_Stub_Target --
11439 --------------------------------
11441 function Specific_Build_Stub_Target
11444 RCI_Locator
: Entity_Id
;
11445 Controlling_Parameter
: Entity_Id
) return RPC_Target
11448 case Get_PCS_Name
is
11449 when Name_PolyORB_DSA
=>
11451 PolyORB_Support
.Build_Stub_Target
11452 (Loc
, Decls
, RCI_Locator
, Controlling_Parameter
);
11456 GARLIC_Support
.Build_Stub_Target
11457 (Loc
, Decls
, RCI_Locator
, Controlling_Parameter
);
11459 end Specific_Build_Stub_Target
;
11461 --------------------------------
11462 -- Specific_RPC_Receiver_Decl --
11463 --------------------------------
11465 function Specific_RPC_Receiver_Decl
11466 (RACW_Type
: Entity_Id
) return Node_Id
11469 case Get_PCS_Name
is
11470 when Name_PolyORB_DSA
=>
11471 return PolyORB_Support
.RPC_Receiver_Decl
(RACW_Type
);
11474 return GARLIC_Support
.RPC_Receiver_Decl
(RACW_Type
);
11476 end Specific_RPC_Receiver_Decl
;
11478 -----------------------------------------------
11479 -- Specific_Build_Subprogram_Receiving_Stubs --
11480 -----------------------------------------------
11482 function Specific_Build_Subprogram_Receiving_Stubs
11483 (Vis_Decl
: Node_Id
;
11484 Asynchronous
: Boolean;
11485 Dynamically_Asynchronous
: Boolean := False;
11486 Stub_Type
: Entity_Id
:= Empty
;
11487 RACW_Type
: Entity_Id
:= Empty
;
11488 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
11491 case Get_PCS_Name
is
11492 when Name_PolyORB_DSA
=>
11494 PolyORB_Support
.Build_Subprogram_Receiving_Stubs
11497 Dynamically_Asynchronous
,
11504 GARLIC_Support
.Build_Subprogram_Receiving_Stubs
11507 Dynamically_Asynchronous
,
11512 end Specific_Build_Subprogram_Receiving_Stubs
;
11514 -------------------------------
11515 -- Transmit_As_Unconstrained --
11516 -------------------------------
11518 function Transmit_As_Unconstrained
(Typ
: Entity_Id
) return Boolean is
11521 not (Is_Elementary_Type
(Typ
) or else Is_Constrained
(Typ
))
11522 or else (Is_Access_Type
(Typ
) and then Can_Never_Be_Null
(Typ
));
11523 end Transmit_As_Unconstrained
;
11525 --------------------------
11526 -- Underlying_RACW_Type --
11527 --------------------------
11529 function Underlying_RACW_Type
(RAS_Typ
: Entity_Id
) return Entity_Id
is
11530 Record_Type
: Entity_Id
;
11533 if Ekind
(RAS_Typ
) = E_Record_Type
then
11534 Record_Type
:= RAS_Typ
;
11536 pragma Assert
(Present
(Equivalent_Type
(RAS_Typ
)));
11537 Record_Type
:= Equivalent_Type
(RAS_Typ
);
11541 Etype
(Subtype_Indication
11542 (Component_Definition
11543 (First
(Component_Items
11546 (Declaration_Node
(Record_Type
))))))));
11547 end Underlying_RACW_Type
;