1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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_Strm
; use Exp_Strm
;
31 with Exp_Tss
; use Exp_Tss
;
32 with Exp_Util
; use Exp_Util
;
34 with Nlists
; use Nlists
;
35 with Nmake
; use Nmake
;
37 with Rtsfind
; use Rtsfind
;
39 with Sem_Aux
; use Sem_Aux
;
40 with Sem_Cat
; use Sem_Cat
;
41 with Sem_Ch3
; use Sem_Ch3
;
42 with Sem_Ch8
; use Sem_Ch8
;
43 with Sem_Dist
; use Sem_Dist
;
44 with Sem_Eval
; use Sem_Eval
;
45 with Sem_Util
; use Sem_Util
;
46 with Sinfo
; use Sinfo
;
47 with Stand
; use Stand
;
48 with Stringt
; use Stringt
;
49 with Tbuild
; use Tbuild
;
50 with Ttypes
; use Ttypes
;
51 with Uintp
; use Uintp
;
53 with GNAT
.HTable
; use GNAT
.HTable
;
55 package body Exp_Dist
is
57 -- The following model has been used to implement distributed objects:
58 -- given a designated type D and a RACW type R, then a record of the
61 -- type Stub is tagged record
62 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
65 -- is built. This type has two properties:
67 -- 1) Since it has the same structure than RACW_Stub_Type, it can be
68 -- converted to and from this type to make it suitable for
69 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
70 -- to avoid memory leaks when the same remote object arrive on the
71 -- same partition through several paths;
73 -- 2) It also has the same dispatching table as the designated type D,
74 -- and thus can be used as an object designated by a value of type
75 -- R on any partition other than the one on which the object has
76 -- been created, since only dispatching calls will be performed and
77 -- the fields themselves will not be used. We call Derive_Subprograms
78 -- to fake half a derivation to ensure that the subprograms do have
79 -- the same dispatching table.
81 First_RCI_Subprogram_Id
: constant := 2;
82 -- RCI subprograms are numbered starting at 2. The RCI receiver for
83 -- an RCI package can thus identify calls received through remote
84 -- access-to-subprogram dereferences by the fact that they have a
85 -- (primitive) subprogram id of 0, and 1 is used for the internal
86 -- RAS information lookup operation. (This is for the Garlic code
87 -- generation, where subprograms are identified by numbers; in the
88 -- PolyORB version, they are identified by name, with a numeric suffix
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
99 -- a hash 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 names. These counters
104 -- are 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
119 -- subprogram identifiers.
121 package Overload_Counter_Table
is
122 new Simple_HTable
(Header_Num
=> Hash_Index
,
128 -- Mapping between a subprogram name and an integer that
129 -- counts the number of defining subprogram names with that
130 -- Name_Id encountered so far in a 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
175 -- subprogram proxy type.
176 -- ACR_Expression is use as the initialization value for
177 -- the All_Calls_Remote component.
179 function Build_Get_Unique_RP_Call
182 Stub_Type
: Entity_Id
) return List_Id
;
183 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
184 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
185 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
187 function Build_Stub_Tag
189 RACW_Type
: Entity_Id
) return Node_Id
;
190 -- Return an expression denoting the tag of the stub type associated with
193 function Build_Subprogram_Calling_Stubs
196 Asynchronous
: Boolean;
197 Dynamically_Asynchronous
: Boolean := False;
198 Stub_Type
: Entity_Id
:= Empty
;
199 RACW_Type
: Entity_Id
:= Empty
;
200 Locator
: Entity_Id
:= Empty
;
201 New_Name
: Name_Id
:= No_Name
) return Node_Id
;
202 -- Build the calling stub for a given subprogram with the subprogram ID
203 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
204 -- parameters of this type will be marshalled instead of the object
205 -- itself. It will then be converted into Stub_Type before performing
206 -- the real call. If Dynamically_Asynchronous is True, then it will be
207 -- computed at run time whether the call is asynchronous or not.
208 -- Otherwise, the value of the formal Asynchronous will be used.
209 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
210 -- New_Name is given, then it will be used instead of the original name.
212 function Build_RPC_Receiver_Specification
213 (RPC_Receiver
: Entity_Id
;
214 Request_Parameter
: Entity_Id
) return Node_Id
;
215 -- Make a subprogram specification for an RPC receiver, with the given
216 -- defining unit name and formal parameter.
218 function Build_Ordered_Parameters_List
(Spec
: Node_Id
) return List_Id
;
219 -- Return an ordered parameter list: unconstrained parameters are put
220 -- at the beginning of the list and constrained ones are put after. If
221 -- there are no parameters, an empty list is returned. Special case:
222 -- the controlling formal of the equivalent RACW operation for a RAS
223 -- type is always left in first position.
225 function Transmit_As_Unconstrained
(Typ
: Entity_Id
) return Boolean;
226 -- True when Typ is an unconstrained type, or a null-excluding access type.
227 -- In either case, this means stubs cannot contain a default-initialized
228 -- object declaration of such type.
230 procedure Add_Calling_Stubs_To_Declarations
233 -- Add calling stubs to the declarative part
235 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean;
236 -- Return True if nothing prevents the program whose specification is
237 -- given to be asynchronous (i.e. no out parameter).
239 function Pack_Entity_Into_Stream_Access
243 Etyp
: Entity_Id
:= Empty
) return Node_Id
;
244 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
245 -- then Etype (Object) will be used if present. If the type is
246 -- constrained, then 'Write will be used to output the object,
247 -- If the type is unconstrained, 'Output will be used.
249 function Pack_Node_Into_Stream
253 Etyp
: Entity_Id
) return Node_Id
;
254 -- Similar to above, with an arbitrary node instead of an entity
256 function Pack_Node_Into_Stream_Access
260 Etyp
: Entity_Id
) return Node_Id
;
261 -- Similar to above, with Stream instead of Stream'Access
263 function Make_Selected_Component
266 Selector_Name
: Name_Id
) return Node_Id
;
267 -- Return a selected_component whose prefix denotes the given entity,
268 -- and with the given Selector_Name.
270 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
;
271 -- Return the scope represented by a given spec
273 procedure Set_Renaming_TSS
276 TSS_Nam
: TSS_Name_Type
);
277 -- Create a renaming declaration of subprogram Nam,
278 -- and register it as a TSS for Typ with name TSS_Nam.
280 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean;
281 -- Return True if the current parameter needs an extra formal to reflect
282 -- its constrained status.
284 function Is_RACW_Controlling_Formal
285 (Parameter
: Node_Id
;
286 Stub_Type
: Entity_Id
) return Boolean;
287 -- Return True if the current parameter is a controlling formal argument
288 -- of type Stub_Type or access to Stub_Type.
290 procedure Declare_Create_NVList
295 -- Append the declaration of NVList to Decls, and its
296 -- initialization to Stmts.
298 function Add_Parameter_To_NVList
301 Parameter
: Entity_Id
;
302 Constrained
: Boolean;
303 RACW_Ctrl
: Boolean := False;
304 Any
: Entity_Id
) return Node_Id
;
305 -- Return a call to Add_Item to add the Any corresponding to the designated
306 -- formal Parameter (with the indicated Constrained status) to NVList.
307 -- RACW_Ctrl must be set to True for controlling formals of distributed
308 -- object primitive operations.
314 -- This record describes various tree fragments associated with the
315 -- generation of RACW calling stubs. One such record exists for every
316 -- distributed object type, i.e. each tagged type that is the designated
317 -- type of one or more RACW type.
319 type Stub_Structure
is record
320 Stub_Type
: Entity_Id
;
321 -- Stub type: this type has the same primitive operations as the
322 -- designated types, but the provided bodies for these operations
323 -- a remote call to an actual target object potentially located on
324 -- another partition; each value of the stub type encapsulates a
325 -- reference to a remote object.
327 Stub_Type_Access
: Entity_Id
;
328 -- A local access type designating the stub type (this is not an RACW
331 RPC_Receiver_Decl
: Node_Id
;
332 -- Declaration for the RPC receiver entity associated with the
333 -- designated type. As an exception, for the case of an RACW that
334 -- implements a RAS, no object RPC receiver is generated. Instead,
335 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
336 -- would have been inserted.
338 Body_Decls
: List_Id
;
339 -- List of subprogram bodies to be included in generated code: bodies
340 -- for the RACW's stream attributes, and for the primitive operations
343 RACW_Type
: Entity_Id
;
344 -- One of the RACW types designating this distributed object type
345 -- (they are all interchangeable; we use any one of them in order to
346 -- avoid having to create various anonymous access types).
350 Empty_Stub_Structure
: constant Stub_Structure
:=
351 (Empty
, Empty
, Empty
, No_List
, Empty
);
353 package Stubs_Table
is
354 new Simple_HTable
(Header_Num
=> Hash_Index
,
355 Element
=> Stub_Structure
,
356 No_Element
=> Empty_Stub_Structure
,
360 -- Mapping between a RACW designated type and its stub type
362 package Asynchronous_Flags_Table
is
363 new Simple_HTable
(Header_Num
=> Hash_Index
,
364 Element
=> Entity_Id
,
369 -- Mapping between a RACW type and a constant having the value True
370 -- if the RACW is asynchronous and False otherwise.
372 package RCI_Locator_Table
is
373 new Simple_HTable
(Header_Num
=> Hash_Index
,
374 Element
=> Entity_Id
,
379 -- Mapping between a RCI package on which All_Calls_Remote applies and
380 -- the generic instantiation of RCI_Locator for this package.
382 package RCI_Calling_Stubs_Table
is
383 new Simple_HTable
(Header_Num
=> Hash_Index
,
384 Element
=> Entity_Id
,
389 -- Mapping between a RCI subprogram and the corresponding calling stubs
391 function Get_Stub_Elements
(RACW_Type
: Entity_Id
) return Stub_Structure
;
392 -- Return the stub information associated with the given RACW type
394 procedure Add_Stub_Type
395 (Designated_Type
: Entity_Id
;
396 RACW_Type
: Entity_Id
;
398 Stub_Type
: out Entity_Id
;
399 Stub_Type_Access
: out Entity_Id
;
400 RPC_Receiver_Decl
: out Node_Id
;
401 Body_Decls
: out List_Id
;
402 Existing
: out Boolean);
403 -- Add the declaration of the stub type, the access to stub type and the
404 -- object RPC receiver at the end of Decls. If these already exist,
405 -- then nothing is added in the tree but the right values are returned
406 -- anyhow and Existing is set to True.
408 function Get_And_Reset_RACW_Bodies
(RACW_Type
: Entity_Id
) return List_Id
;
409 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
410 -- structure table, reset it to No_List, and return the previous value.
412 procedure Add_RACW_Asynchronous_Flag
413 (Declarations
: List_Id
;
414 RACW_Type
: Entity_Id
);
415 -- Declare a boolean constant associated with RACW_Type whose value
416 -- indicates at run time whether a pragma Asynchronous applies to it.
418 procedure Assign_Subprogram_Identifier
422 -- Determine the distribution subprogram identifier to
423 -- be used for remote subprogram Def, return it in Id and
424 -- store it in a hash table for later retrieval by
425 -- Get_Subprogram_Id. Spn is the subprogram number.
427 function RCI_Package_Locator
429 Package_Spec
: Node_Id
) return Node_Id
;
430 -- Instantiate the generic package RCI_Locator in order to locate the
431 -- RCI package whose spec is given as argument.
433 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
;
434 -- Surround a node N by a tag check, as in:
438 -- when E : Ada.Tags.Tag_Error =>
439 -- Raise_Exception (Program_Error'Identity,
440 -- Exception_Message (E));
443 function Input_With_Tag_Check
445 Var_Type
: Entity_Id
;
446 Stream
: Node_Id
) return Node_Id
;
447 -- Return a function with the following form:
448 -- function R return Var_Type is
450 -- return Var_Type'Input (S);
452 -- when E : Ada.Tags.Tag_Error =>
453 -- Raise_Exception (Program_Error'Identity,
454 -- Exception_Message (E));
457 procedure Build_Actual_Object_Declaration
463 -- Build the declaration of an object with the given defining identifier,
464 -- initialized with Expr if provided, to serve as actual parameter in a
465 -- server stub. If Variable is true, the declared object will be a variable
466 -- (case of an out or in out formal), else it will be a constant. Object's
467 -- Ekind is set accordingly. The declaration, as well as any other
468 -- declarations it requires, are appended to Decls.
470 --------------------------------------------
471 -- Hooks for PCS-specific code generation --
472 --------------------------------------------
474 -- Part of the code generation circuitry for distribution needs to be
475 -- tailored for each implementation of the PCS. For each routine that
476 -- needs to be specialized, a Specific_<routine> wrapper is created,
477 -- which calls the corresponding <routine> in package
478 -- <pcs_implementation>_Support.
480 procedure Specific_Add_RACW_Features
481 (RACW_Type
: Entity_Id
;
483 Stub_Type
: Entity_Id
;
484 Stub_Type_Access
: Entity_Id
;
485 RPC_Receiver_Decl
: Node_Id
;
486 Body_Decls
: List_Id
);
487 -- Add declaration for TSSs for a given RACW type. The declarations are
488 -- added just after the declaration of the RACW type itself. If the RACW
489 -- appears in the main unit, Body_Decls is a list of declarations to which
490 -- the bodies are appended. Else Body_Decls is No_List.
491 -- PCS-specific ancillary subprogram for Add_RACW_Features.
493 procedure Specific_Add_RAST_Features
495 RAS_Type
: Entity_Id
);
496 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
497 -- subprogram for Add_RAST_Features.
499 -- An RPC_Target record is used during construction of calling stubs
500 -- to pass PCS-specific tree fragments corresponding to the information
501 -- necessary to locate the target of a remote subprogram call.
503 type RPC_Target
(PCS_Kind
: PCS_Names
) is record
505 when Name_PolyORB_DSA
=>
507 -- An expression whose value is a PolyORB reference to the target
511 Partition
: Entity_Id
;
512 -- A variable containing the Partition_ID of the target partition
514 RPC_Receiver
: Node_Id
;
515 -- An expression whose value is the address of the target RPC
520 procedure Specific_Build_General_Calling_Stubs
522 Statements
: List_Id
;
524 Subprogram_Id
: Node_Id
;
525 Asynchronous
: Node_Id
:= Empty
;
526 Is_Known_Asynchronous
: Boolean := False;
527 Is_Known_Non_Asynchronous
: Boolean := False;
528 Is_Function
: Boolean;
530 Stub_Type
: Entity_Id
:= Empty
;
531 RACW_Type
: Entity_Id
:= Empty
;
533 -- Build calling stubs for general purpose. The parameters are:
534 -- Decls : a place to put declarations
535 -- Statements : a place to put statements
536 -- Target : PCS-specific target information (see details
537 -- in RPC_Target declaration).
538 -- Subprogram_Id : a node containing the subprogram ID
539 -- Asynchronous : True if an APC must be made instead of an RPC.
540 -- The value needs not be supplied if one of the
541 -- Is_Known_... is True.
542 -- Is_Known_Async... : True if we know that this is asynchronous
543 -- Is_Known_Non_A... : True if we know that this is not asynchronous
544 -- Spec : a node with a Parameter_Specifications and
545 -- a Result_Definition if applicable
546 -- Stub_Type : in case of RACW stubs, parameters of type access
547 -- to Stub_Type will be marshalled using the
548 -- address of the object (the addr field) rather
549 -- than using the 'Write on the stub itself
550 -- Nod : used to provide sloc for generated code
552 function Specific_Build_Stub_Target
555 RCI_Locator
: Entity_Id
;
556 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
557 -- Build call target information nodes for use within calling stubs. In the
558 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
559 -- for an RACW, Controlling_Parameter is the entity for the controlling
560 -- formal parameter used to determine the location of the target of the
561 -- call. Decls provides a location where variable declarations can be
562 -- appended to construct the necessary values.
564 procedure Specific_Build_Stub_Type
565 (RACW_Type
: Entity_Id
;
566 Stub_Type
: Entity_Id
;
567 Stub_Type_Decl
: out Node_Id
;
568 RPC_Receiver_Decl
: out Node_Id
);
569 -- Build a type declaration for the stub type associated with an RACW
570 -- type, and the necessary RPC receiver, if applicable. PCS-specific
571 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
572 -- is generated, then RPC_Receiver_Decl is set to Empty.
574 procedure Specific_Build_RPC_Receiver_Body
575 (RPC_Receiver
: Entity_Id
;
576 Request
: out Entity_Id
;
577 Subp_Id
: out Entity_Id
;
578 Subp_Index
: out Entity_Id
;
581 -- Make a subprogram body for an RPC receiver, with the given
582 -- defining unit name. On return:
583 -- - Subp_Id is the subprogram identifier from the PCS.
584 -- - Subp_Index is the index in the list of subprograms
585 -- used for dispatching (a variable of type Subprogram_Id).
586 -- - Stmts is the place where the request dispatching
587 -- statements can occur,
588 -- - Decl is the subprogram body declaration.
590 function Specific_Build_Subprogram_Receiving_Stubs
592 Asynchronous
: Boolean;
593 Dynamically_Asynchronous
: Boolean := False;
594 Stub_Type
: Entity_Id
:= Empty
;
595 RACW_Type
: Entity_Id
:= Empty
;
596 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
597 -- Build the receiving stub for a given subprogram. The subprogram
598 -- declaration is also built by this procedure, and the value returned
599 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
600 -- found in the specification, then its address is read from the stream
601 -- instead of the object itself and converted into an access to
602 -- class-wide type before doing the real call using any of the RACW type
603 -- pointing on the designated type.
605 procedure Specific_Add_Obj_RPC_Receiver_Completion
608 RPC_Receiver
: Entity_Id
;
609 Stub_Elements
: Stub_Structure
);
610 -- Add the necessary code to Decls after the completion of generation
611 -- of the RACW RPC receiver described by Stub_Elements.
613 procedure Specific_Add_Receiving_Stubs_To_Declarations
617 -- Add receiving stubs to the declarative part of an RCI unit
619 package GARLIC_Support
is
621 -- Support for generating DSA code that uses the GARLIC PCS
623 -- The subprograms below provide the GARLIC versions of the
624 -- corresponding Specific_<subprogram> routine declared above.
626 procedure Add_RACW_Features
627 (RACW_Type
: Entity_Id
;
628 Stub_Type
: Entity_Id
;
629 Stub_Type_Access
: Entity_Id
;
630 RPC_Receiver_Decl
: Node_Id
;
631 Body_Decls
: List_Id
);
633 procedure Add_RAST_Features
635 RAS_Type
: Entity_Id
);
637 procedure Build_General_Calling_Stubs
639 Statements
: List_Id
;
640 Target_Partition
: Entity_Id
; -- From RPC_Target
641 Target_RPC_Receiver
: Node_Id
; -- From RPC_Target
642 Subprogram_Id
: Node_Id
;
643 Asynchronous
: Node_Id
:= Empty
;
644 Is_Known_Asynchronous
: Boolean := False;
645 Is_Known_Non_Asynchronous
: Boolean := False;
646 Is_Function
: Boolean;
648 Stub_Type
: Entity_Id
:= Empty
;
649 RACW_Type
: Entity_Id
:= Empty
;
652 function Build_Stub_Target
655 RCI_Locator
: Entity_Id
;
656 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
658 procedure Build_Stub_Type
659 (RACW_Type
: Entity_Id
;
660 Stub_Type
: Entity_Id
;
661 Stub_Type_Decl
: out Node_Id
;
662 RPC_Receiver_Decl
: out Node_Id
);
664 function Build_Subprogram_Receiving_Stubs
666 Asynchronous
: Boolean;
667 Dynamically_Asynchronous
: Boolean := False;
668 Stub_Type
: Entity_Id
:= Empty
;
669 RACW_Type
: Entity_Id
:= Empty
;
670 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
672 procedure Add_Obj_RPC_Receiver_Completion
675 RPC_Receiver
: Entity_Id
;
676 Stub_Elements
: Stub_Structure
);
678 procedure Add_Receiving_Stubs_To_Declarations
683 procedure Build_RPC_Receiver_Body
684 (RPC_Receiver
: Entity_Id
;
685 Request
: out Entity_Id
;
686 Subp_Id
: out Entity_Id
;
687 Subp_Index
: out Entity_Id
;
693 package PolyORB_Support
is
695 -- Support for generating DSA code that uses the PolyORB PCS
697 -- The subprograms below provide the PolyORB versions of the
698 -- corresponding Specific_<subprogram> routine declared above.
700 procedure Add_RACW_Features
701 (RACW_Type
: Entity_Id
;
703 Stub_Type
: Entity_Id
;
704 Stub_Type_Access
: Entity_Id
;
705 RPC_Receiver_Decl
: Node_Id
;
706 Body_Decls
: List_Id
);
708 procedure Add_RAST_Features
710 RAS_Type
: Entity_Id
);
712 procedure Build_General_Calling_Stubs
714 Statements
: List_Id
;
715 Target_Object
: Node_Id
; -- From RPC_Target
716 Subprogram_Id
: Node_Id
;
717 Asynchronous
: Node_Id
:= Empty
;
718 Is_Known_Asynchronous
: Boolean := False;
719 Is_Known_Non_Asynchronous
: Boolean := False;
720 Is_Function
: Boolean;
722 Stub_Type
: Entity_Id
:= Empty
;
723 RACW_Type
: Entity_Id
:= Empty
;
726 function Build_Stub_Target
729 RCI_Locator
: Entity_Id
;
730 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
732 procedure Build_Stub_Type
733 (RACW_Type
: Entity_Id
;
734 Stub_Type
: Entity_Id
;
735 Stub_Type_Decl
: out Node_Id
;
736 RPC_Receiver_Decl
: out Node_Id
);
738 function Build_Subprogram_Receiving_Stubs
740 Asynchronous
: Boolean;
741 Dynamically_Asynchronous
: Boolean := False;
742 Stub_Type
: Entity_Id
:= Empty
;
743 RACW_Type
: Entity_Id
:= Empty
;
744 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
746 procedure Add_Obj_RPC_Receiver_Completion
749 RPC_Receiver
: Entity_Id
;
750 Stub_Elements
: Stub_Structure
);
752 procedure Add_Receiving_Stubs_To_Declarations
757 procedure Build_RPC_Receiver_Body
758 (RPC_Receiver
: Entity_Id
;
759 Request
: out Entity_Id
;
760 Subp_Id
: out Entity_Id
;
761 Subp_Index
: out Entity_Id
;
765 procedure Reserve_NamingContext_Methods
;
766 -- Mark the method names for interface NamingContext as already used in
767 -- the overload table, so no clashes occur with user code (with the
768 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
769 -- their methods to be accessed as objects, for the implementation of
770 -- remote access-to-subprogram types).
774 -- Routines to build distribution helper subprograms for user-defined
775 -- types. For implementation of the Distributed systems annex (DSA)
776 -- over the PolyORB generic middleware components, it is necessary to
777 -- generate several supporting subprograms for each application data
778 -- type used in inter-partition communication. These subprograms are:
780 -- A Typecode function returning a high-level description of the
783 -- Two conversion functions allowing conversion of values of the
784 -- type from and to the generic data containers used by PolyORB.
785 -- These generic containers are called 'Any' type values after the
786 -- CORBA terminology, and hence the conversion subprograms are
787 -- named To_Any and From_Any.
789 function Build_From_Any_Call
792 Decls
: List_Id
) return Node_Id
;
793 -- Build call to From_Any attribute function of type Typ with
794 -- expression N as actual parameter. Decls is the declarations list
795 -- for an appropriate enclosing scope of the point where the call
796 -- will be inserted; if the From_Any attribute for Typ needs to be
797 -- generated at this point, its declaration is appended to Decls.
799 procedure Build_From_Any_Function
803 Fnam
: out Entity_Id
);
804 -- Build From_Any attribute function for Typ. Loc is the reference
805 -- location for generated nodes, Typ is the type for which the
806 -- conversion function is generated. On return, Decl and Fnam contain
807 -- the declaration and entity for the newly-created function.
809 function Build_To_Any_Call
811 Decls
: List_Id
) return Node_Id
;
812 -- Build call to To_Any attribute function with expression as actual
813 -- parameter. Decls is the declarations list for an appropriate
814 -- enclosing scope of the point where the call will be inserted; if
815 -- the To_Any attribute for Typ needs to be generated at this point,
816 -- its declaration is appended to Decls.
818 procedure Build_To_Any_Function
822 Fnam
: out Entity_Id
);
823 -- Build To_Any attribute function for Typ. Loc is the reference
824 -- location for generated nodes, Typ is the type for which the
825 -- conversion function is generated. On return, Decl and Fnam contain
826 -- the declaration and entity for the newly-created function.
828 function Build_TypeCode_Call
831 Decls
: List_Id
) return Node_Id
;
832 -- Build call to TypeCode attribute function for Typ. Decls is the
833 -- declarations list for an appropriate enclosing scope of the point
834 -- where the call will be inserted; if the To_Any attribute for Typ
835 -- needs to be generated at this point, its declaration is appended
838 procedure Build_TypeCode_Function
842 Fnam
: out Entity_Id
);
843 -- Build TypeCode attribute function for Typ. Loc is the reference
844 -- location for generated nodes, Typ is the type for which the
845 -- conversion function is generated. On return, Decl and Fnam contain
846 -- the declaration and entity for the newly-created function.
848 procedure Build_Name_And_Repository_Id
850 Name_Str
: out String_Id
;
851 Repo_Id_Str
: out String_Id
);
852 -- In the PolyORB distribution model, each distributed object type
853 -- and each distributed operation has a globally unique identifier,
854 -- its Repository Id. This subprogram builds and returns two strings
855 -- for entity E (a distributed object type or operation): one
856 -- containing the name of E, the second containing its repository id.
862 -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
864 function Build_From_Any_Call
867 Decls
: List_Id
) return Node_Id
868 renames PolyORB_Support
.Helpers
.Build_From_Any_Call
;
870 function Build_To_Any_Call
872 Decls
: List_Id
) return Node_Id
873 renames PolyORB_Support
.Helpers
.Build_To_Any_Call
;
875 function Build_TypeCode_Call
878 Decls
: List_Id
) return Node_Id
879 renames PolyORB_Support
.Helpers
.Build_TypeCode_Call
;
881 ------------------------------------
882 -- Local variables and structures --
883 ------------------------------------
886 -- Needs comments ???
888 Output_From_Constrained
: constant array (Boolean) of Name_Id
:=
889 (False => Name_Output
,
891 -- The attribute to choose depending on the fact that the parameter
892 -- is constrained or not. There is no such thing as Input_From_Constrained
893 -- since this require separate mechanisms ('Input is a function while
894 -- 'Read is a procedure).
896 ---------------------------------------
897 -- Add_Calling_Stubs_To_Declarations --
898 ---------------------------------------
900 procedure Add_Calling_Stubs_To_Declarations
904 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
905 -- Subprogram id 0 is reserved for calls received from
906 -- remote access-to-subprogram dereferences.
908 Current_Declaration
: Node_Id
;
909 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
910 RCI_Instantiation
: Node_Id
;
911 Subp_Stubs
: Node_Id
;
912 Subp_Str
: String_Id
;
914 pragma Warnings
(Off
, Subp_Str
);
917 -- The first thing added is an instantiation of the generic package
918 -- System.Partition_Interface.RCI_Locator with the name of this remote
919 -- package. This will act as an interface with the name server to
920 -- determine the Partition_ID and the RPC_Receiver for the receiver
923 RCI_Instantiation
:= RCI_Package_Locator
(Loc
, Pkg_Spec
);
924 RCI_Cache
:= Defining_Unit_Name
(RCI_Instantiation
);
926 Append_To
(Decls
, RCI_Instantiation
);
927 Analyze
(RCI_Instantiation
);
929 -- For each subprogram declaration visible in the spec, we do build a
930 -- body. We also increment a counter to assign a different Subprogram_Id
931 -- to each subprograms. The receiving stubs processing do use the same
932 -- mechanism and will thus assign the same Id and do the correct
935 Overload_Counter_Table
.Reset
;
936 PolyORB_Support
.Reserve_NamingContext_Methods
;
938 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
939 while Present
(Current_Declaration
) loop
940 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
941 and then Comes_From_Source
(Current_Declaration
)
943 Assign_Subprogram_Identifier
944 (Defining_Unit_Name
(Specification
(Current_Declaration
)),
945 Current_Subprogram_Number
,
949 Build_Subprogram_Calling_Stubs
(
950 Vis_Decl
=> Current_Declaration
,
952 Build_Subprogram_Id
(Loc
,
953 Defining_Unit_Name
(Specification
(Current_Declaration
))),
955 Nkind
(Specification
(Current_Declaration
)) =
956 N_Procedure_Specification
958 Is_Asynchronous
(Defining_Unit_Name
(Specification
959 (Current_Declaration
))));
961 Append_To
(Decls
, Subp_Stubs
);
962 Analyze
(Subp_Stubs
);
964 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
967 Next
(Current_Declaration
);
969 end Add_Calling_Stubs_To_Declarations
;
971 -----------------------------
972 -- Add_Parameter_To_NVList --
973 -----------------------------
975 function Add_Parameter_To_NVList
978 Parameter
: Entity_Id
;
979 Constrained
: Boolean;
980 RACW_Ctrl
: Boolean := False;
981 Any
: Entity_Id
) return Node_Id
983 Parameter_Name_String
: String_Id
;
984 Parameter_Mode
: Node_Id
;
986 function Parameter_Passing_Mode
988 Parameter
: Entity_Id
;
989 Constrained
: Boolean) return Node_Id
;
990 -- Return an expression that denotes the parameter passing mode to be
991 -- used for Parameter in distribution stubs, where Constrained is
992 -- Parameter's constrained status.
994 ----------------------------
995 -- Parameter_Passing_Mode --
996 ----------------------------
998 function Parameter_Passing_Mode
1000 Parameter
: Entity_Id
;
1001 Constrained
: Boolean) return Node_Id
1006 if Out_Present
(Parameter
) then
1007 if In_Present
(Parameter
)
1008 or else not Constrained
1010 -- Unconstrained formals must be translated
1011 -- to 'in' or 'inout', not 'out', because
1012 -- they need to be constrained by the actual.
1014 Lib_RE
:= RE_Mode_Inout
;
1016 Lib_RE
:= RE_Mode_Out
;
1020 Lib_RE
:= RE_Mode_In
;
1023 return New_Occurrence_Of
(RTE
(Lib_RE
), Loc
);
1024 end Parameter_Passing_Mode
;
1026 -- Start of processing for Add_Parameter_To_NVList
1029 if Nkind
(Parameter
) = N_Defining_Identifier
then
1030 Get_Name_String
(Chars
(Parameter
));
1032 Get_Name_String
(Chars
(Defining_Identifier
(Parameter
)));
1035 Parameter_Name_String
:= String_From_Name_Buffer
;
1037 if RACW_Ctrl
or else Nkind
(Parameter
) = N_Defining_Identifier
then
1039 -- When the parameter passed to Add_Parameter_To_NVList is an
1040 -- Extra_Constrained parameter, Parameter is an N_Defining_
1041 -- Identifier, instead of a complete N_Parameter_Specification.
1042 -- Thus, we explicitly set 'in' mode in this case.
1044 Parameter_Mode
:= New_Occurrence_Of
(RTE
(RE_Mode_In
), Loc
);
1048 Parameter_Passing_Mode
(Loc
, Parameter
, Constrained
);
1052 Make_Procedure_Call_Statement
(Loc
,
1055 (RTE
(RE_NVList_Add_Item
), Loc
),
1056 Parameter_Associations
=> New_List
(
1057 New_Occurrence_Of
(NVList
, Loc
),
1058 Make_Function_Call
(Loc
,
1061 (RTE
(RE_To_PolyORB_String
), Loc
),
1062 Parameter_Associations
=> New_List
(
1063 Make_String_Literal
(Loc
,
1064 Strval
=> Parameter_Name_String
))),
1065 New_Occurrence_Of
(Any
, Loc
),
1067 end Add_Parameter_To_NVList
;
1069 --------------------------------
1070 -- Add_RACW_Asynchronous_Flag --
1071 --------------------------------
1073 procedure Add_RACW_Asynchronous_Flag
1074 (Declarations
: List_Id
;
1075 RACW_Type
: Entity_Id
)
1077 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1079 Asynchronous_Flag
: constant Entity_Id
:=
1080 Make_Defining_Identifier
(Loc
,
1081 New_External_Name
(Chars
(RACW_Type
), 'A'));
1084 -- Declare the asynchronous flag. This flag will be changed to True
1085 -- whenever it is known that the RACW type is asynchronous.
1087 Append_To
(Declarations
,
1088 Make_Object_Declaration
(Loc
,
1089 Defining_Identifier
=> Asynchronous_Flag
,
1090 Constant_Present
=> True,
1091 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
1092 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
1094 Asynchronous_Flags_Table
.Set
(RACW_Type
, Asynchronous_Flag
);
1095 end Add_RACW_Asynchronous_Flag
;
1097 -----------------------
1098 -- Add_RACW_Features --
1099 -----------------------
1101 procedure Add_RACW_Features
(RACW_Type
: Entity_Id
) is
1102 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
1103 Same_Scope
: constant Boolean := Scope
(Desig
) = Scope
(RACW_Type
);
1107 Body_Decls
: List_Id
;
1109 Stub_Type
: Entity_Id
;
1110 Stub_Type_Access
: Entity_Id
;
1111 RPC_Receiver_Decl
: Node_Id
;
1114 -- True when appropriate stubs have already been generated (this is the
1115 -- case when another RACW with the same designated type has already been
1116 -- encountered), in which case we reuse the previous stubs rather than
1117 -- generating new ones.
1120 if not Expander_Active
then
1124 -- Mark the current package declaration as containing an RACW, so that
1125 -- the bodies for the calling stubs and the RACW stream subprograms
1126 -- are attached to the tree when the corresponding body is encountered.
1128 Set_Has_RACW
(Current_Scope
);
1130 -- Look for place to declare the RACW stub type and RACW operations
1136 -- Case of declaring the RACW in the same package as its designated
1137 -- type: we know that the designated type is a private type, so we
1138 -- use the private declarations list.
1140 Pkg_Spec
:= Package_Specification_Of_Scope
(Current_Scope
);
1142 if Present
(Private_Declarations
(Pkg_Spec
)) then
1143 Decls
:= Private_Declarations
(Pkg_Spec
);
1145 Decls
:= Visible_Declarations
(Pkg_Spec
);
1150 -- Case of declaring the RACW in another package than its designated
1151 -- type: use the private declarations list if present; otherwise
1152 -- use the visible declarations.
1154 Decls
:= List_Containing
(Declaration_Node
(RACW_Type
));
1158 -- If we were unable to find the declarations, that means that the
1159 -- completion of the type was missing. We can safely return and let the
1160 -- error be caught by the semantic analysis.
1167 (Designated_Type
=> Desig
,
1168 RACW_Type
=> RACW_Type
,
1170 Stub_Type
=> Stub_Type
,
1171 Stub_Type_Access
=> Stub_Type_Access
,
1172 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1173 Body_Decls
=> Body_Decls
,
1174 Existing
=> Existing
);
1176 -- If this RACW is not in the main unit, do not generate primitive or
1179 if not Entity_Is_In_Main_Unit
(RACW_Type
) then
1180 Body_Decls
:= No_List
;
1183 Add_RACW_Asynchronous_Flag
1184 (Declarations
=> Decls
,
1185 RACW_Type
=> RACW_Type
);
1187 Specific_Add_RACW_Features
1188 (RACW_Type
=> RACW_Type
,
1190 Stub_Type
=> Stub_Type
,
1191 Stub_Type_Access
=> Stub_Type_Access
,
1192 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1193 Body_Decls
=> Body_Decls
);
1195 -- If we already have stubs for this designated type, nothing to do
1201 if Is_Frozen
(Desig
) then
1202 Validate_RACW_Primitives
(RACW_Type
);
1203 Add_RACW_Primitive_Declarations_And_Bodies
1204 (Designated_Type
=> Desig
,
1205 Insertion_Node
=> RPC_Receiver_Decl
,
1206 Body_Decls
=> Body_Decls
);
1209 -- Validate_RACW_Primitives requires the list of all primitives of
1210 -- the designated type, so defer processing until Desig is frozen.
1211 -- See Exp_Ch3.Freeze_Type.
1213 Add_Access_Type_To_Process
(E
=> Desig
, A
=> RACW_Type
);
1215 end Add_RACW_Features
;
1217 ------------------------------------------------
1218 -- Add_RACW_Primitive_Declarations_And_Bodies --
1219 ------------------------------------------------
1221 procedure Add_RACW_Primitive_Declarations_And_Bodies
1222 (Designated_Type
: Entity_Id
;
1223 Insertion_Node
: Node_Id
;
1224 Body_Decls
: List_Id
)
1226 Loc
: constant Source_Ptr
:= Sloc
(Insertion_Node
);
1227 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1228 -- the declarations are recognized as belonging to the current package.
1230 Stub_Elements
: constant Stub_Structure
:=
1231 Stubs_Table
.Get
(Designated_Type
);
1233 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
1235 Is_RAS
: constant Boolean :=
1236 not Comes_From_Source
(Stub_Elements
.RACW_Type
);
1237 -- Case of the RACW generated to implement a remote access-to-
1240 Build_Bodies
: constant Boolean :=
1241 In_Extended_Main_Code_Unit
(Stub_Elements
.Stub_Type
);
1242 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1243 -- only when the main unit is the unit that contains the stub type.
1245 Current_Insertion_Node
: Node_Id
:= Insertion_Node
;
1247 RPC_Receiver
: Entity_Id
;
1248 RPC_Receiver_Statements
: List_Id
;
1249 RPC_Receiver_Case_Alternatives
: constant List_Id
:= New_List
;
1250 RPC_Receiver_Elsif_Parts
: List_Id
;
1251 RPC_Receiver_Request
: Entity_Id
;
1252 RPC_Receiver_Subp_Id
: Entity_Id
;
1253 RPC_Receiver_Subp_Index
: Entity_Id
;
1255 Subp_Str
: String_Id
;
1257 Current_Primitive_Elmt
: Elmt_Id
;
1258 Current_Primitive
: Entity_Id
;
1259 Current_Primitive_Body
: Node_Id
;
1260 Current_Primitive_Spec
: Node_Id
;
1261 Current_Primitive_Decl
: Node_Id
;
1262 Current_Primitive_Number
: Int
:= 0;
1263 Current_Primitive_Alias
: Node_Id
;
1264 Current_Receiver
: Entity_Id
;
1265 Current_Receiver_Body
: Node_Id
;
1266 RPC_Receiver_Decl
: Node_Id
;
1267 Possibly_Asynchronous
: Boolean;
1270 if not Expander_Active
then
1276 Make_Defining_Identifier
(Loc
,
1277 Chars
=> New_Internal_Name
('P'));
1279 Specific_Build_RPC_Receiver_Body
1280 (RPC_Receiver
=> RPC_Receiver
,
1281 Request
=> RPC_Receiver_Request
,
1282 Subp_Id
=> RPC_Receiver_Subp_Id
,
1283 Subp_Index
=> RPC_Receiver_Subp_Index
,
1284 Stmts
=> RPC_Receiver_Statements
,
1285 Decl
=> RPC_Receiver_Decl
);
1287 if Get_PCS_Name
= Name_PolyORB_DSA
then
1289 -- For the case of PolyORB, we need to map a textual operation
1290 -- name into a primitive index. Currently we do so using a simple
1291 -- sequence of string comparisons.
1293 RPC_Receiver_Elsif_Parts
:= New_List
;
1297 -- Build callers, receivers for every primitive operations and a RPC
1298 -- receiver for this type.
1300 if Present
(Primitive_Operations
(Designated_Type
)) then
1301 Overload_Counter_Table
.Reset
;
1303 Current_Primitive_Elmt
:=
1304 First_Elmt
(Primitive_Operations
(Designated_Type
));
1305 while Current_Primitive_Elmt
/= No_Elmt
loop
1306 Current_Primitive
:= Node
(Current_Primitive_Elmt
);
1308 -- Copy the primitive of all the parents, except predefined ones
1309 -- that are not remotely dispatching. Also omit hidden primitives
1310 -- (occurs in the case of primitives of interface progenitors
1311 -- other than immediate ancestors of the Designated_Type).
1313 if Chars
(Current_Primitive
) /= Name_uSize
1314 and then Chars
(Current_Primitive
) /= Name_uAlignment
1316 (Is_TSS
(Current_Primitive
, TSS_Deep_Finalize
) or else
1317 Is_TSS
(Current_Primitive
, TSS_Stream_Input
) or else
1318 Is_TSS
(Current_Primitive
, TSS_Stream_Output
) or else
1319 Is_TSS
(Current_Primitive
, TSS_Stream_Read
) or else
1320 Is_TSS
(Current_Primitive
, TSS_Stream_Write
))
1321 and then not Is_Hidden
(Current_Primitive
)
1323 -- The first thing to do is build an up-to-date copy of the
1324 -- spec with all the formals referencing Designated_Type
1325 -- transformed into formals referencing Stub_Type. Since this
1326 -- primitive may have been inherited, go back the alias chain
1327 -- until the real primitive has been found.
1329 Current_Primitive_Alias
:= Current_Primitive
;
1330 while Present
(Alias
(Current_Primitive_Alias
)) loop
1332 (Current_Primitive_Alias
1333 /= Alias
(Current_Primitive_Alias
));
1334 Current_Primitive_Alias
:= Alias
(Current_Primitive_Alias
);
1337 -- Copy the spec from the original declaration for the purpose
1338 -- of declaring an overriding subprogram: we need to replace
1339 -- the type of each controlling formal with Stub_Type. The
1340 -- primitive may have been declared for Designated_Type or
1341 -- inherited from some ancestor type for which we do not have
1342 -- an easily determined Entity_Id. We have no systematic way
1343 -- of knowing which type to substitute Stub_Type for. Instead,
1344 -- Copy_Specification relies on the flag Is_Controlling_Formal
1345 -- to determine which formals to change.
1347 Current_Primitive_Spec
:=
1348 Copy_Specification
(Loc
,
1349 Spec
=> Parent
(Current_Primitive_Alias
),
1350 Ctrl_Type
=> Stub_Elements
.Stub_Type
);
1352 Current_Primitive_Decl
:=
1353 Make_Subprogram_Declaration
(Loc
,
1354 Specification
=> Current_Primitive_Spec
);
1356 Insert_After_And_Analyze
(Current_Insertion_Node
,
1357 Current_Primitive_Decl
);
1358 Current_Insertion_Node
:= Current_Primitive_Decl
;
1360 Possibly_Asynchronous
:=
1361 Nkind
(Current_Primitive_Spec
) = N_Procedure_Specification
1362 and then Could_Be_Asynchronous
(Current_Primitive_Spec
);
1364 Assign_Subprogram_Identifier
(
1365 Defining_Unit_Name
(Current_Primitive_Spec
),
1366 Current_Primitive_Number
,
1369 if Build_Bodies
then
1370 Current_Primitive_Body
:=
1371 Build_Subprogram_Calling_Stubs
1372 (Vis_Decl
=> Current_Primitive_Decl
,
1374 Build_Subprogram_Id
(Loc
,
1375 Defining_Unit_Name
(Current_Primitive_Spec
)),
1376 Asynchronous
=> Possibly_Asynchronous
,
1377 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1378 Stub_Type
=> Stub_Elements
.Stub_Type
,
1379 RACW_Type
=> Stub_Elements
.RACW_Type
);
1380 Append_To
(Body_Decls
, Current_Primitive_Body
);
1382 -- Analyzing the body here would cause the Stub type to
1383 -- be frozen, thus preventing subsequent primitive
1384 -- declarations. For this reason, it will be analyzed
1385 -- later in the regular flow (and in the context of the
1386 -- appropriate unit body, see Append_RACW_Bodies).
1390 -- Build the receiver stubs
1392 if Build_Bodies
and then not Is_RAS
then
1393 Current_Receiver_Body
:=
1394 Specific_Build_Subprogram_Receiving_Stubs
1395 (Vis_Decl
=> Current_Primitive_Decl
,
1396 Asynchronous
=> Possibly_Asynchronous
,
1397 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1398 Stub_Type
=> Stub_Elements
.Stub_Type
,
1399 RACW_Type
=> Stub_Elements
.RACW_Type
,
1400 Parent_Primitive
=> Current_Primitive
);
1402 Current_Receiver
:= Defining_Unit_Name
(
1403 Specification
(Current_Receiver_Body
));
1405 Append_To
(Body_Decls
, Current_Receiver_Body
);
1407 -- Add a case alternative to the receiver
1409 if Get_PCS_Name
= Name_PolyORB_DSA
then
1410 Append_To
(RPC_Receiver_Elsif_Parts
,
1411 Make_Elsif_Part
(Loc
,
1413 Make_Function_Call
(Loc
,
1416 RTE
(RE_Caseless_String_Eq
), Loc
),
1417 Parameter_Associations
=> New_List
(
1418 New_Occurrence_Of
(RPC_Receiver_Subp_Id
, Loc
),
1419 Make_String_Literal
(Loc
, Subp_Str
))),
1421 Then_Statements
=> New_List
(
1422 Make_Assignment_Statement
(Loc
,
1423 Name
=> New_Occurrence_Of
(
1424 RPC_Receiver_Subp_Index
, Loc
),
1426 Make_Integer_Literal
(Loc
,
1427 Intval
=> Current_Primitive_Number
)))));
1430 Append_To
(RPC_Receiver_Case_Alternatives
,
1431 Make_Case_Statement_Alternative
(Loc
,
1432 Discrete_Choices
=> New_List
(
1433 Make_Integer_Literal
(Loc
, Current_Primitive_Number
)),
1435 Statements
=> New_List
(
1436 Make_Procedure_Call_Statement
(Loc
,
1438 New_Occurrence_Of
(Current_Receiver
, Loc
),
1439 Parameter_Associations
=> New_List
(
1440 New_Occurrence_Of
(RPC_Receiver_Request
, Loc
))))));
1443 -- Increment the index of current primitive
1445 Current_Primitive_Number
:= Current_Primitive_Number
+ 1;
1448 Next_Elmt
(Current_Primitive_Elmt
);
1452 -- Build the case statement and the heart of the subprogram
1454 if Build_Bodies
and then not Is_RAS
then
1455 if Get_PCS_Name
= Name_PolyORB_DSA
1456 and then Present
(First
(RPC_Receiver_Elsif_Parts
))
1458 Append_To
(RPC_Receiver_Statements
,
1459 Make_Implicit_If_Statement
(Designated_Type
,
1460 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
1461 Then_Statements
=> New_List
,
1462 Elsif_Parts
=> RPC_Receiver_Elsif_Parts
));
1465 Append_To
(RPC_Receiver_Case_Alternatives
,
1466 Make_Case_Statement_Alternative
(Loc
,
1467 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1468 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
1470 Append_To
(RPC_Receiver_Statements
,
1471 Make_Case_Statement
(Loc
,
1473 New_Occurrence_Of
(RPC_Receiver_Subp_Index
, Loc
),
1474 Alternatives
=> RPC_Receiver_Case_Alternatives
));
1476 Append_To
(Body_Decls
, RPC_Receiver_Decl
);
1477 Specific_Add_Obj_RPC_Receiver_Completion
(Loc
,
1478 Body_Decls
, RPC_Receiver
, Stub_Elements
);
1480 -- Do not analyze RPC receiver body at this stage since it references
1481 -- subprograms that have not been analyzed yet. It will be analyzed in
1482 -- the regular flow (see Append_RACW_Bodies).
1485 end Add_RACW_Primitive_Declarations_And_Bodies
;
1487 -----------------------------
1488 -- Add_RAS_Dereference_TSS --
1489 -----------------------------
1491 procedure Add_RAS_Dereference_TSS
(N
: Node_Id
) is
1492 Loc
: constant Source_Ptr
:= Sloc
(N
);
1494 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
1495 RAS_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
1496 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(RAS_Type
);
1497 RACW_Type
: constant Entity_Id
:= Underlying_RACW_Type
(RAS_Type
);
1499 RACW_Primitive_Name
: Node_Id
;
1501 Proc
: constant Entity_Id
:=
1502 Make_Defining_Identifier
(Loc
,
1503 Chars
=> Make_TSS_Name
(RAS_Type
, TSS_RAS_Dereference
));
1505 Proc_Spec
: Node_Id
;
1506 Param_Specs
: List_Id
;
1507 Param_Assoc
: constant List_Id
:= New_List
;
1508 Stmts
: constant List_Id
:= New_List
;
1510 RAS_Parameter
: constant Entity_Id
:=
1511 Make_Defining_Identifier
(Loc
,
1512 Chars
=> New_Internal_Name
('P'));
1514 Is_Function
: constant Boolean :=
1515 Nkind
(Type_Def
) = N_Access_Function_Definition
;
1517 Is_Degenerate
: Boolean;
1518 -- Set to True if the subprogram_specification for this RAS has an
1519 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1521 Spec
: constant Node_Id
:= Type_Def
;
1523 Current_Parameter
: Node_Id
;
1525 -- Start of processing for Add_RAS_Dereference_TSS
1528 -- The Dereference TSS for a remote access-to-subprogram type has the
1531 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1534 -- This is called whenever a value of a RAS type is dereferenced
1536 -- First construct a list of parameter specifications:
1538 -- The first formal is the RAS values
1540 Param_Specs
:= New_List
(
1541 Make_Parameter_Specification
(Loc
,
1542 Defining_Identifier
=> RAS_Parameter
,
1545 New_Occurrence_Of
(Fat_Type
, Loc
)));
1547 -- The following formals are copied from the type declaration
1549 Is_Degenerate
:= False;
1550 Current_Parameter
:= First
(Parameter_Specifications
(Type_Def
));
1551 Parameters
: while Present
(Current_Parameter
) loop
1552 if Nkind
(Parameter_Type
(Current_Parameter
)) =
1555 Is_Degenerate
:= True;
1558 Append_To
(Param_Specs
,
1559 Make_Parameter_Specification
(Loc
,
1560 Defining_Identifier
=>
1561 Make_Defining_Identifier
(Loc
,
1562 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))),
1563 In_Present
=> In_Present
(Current_Parameter
),
1564 Out_Present
=> Out_Present
(Current_Parameter
),
1566 New_Copy_Tree
(Parameter_Type
(Current_Parameter
)),
1568 New_Copy_Tree
(Expression
(Current_Parameter
))));
1570 Append_To
(Param_Assoc
,
1571 Make_Identifier
(Loc
,
1572 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))));
1574 Next
(Current_Parameter
);
1575 end loop Parameters
;
1577 if Is_Degenerate
then
1578 Prepend_To
(Param_Assoc
, New_Occurrence_Of
(RAS_Parameter
, Loc
));
1580 -- Generate a dummy body. This code will never actually be executed,
1581 -- because null is the only legal value for a degenerate RAS type.
1582 -- For legality's sake (in order to avoid generating a function that
1583 -- does not contain a return statement), we include a dummy recursive
1584 -- call on the TSS itself.
1587 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Explicit_Raise
));
1588 RACW_Primitive_Name
:= New_Occurrence_Of
(Proc
, Loc
);
1591 -- For a normal RAS type, we cast the RAS formal to the corresponding
1592 -- tagged type, and perform a dispatching call to its Call primitive
1595 Prepend_To
(Param_Assoc
,
1596 Unchecked_Convert_To
(RACW_Type
,
1597 New_Occurrence_Of
(RAS_Parameter
, Loc
)));
1599 RACW_Primitive_Name
:=
1600 Make_Selected_Component
(Loc
,
1601 Prefix
=> Scope
(RACW_Type
),
1602 Selector_Name
=> Name_uCall
);
1607 Make_Simple_Return_Statement
(Loc
,
1609 Make_Function_Call
(Loc
,
1610 Name
=> RACW_Primitive_Name
,
1611 Parameter_Associations
=> Param_Assoc
)));
1615 Make_Procedure_Call_Statement
(Loc
,
1616 Name
=> RACW_Primitive_Name
,
1617 Parameter_Associations
=> Param_Assoc
));
1620 -- Build the complete subprogram
1624 Make_Function_Specification
(Loc
,
1625 Defining_Unit_Name
=> Proc
,
1626 Parameter_Specifications
=> Param_Specs
,
1627 Result_Definition
=>
1629 Entity
(Result_Definition
(Spec
)), Loc
));
1631 Set_Ekind
(Proc
, E_Function
);
1633 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
1637 Make_Procedure_Specification
(Loc
,
1638 Defining_Unit_Name
=> Proc
,
1639 Parameter_Specifications
=> Param_Specs
);
1641 Set_Ekind
(Proc
, E_Procedure
);
1642 Set_Etype
(Proc
, Standard_Void_Type
);
1646 Make_Subprogram_Body
(Loc
,
1647 Specification
=> Proc_Spec
,
1648 Declarations
=> New_List
,
1649 Handled_Statement_Sequence
=>
1650 Make_Handled_Sequence_Of_Statements
(Loc
,
1651 Statements
=> Stmts
)));
1653 Set_TSS
(Fat_Type
, Proc
);
1654 end Add_RAS_Dereference_TSS
;
1656 -------------------------------
1657 -- Add_RAS_Proxy_And_Analyze --
1658 -------------------------------
1660 procedure Add_RAS_Proxy_And_Analyze
1663 All_Calls_Remote_E
: Entity_Id
;
1664 Proxy_Object_Addr
: out Entity_Id
)
1666 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
1668 Subp_Name
: constant Entity_Id
:=
1669 Defining_Unit_Name
(Specification
(Vis_Decl
));
1671 Pkg_Name
: constant Entity_Id
:=
1672 Make_Defining_Identifier
(Loc
,
1673 Chars
=> New_External_Name
(Chars
(Subp_Name
), 'P', -1));
1675 Proxy_Type
: constant Entity_Id
:=
1676 Make_Defining_Identifier
(Loc
,
1679 (Related_Id
=> Chars
(Subp_Name
),
1682 Proxy_Type_Full_View
: constant Entity_Id
:=
1683 Make_Defining_Identifier
(Loc
,
1684 Chars
(Proxy_Type
));
1686 Subp_Decl_Spec
: constant Node_Id
:=
1687 Build_RAS_Primitive_Specification
1688 (Subp_Spec
=> Specification
(Vis_Decl
),
1689 Remote_Object_Type
=> Proxy_Type
);
1691 Subp_Body_Spec
: constant Node_Id
:=
1692 Build_RAS_Primitive_Specification
1693 (Subp_Spec
=> Specification
(Vis_Decl
),
1694 Remote_Object_Type
=> Proxy_Type
);
1696 Vis_Decls
: constant List_Id
:= New_List
;
1697 Pvt_Decls
: constant List_Id
:= New_List
;
1698 Actuals
: constant List_Id
:= New_List
;
1700 Perform_Call
: Node_Id
;
1703 -- type subpP is tagged limited private;
1705 Append_To
(Vis_Decls
,
1706 Make_Private_Type_Declaration
(Loc
,
1707 Defining_Identifier
=> Proxy_Type
,
1708 Tagged_Present
=> True,
1709 Limited_Present
=> True));
1711 -- [subprogram] Call
1712 -- (Self : access subpP;
1713 -- ...other-formals...)
1716 Append_To
(Vis_Decls
,
1717 Make_Subprogram_Declaration
(Loc
,
1718 Specification
=> Subp_Decl_Spec
));
1720 -- A : constant System.Address;
1722 Proxy_Object_Addr
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1724 Append_To
(Vis_Decls
,
1725 Make_Object_Declaration
(Loc
,
1726 Defining_Identifier
=> Proxy_Object_Addr
,
1727 Constant_Present
=> True,
1728 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
1732 -- type subpP is tagged limited record
1733 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1737 Append_To
(Pvt_Decls
,
1738 Make_Full_Type_Declaration
(Loc
,
1739 Defining_Identifier
=> Proxy_Type_Full_View
,
1741 Build_Remote_Subprogram_Proxy_Type
(Loc
,
1742 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
))));
1744 -- Trick semantic analysis into swapping the public and full view when
1745 -- freezing the public view.
1747 Set_Comes_From_Source
(Proxy_Type_Full_View
, True);
1750 -- (Self : access O;
1751 -- ...other-formals...) is
1753 -- P (...other-formals...);
1757 -- (Self : access O;
1758 -- ...other-formals...)
1761 -- return F (...other-formals...);
1764 if Nkind
(Subp_Decl_Spec
) = N_Procedure_Specification
then
1766 Make_Procedure_Call_Statement
(Loc
,
1767 Name
=> New_Occurrence_Of
(Subp_Name
, Loc
),
1768 Parameter_Associations
=> Actuals
);
1771 Make_Simple_Return_Statement
(Loc
,
1773 Make_Function_Call
(Loc
,
1774 Name
=> New_Occurrence_Of
(Subp_Name
, Loc
),
1775 Parameter_Associations
=> Actuals
));
1778 Formal
:= First
(Parameter_Specifications
(Subp_Decl_Spec
));
1779 pragma Assert
(Present
(Formal
));
1782 exit when No
(Formal
);
1784 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1787 -- O : aliased subpP;
1789 Append_To
(Pvt_Decls
,
1790 Make_Object_Declaration
(Loc
,
1791 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uO
),
1792 Aliased_Present
=> True,
1793 Object_Definition
=> New_Occurrence_Of
(Proxy_Type
, Loc
)));
1795 -- A : constant System.Address := O'Address;
1797 Append_To
(Pvt_Decls
,
1798 Make_Object_Declaration
(Loc
,
1799 Defining_Identifier
=>
1800 Make_Defining_Identifier
(Loc
, Chars
(Proxy_Object_Addr
)),
1801 Constant_Present
=> True,
1802 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
1804 Make_Attribute_Reference
(Loc
,
1805 Prefix
=> New_Occurrence_Of
(
1806 Defining_Identifier
(Last
(Pvt_Decls
)), Loc
),
1807 Attribute_Name
=> Name_Address
)));
1810 Make_Package_Declaration
(Loc
,
1811 Specification
=> Make_Package_Specification
(Loc
,
1812 Defining_Unit_Name
=> Pkg_Name
,
1813 Visible_Declarations
=> Vis_Decls
,
1814 Private_Declarations
=> Pvt_Decls
,
1815 End_Label
=> Empty
)));
1816 Analyze
(Last
(Decls
));
1819 Make_Package_Body
(Loc
,
1820 Defining_Unit_Name
=>
1821 Make_Defining_Identifier
(Loc
, Chars
(Pkg_Name
)),
1822 Declarations
=> New_List
(
1823 Make_Subprogram_Body
(Loc
,
1824 Specification
=> Subp_Body_Spec
,
1825 Declarations
=> New_List
,
1826 Handled_Statement_Sequence
=>
1827 Make_Handled_Sequence_Of_Statements
(Loc
,
1828 Statements
=> New_List
(Perform_Call
))))));
1829 Analyze
(Last
(Decls
));
1830 end Add_RAS_Proxy_And_Analyze
;
1832 -----------------------
1833 -- Add_RAST_Features --
1834 -----------------------
1836 procedure Add_RAST_Features
(Vis_Decl
: Node_Id
) is
1837 RAS_Type
: constant Entity_Id
:=
1838 Equivalent_Type
(Defining_Identifier
(Vis_Decl
));
1840 pragma Assert
(No
(TSS
(RAS_Type
, TSS_RAS_Access
)));
1841 Add_RAS_Dereference_TSS
(Vis_Decl
);
1842 Specific_Add_RAST_Features
(Vis_Decl
, RAS_Type
);
1843 end Add_RAST_Features
;
1849 procedure Add_Stub_Type
1850 (Designated_Type
: Entity_Id
;
1851 RACW_Type
: Entity_Id
;
1853 Stub_Type
: out Entity_Id
;
1854 Stub_Type_Access
: out Entity_Id
;
1855 RPC_Receiver_Decl
: out Node_Id
;
1856 Body_Decls
: out List_Id
;
1857 Existing
: out Boolean)
1859 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1861 Stub_Elements
: constant Stub_Structure
:=
1862 Stubs_Table
.Get
(Designated_Type
);
1863 Stub_Type_Decl
: Node_Id
;
1864 Stub_Type_Access_Decl
: Node_Id
;
1867 if Stub_Elements
/= Empty_Stub_Structure
then
1868 Stub_Type
:= Stub_Elements
.Stub_Type
;
1869 Stub_Type_Access
:= Stub_Elements
.Stub_Type_Access
;
1870 RPC_Receiver_Decl
:= Stub_Elements
.RPC_Receiver_Decl
;
1871 Body_Decls
:= Stub_Elements
.Body_Decls
;
1878 Make_Defining_Identifier
(Loc
,
1879 Chars
=> New_Internal_Name
('S'));
1880 Set_Ekind
(Stub_Type
, E_Record_Type
);
1881 Set_Is_RACW_Stub_Type
(Stub_Type
);
1883 Make_Defining_Identifier
(Loc
,
1884 Chars
=> New_External_Name
1885 (Related_Id
=> Chars
(Stub_Type
), Suffix
=> 'A'));
1887 Specific_Build_Stub_Type
1888 (RACW_Type
, Stub_Type
,
1889 Stub_Type_Decl
, RPC_Receiver_Decl
);
1891 Stub_Type_Access_Decl
:=
1892 Make_Full_Type_Declaration
(Loc
,
1893 Defining_Identifier
=> Stub_Type_Access
,
1895 Make_Access_To_Object_Definition
(Loc
,
1896 All_Present
=> True,
1897 Subtype_Indication
=> New_Occurrence_Of
(Stub_Type
, Loc
)));
1899 Append_To
(Decls
, Stub_Type_Decl
);
1900 Analyze
(Last
(Decls
));
1901 Append_To
(Decls
, Stub_Type_Access_Decl
);
1902 Analyze
(Last
(Decls
));
1904 -- This is in no way a type derivation, but we fake it to make sure that
1905 -- the dispatching table gets built with the corresponding primitive
1906 -- operations at the right place.
1908 Derive_Subprograms
(Parent_Type
=> Designated_Type
,
1909 Derived_Type
=> Stub_Type
);
1911 if Present
(RPC_Receiver_Decl
) then
1912 Append_To
(Decls
, RPC_Receiver_Decl
);
1914 RPC_Receiver_Decl
:= Last
(Decls
);
1917 Body_Decls
:= New_List
;
1919 Stubs_Table
.Set
(Designated_Type
,
1920 (Stub_Type
=> Stub_Type
,
1921 Stub_Type_Access
=> Stub_Type_Access
,
1922 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1923 Body_Decls
=> Body_Decls
,
1924 RACW_Type
=> RACW_Type
));
1927 ------------------------
1928 -- Append_RACW_Bodies --
1929 ------------------------
1931 procedure Append_RACW_Bodies
(Decls
: List_Id
; Spec_Id
: Entity_Id
) is
1934 E
:= First_Entity
(Spec_Id
);
1935 while Present
(E
) loop
1936 if Is_Remote_Access_To_Class_Wide_Type
(E
) then
1937 Append_List_To
(Decls
, Get_And_Reset_RACW_Bodies
(E
));
1942 end Append_RACW_Bodies
;
1944 ----------------------------------
1945 -- Assign_Subprogram_Identifier --
1946 ----------------------------------
1948 procedure Assign_Subprogram_Identifier
1953 N
: constant Name_Id
:= Chars
(Def
);
1955 Overload_Order
: constant Int
:=
1956 Overload_Counter_Table
.Get
(N
) + 1;
1959 Overload_Counter_Table
.Set
(N
, Overload_Order
);
1961 Get_Name_String
(N
);
1963 -- Homonym handling: as in Exp_Dbug, but much simpler,
1964 -- because the only entities for which we have to generate
1965 -- names here need only to be disambiguated within their
1968 if Overload_Order
> 1 then
1969 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 2) := "__";
1970 Name_Len
:= Name_Len
+ 2;
1971 Add_Nat_To_Name_Buffer
(Overload_Order
);
1974 Id
:= String_From_Name_Buffer
;
1975 Subprogram_Identifier_Table
.Set
(Def
,
1976 Subprogram_Identifiers
'(Str_Identifier => Id, Int_Identifier => Spn));
1977 end Assign_Subprogram_Identifier;
1979 -------------------------------------
1980 -- Build_Actual_Object_Declaration --
1981 -------------------------------------
1983 procedure Build_Actual_Object_Declaration
1984 (Object : Entity_Id;
1990 Loc : constant Source_Ptr := Sloc (Object);
1992 -- Declare a temporary object for the actual, possibly initialized with
1993 -- a 'Input
/From_Any call
.
1995 -- Complication arises in the case of limited types, for which such a
1996 -- declaration is illegal in Ada 95. In that case, we first generate a
1997 -- renaming declaration of the 'Input call, and then if needed we
1998 -- generate an overlaid non-constant view.
2000 if Ada_Version
<= Ada_95
2001 and then Is_Limited_Type
(Etyp
)
2002 and then Present
(Expr
)
2005 -- Object : Etyp renames <func-call>
2008 Make_Object_Renaming_Declaration
(Loc
,
2009 Defining_Identifier
=> Object
,
2010 Subtype_Mark
=> New_Occurrence_Of
(Etyp
, Loc
),
2015 -- The name defined by the renaming declaration denotes a
2016 -- constant view; create a non-constant object at the same address
2017 -- to be used as the actual.
2020 Constant_Object
: constant Entity_Id
:=
2021 Make_Defining_Identifier
(Loc
,
2022 New_Internal_Name
('P'));
2024 Set_Defining_Identifier
2025 (Last
(Decls
), Constant_Object
);
2027 -- We have an unconstrained Etyp: build the actual constrained
2028 -- subtype for the value we just read from the stream.
2030 -- subtype S is <actual subtype of Constant_Object>;
2033 Build_Actual_Subtype
(Etyp
,
2034 New_Occurrence_Of
(Constant_Object
, Loc
)));
2039 Make_Object_Declaration
(Loc
,
2040 Defining_Identifier
=> Object
,
2041 Object_Definition
=>
2043 (Defining_Identifier
(Last
(Decls
)), Loc
)));
2044 Set_Ekind
(Object
, E_Variable
);
2046 -- Suppress default initialization:
2047 -- pragma Import (Ada, Object);
2051 Chars
=> Name_Import
,
2052 Pragma_Argument_Associations
=> New_List
(
2053 Make_Pragma_Argument_Association
(Loc
,
2054 Chars
=> Name_Convention
,
2055 Expression
=> Make_Identifier
(Loc
, Name_Ada
)),
2056 Make_Pragma_Argument_Association
(Loc
,
2057 Chars
=> Name_Entity
,
2058 Expression
=> New_Occurrence_Of
(Object
, Loc
)))));
2060 -- for Object'Address use Constant_Object'Address;
2063 Make_Attribute_Definition_Clause
(Loc
,
2064 Name
=> New_Occurrence_Of
(Object
, Loc
),
2065 Chars
=> Name_Address
,
2067 Make_Attribute_Reference
(Loc
,
2068 Prefix
=> New_Occurrence_Of
(Constant_Object
, Loc
),
2069 Attribute_Name
=> Name_Address
)));
2075 -- General case of a regular object declaration. Object is flagged
2076 -- constant unless it has mode out or in out, to allow the backend
2077 -- to optimize where possible.
2079 -- Object : [constant] Etyp [:= <expr>];
2082 Make_Object_Declaration
(Loc
,
2083 Defining_Identifier
=> Object
,
2084 Constant_Present
=> Present
(Expr
) and then not Variable
,
2085 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
2086 Expression
=> Expr
));
2088 if Constant_Present
(Last
(Decls
)) then
2089 Set_Ekind
(Object
, E_Constant
);
2091 Set_Ekind
(Object
, E_Variable
);
2094 end Build_Actual_Object_Declaration
;
2096 ------------------------------
2097 -- Build_Get_Unique_RP_Call --
2098 ------------------------------
2100 function Build_Get_Unique_RP_Call
2102 Pointer
: Entity_Id
;
2103 Stub_Type
: Entity_Id
) return List_Id
2107 Make_Procedure_Call_Statement
(Loc
,
2109 New_Occurrence_Of
(RTE
(RE_Get_Unique_Remote_Pointer
), Loc
),
2110 Parameter_Associations
=> New_List
(
2111 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2112 New_Occurrence_Of
(Pointer
, Loc
)))),
2114 Make_Assignment_Statement
(Loc
,
2116 Make_Selected_Component
(Loc
,
2117 Prefix
=> New_Occurrence_Of
(Pointer
, Loc
),
2119 New_Occurrence_Of
(First_Tag_Component
2120 (Designated_Type
(Etype
(Pointer
))), Loc
)),
2122 Make_Attribute_Reference
(Loc
,
2123 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
2124 Attribute_Name
=> Name_Tag
)));
2126 -- Note: The assignment to Pointer._Tag is safe here because
2127 -- we carefully ensured that Stub_Type has exactly the same layout
2128 -- as System.Partition_Interface.RACW_Stub_Type.
2130 end Build_Get_Unique_RP_Call
;
2132 -----------------------------------
2133 -- Build_Ordered_Parameters_List --
2134 -----------------------------------
2136 function Build_Ordered_Parameters_List
(Spec
: Node_Id
) return List_Id
is
2137 Constrained_List
: List_Id
;
2138 Unconstrained_List
: List_Id
;
2139 Current_Parameter
: Node_Id
;
2142 First_Parameter
: Node_Id
;
2143 For_RAS
: Boolean := False;
2146 if No
(Parameter_Specifications
(Spec
)) then
2150 Constrained_List
:= New_List
;
2151 Unconstrained_List
:= New_List
;
2152 First_Parameter
:= First
(Parameter_Specifications
(Spec
));
2154 if Nkind
(Parameter_Type
(First_Parameter
)) = N_Access_Definition
2155 and then Chars
(Defining_Identifier
(First_Parameter
)) = Name_uS
2160 -- Loop through the parameters and add them to the right list. Note that
2161 -- we treat a parameter of a null-excluding access type as unconstrained
2162 -- because we can't declare an object of such a type with default
2165 Current_Parameter
:= First_Parameter
;
2166 while Present
(Current_Parameter
) loop
2167 Ptyp
:= Parameter_Type
(Current_Parameter
);
2169 if (Nkind
(Ptyp
) = N_Access_Definition
2170 or else not Transmit_As_Unconstrained
(Etype
(Ptyp
)))
2171 and then not (For_RAS
and then Current_Parameter
= First_Parameter
)
2173 Append_To
(Constrained_List
, New_Copy
(Current_Parameter
));
2175 Append_To
(Unconstrained_List
, New_Copy
(Current_Parameter
));
2178 Next
(Current_Parameter
);
2181 -- Unconstrained parameters are returned first
2183 Append_List_To
(Unconstrained_List
, Constrained_List
);
2185 return Unconstrained_List
;
2186 end Build_Ordered_Parameters_List
;
2188 ----------------------------------
2189 -- Build_Passive_Partition_Stub --
2190 ----------------------------------
2192 procedure Build_Passive_Partition_Stub
(U
: Node_Id
) is
2194 Pkg_Name
: String_Id
;
2197 Loc
: constant Source_Ptr
:= Sloc
(U
);
2200 -- Verify that the implementation supports distribution, by accessing
2201 -- a type defined in the proper version of system.rpc
2204 Dist_OK
: Entity_Id
;
2205 pragma Warnings
(Off
, Dist_OK
);
2207 Dist_OK
:= RTE
(RE_Params_Stream_Type
);
2210 -- Use body if present, spec otherwise
2212 if Nkind
(U
) = N_Package_Declaration
then
2213 Pkg_Spec
:= Specification
(U
);
2214 L
:= Visible_Declarations
(Pkg_Spec
);
2216 Pkg_Spec
:= Parent
(Corresponding_Spec
(U
));
2217 L
:= Declarations
(U
);
2220 Get_Library_Unit_Name_String
(Pkg_Spec
);
2221 Pkg_Name
:= String_From_Name_Buffer
;
2223 Make_Procedure_Call_Statement
(Loc
,
2225 New_Occurrence_Of
(RTE
(RE_Register_Passive_Package
), Loc
),
2226 Parameter_Associations
=> New_List
(
2227 Make_String_Literal
(Loc
, Pkg_Name
),
2228 Make_Attribute_Reference
(Loc
,
2230 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
2231 Attribute_Name
=> Name_Version
)));
2234 end Build_Passive_Partition_Stub
;
2236 --------------------------------------
2237 -- Build_RPC_Receiver_Specification --
2238 --------------------------------------
2240 function Build_RPC_Receiver_Specification
2241 (RPC_Receiver
: Entity_Id
;
2242 Request_Parameter
: Entity_Id
) return Node_Id
2244 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
2247 Make_Procedure_Specification
(Loc
,
2248 Defining_Unit_Name
=> RPC_Receiver
,
2249 Parameter_Specifications
=> New_List
(
2250 Make_Parameter_Specification
(Loc
,
2251 Defining_Identifier
=> Request_Parameter
,
2253 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
2254 end Build_RPC_Receiver_Specification
;
2256 ----------------------------------------
2257 -- Build_Remote_Subprogram_Proxy_Type --
2258 ----------------------------------------
2260 function Build_Remote_Subprogram_Proxy_Type
2262 ACR_Expression
: Node_Id
) return Node_Id
2266 Make_Record_Definition
(Loc
,
2267 Tagged_Present
=> True,
2268 Limited_Present
=> True,
2270 Make_Component_List
(Loc
,
2272 Component_Items
=> New_List
(
2273 Make_Component_Declaration
(Loc
,
2274 Defining_Identifier
=>
2275 Make_Defining_Identifier
(Loc
,
2276 Name_All_Calls_Remote
),
2277 Component_Definition
=>
2278 Make_Component_Definition
(Loc
,
2279 Subtype_Indication
=>
2280 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
2284 Make_Component_Declaration
(Loc
,
2285 Defining_Identifier
=>
2286 Make_Defining_Identifier
(Loc
,
2288 Component_Definition
=>
2289 Make_Component_Definition
(Loc
,
2290 Subtype_Indication
=>
2291 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2293 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)),
2295 Make_Component_Declaration
(Loc
,
2296 Defining_Identifier
=>
2297 Make_Defining_Identifier
(Loc
,
2299 Component_Definition
=>
2300 Make_Component_Definition
(Loc
,
2301 Subtype_Indication
=>
2302 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))))));
2303 end Build_Remote_Subprogram_Proxy_Type
;
2305 --------------------
2306 -- Build_Stub_Tag --
2307 --------------------
2309 function Build_Stub_Tag
2311 RACW_Type
: Entity_Id
) return Node_Id
2313 Stub_Type
: constant Entity_Id
:= Corresponding_Stub_Type
(RACW_Type
);
2316 Make_Attribute_Reference
(Loc
,
2317 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
2318 Attribute_Name
=> Name_Tag
);
2321 ------------------------------------
2322 -- Build_Subprogram_Calling_Stubs --
2323 ------------------------------------
2325 function Build_Subprogram_Calling_Stubs
2326 (Vis_Decl
: Node_Id
;
2328 Asynchronous
: Boolean;
2329 Dynamically_Asynchronous
: Boolean := False;
2330 Stub_Type
: Entity_Id
:= Empty
;
2331 RACW_Type
: Entity_Id
:= Empty
;
2332 Locator
: Entity_Id
:= Empty
;
2333 New_Name
: Name_Id
:= No_Name
) return Node_Id
2335 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
2337 Decls
: constant List_Id
:= New_List
;
2338 Statements
: constant List_Id
:= New_List
;
2340 Subp_Spec
: Node_Id
;
2341 -- The specification of the body
2343 Controlling_Parameter
: Entity_Id
:= Empty
;
2345 Asynchronous_Expr
: Node_Id
:= Empty
;
2347 RCI_Locator
: Entity_Id
;
2349 Spec_To_Use
: Node_Id
;
2351 procedure Insert_Partition_Check
(Parameter
: Node_Id
);
2352 -- Check that the parameter has been elaborated on the same partition
2353 -- than the controlling parameter (E.4(19)).
2355 ----------------------------
2356 -- Insert_Partition_Check --
2357 ----------------------------
2359 procedure Insert_Partition_Check
(Parameter
: Node_Id
) is
2360 Parameter_Entity
: constant Entity_Id
:=
2361 Defining_Identifier
(Parameter
);
2363 -- The expression that will be built is of the form:
2365 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2366 -- raise Constraint_Error;
2369 -- We do not check that Parameter is in Stub_Type since such a check
2370 -- has been inserted at the point of call already (a tag check since
2371 -- we have multiple controlling operands).
2374 Make_Raise_Constraint_Error
(Loc
,
2378 Make_Function_Call
(Loc
,
2380 New_Occurrence_Of
(RTE
(RE_Same_Partition
), Loc
),
2381 Parameter_Associations
=>
2383 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2384 New_Occurrence_Of
(Parameter_Entity
, Loc
)),
2385 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2386 New_Occurrence_Of
(Controlling_Parameter
, Loc
))))),
2387 Reason
=> CE_Partition_Check_Failed
));
2388 end Insert_Partition_Check
;
2390 -- Start of processing for Build_Subprogram_Calling_Stubs
2393 Subp_Spec
:= Copy_Specification
(Loc
,
2394 Spec
=> Specification
(Vis_Decl
),
2395 New_Name
=> New_Name
);
2397 if Locator
= Empty
then
2398 RCI_Locator
:= RCI_Cache
;
2399 Spec_To_Use
:= Specification
(Vis_Decl
);
2401 RCI_Locator
:= Locator
;
2402 Spec_To_Use
:= Subp_Spec
;
2405 -- Find a controlling argument if we have a stub type. Also check
2406 -- if this subprogram can be made asynchronous.
2408 if Present
(Stub_Type
)
2409 and then Present
(Parameter_Specifications
(Spec_To_Use
))
2412 Current_Parameter
: Node_Id
:=
2413 First
(Parameter_Specifications
2416 while Present
(Current_Parameter
) loop
2418 Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
)
2420 if Controlling_Parameter
= Empty
then
2421 Controlling_Parameter
:=
2422 Defining_Identifier
(Current_Parameter
);
2424 Insert_Partition_Check
(Current_Parameter
);
2428 Next
(Current_Parameter
);
2433 pragma Assert
(No
(Stub_Type
) or else Present
(Controlling_Parameter
));
2435 if Dynamically_Asynchronous
then
2436 Asynchronous_Expr
:= Make_Selected_Component
(Loc
,
2437 Prefix
=> Controlling_Parameter
,
2438 Selector_Name
=> Name_Asynchronous
);
2441 Specific_Build_General_Calling_Stubs
2443 Statements
=> Statements
,
2444 Target
=> Specific_Build_Stub_Target
(Loc
,
2445 Decls
, RCI_Locator
, Controlling_Parameter
),
2446 Subprogram_Id
=> Subp_Id
,
2447 Asynchronous
=> Asynchronous_Expr
,
2448 Is_Known_Asynchronous
=> Asynchronous
2449 and then not Dynamically_Asynchronous
,
2450 Is_Known_Non_Asynchronous
2452 and then not Dynamically_Asynchronous
,
2453 Is_Function
=> Nkind
(Spec_To_Use
) =
2454 N_Function_Specification
,
2455 Spec
=> Spec_To_Use
,
2456 Stub_Type
=> Stub_Type
,
2457 RACW_Type
=> RACW_Type
,
2460 RCI_Calling_Stubs_Table
.Set
2461 (Defining_Unit_Name
(Specification
(Vis_Decl
)),
2462 Defining_Unit_Name
(Spec_To_Use
));
2465 Make_Subprogram_Body
(Loc
,
2466 Specification
=> Subp_Spec
,
2467 Declarations
=> Decls
,
2468 Handled_Statement_Sequence
=>
2469 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
));
2470 end Build_Subprogram_Calling_Stubs
;
2472 -------------------------
2473 -- Build_Subprogram_Id --
2474 -------------------------
2476 function Build_Subprogram_Id
2478 E
: Entity_Id
) return Node_Id
2481 if Get_Subprogram_Ids
(E
).Str_Identifier
= No_String
then
2483 Current_Declaration
: Node_Id
;
2484 Current_Subp
: Entity_Id
;
2485 Current_Subp_Str
: String_Id
;
2486 Current_Subp_Number
: Int
:= First_RCI_Subprogram_Id
;
2488 pragma Warnings
(Off
, Current_Subp_Str
);
2491 -- Build_Subprogram_Id is called outside of the context of
2492 -- generating calling or receiving stubs. Hence we are processing
2493 -- an 'Access attribute_reference for an RCI subprogram, for the
2494 -- purpose of obtaining a RAS value.
2497 (Is_Remote_Call_Interface
(Scope
(E
))
2499 (Nkind
(Parent
(E
)) = N_Procedure_Specification
2501 Nkind
(Parent
(E
)) = N_Function_Specification
));
2503 Current_Declaration
:=
2504 First
(Visible_Declarations
2505 (Package_Specification_Of_Scope
(Scope
(E
))));
2506 while Present
(Current_Declaration
) loop
2507 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
2508 and then Comes_From_Source
(Current_Declaration
)
2510 Current_Subp
:= Defining_Unit_Name
(Specification
(
2511 Current_Declaration
));
2513 Assign_Subprogram_Identifier
2514 (Current_Subp
, Current_Subp_Number
, Current_Subp_Str
);
2516 Current_Subp_Number
:= Current_Subp_Number
+ 1;
2519 Next
(Current_Declaration
);
2524 case Get_PCS_Name
is
2525 when Name_PolyORB_DSA
=>
2526 return Make_String_Literal
(Loc
, Get_Subprogram_Id
(E
));
2528 return Make_Integer_Literal
(Loc
, Get_Subprogram_Id
(E
));
2530 end Build_Subprogram_Id
;
2532 ------------------------
2533 -- Copy_Specification --
2534 ------------------------
2536 function Copy_Specification
2539 Ctrl_Type
: Entity_Id
:= Empty
;
2540 New_Name
: Name_Id
:= No_Name
) return Node_Id
2542 Parameters
: List_Id
:= No_List
;
2544 Current_Parameter
: Node_Id
;
2545 Current_Identifier
: Entity_Id
;
2546 Current_Type
: Node_Id
;
2548 Name_For_New_Spec
: Name_Id
;
2550 New_Identifier
: Entity_Id
;
2552 -- Comments needed in body below ???
2555 if New_Name
= No_Name
then
2556 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
2557 or else Nkind
(Spec
) = N_Procedure_Specification
);
2559 Name_For_New_Spec
:= Chars
(Defining_Unit_Name
(Spec
));
2561 Name_For_New_Spec
:= New_Name
;
2564 if Present
(Parameter_Specifications
(Spec
)) then
2565 Parameters
:= New_List
;
2566 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2567 while Present
(Current_Parameter
) loop
2568 Current_Identifier
:= Defining_Identifier
(Current_Parameter
);
2569 Current_Type
:= Parameter_Type
(Current_Parameter
);
2571 if Nkind
(Current_Type
) = N_Access_Definition
then
2572 if Present
(Ctrl_Type
) then
2573 pragma Assert
(Is_Controlling_Formal
(Current_Identifier
));
2575 Make_Access_Definition
(Loc
,
2576 Subtype_Mark
=> New_Occurrence_Of
(Ctrl_Type
, Loc
),
2577 Null_Exclusion_Present
=>
2578 Null_Exclusion_Present
(Current_Type
));
2582 Make_Access_Definition
(Loc
,
2584 New_Copy_Tree
(Subtype_Mark
(Current_Type
)),
2585 Null_Exclusion_Present
=>
2586 Null_Exclusion_Present
(Current_Type
));
2590 if Present
(Ctrl_Type
)
2591 and then Is_Controlling_Formal
(Current_Identifier
)
2593 Current_Type
:= New_Occurrence_Of
(Ctrl_Type
, Loc
);
2595 Current_Type
:= New_Copy_Tree
(Current_Type
);
2599 New_Identifier
:= Make_Defining_Identifier
(Loc
,
2600 Chars
(Current_Identifier
));
2602 Append_To
(Parameters
,
2603 Make_Parameter_Specification
(Loc
,
2604 Defining_Identifier
=> New_Identifier
,
2605 Parameter_Type
=> Current_Type
,
2606 In_Present
=> In_Present
(Current_Parameter
),
2607 Out_Present
=> Out_Present
(Current_Parameter
),
2609 New_Copy_Tree
(Expression
(Current_Parameter
))));
2611 -- For a regular formal parameter (that needs to be marshalled
2612 -- in the context of remote calls), set the Etype now, because
2613 -- marshalling processing might need it.
2615 if Is_Entity_Name
(Current_Type
) then
2616 Set_Etype
(New_Identifier
, Entity
(Current_Type
));
2618 -- Current_Type is an access definition, special processing
2619 -- (not requiring etype) will occur for marshalling.
2625 Next
(Current_Parameter
);
2629 case Nkind
(Spec
) is
2631 when N_Function_Specification | N_Access_Function_Definition
=>
2633 Make_Function_Specification
(Loc
,
2634 Defining_Unit_Name
=>
2635 Make_Defining_Identifier
(Loc
,
2636 Chars
=> Name_For_New_Spec
),
2637 Parameter_Specifications
=> Parameters
,
2638 Result_Definition
=>
2639 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
2641 when N_Procedure_Specification | N_Access_Procedure_Definition
=>
2643 Make_Procedure_Specification
(Loc
,
2644 Defining_Unit_Name
=>
2645 Make_Defining_Identifier
(Loc
,
2646 Chars
=> Name_For_New_Spec
),
2647 Parameter_Specifications
=> Parameters
);
2650 raise Program_Error
;
2652 end Copy_Specification
;
2654 -----------------------------
2655 -- Corresponding_Stub_Type --
2656 -----------------------------
2658 function Corresponding_Stub_Type
(RACW_Type
: Entity_Id
) return Entity_Id
is
2659 Desig
: constant Entity_Id
:=
2660 Etype
(Designated_Type
(RACW_Type
));
2661 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
2663 return Stub_Elements
.Stub_Type
;
2664 end Corresponding_Stub_Type
;
2666 ---------------------------
2667 -- Could_Be_Asynchronous --
2668 ---------------------------
2670 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean is
2671 Current_Parameter
: Node_Id
;
2674 if Present
(Parameter_Specifications
(Spec
)) then
2675 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2676 while Present
(Current_Parameter
) loop
2677 if Out_Present
(Current_Parameter
) then
2681 Next
(Current_Parameter
);
2686 end Could_Be_Asynchronous
;
2688 ---------------------------
2689 -- Declare_Create_NVList --
2690 ---------------------------
2692 procedure Declare_Create_NVList
2700 Make_Object_Declaration
(Loc
,
2701 Defining_Identifier
=> NVList
,
2702 Aliased_Present
=> False,
2703 Object_Definition
=>
2704 New_Occurrence_Of
(RTE
(RE_NVList_Ref
), Loc
)));
2707 Make_Procedure_Call_Statement
(Loc
,
2708 Name
=> New_Occurrence_Of
(RTE
(RE_NVList_Create
), Loc
),
2709 Parameter_Associations
=> New_List
(
2710 New_Occurrence_Of
(NVList
, Loc
))));
2711 end Declare_Create_NVList
;
2713 ---------------------------------------------
2714 -- Expand_All_Calls_Remote_Subprogram_Call --
2715 ---------------------------------------------
2717 procedure Expand_All_Calls_Remote_Subprogram_Call
(N
: Node_Id
) is
2718 Called_Subprogram
: constant Entity_Id
:= Entity
(Name
(N
));
2719 RCI_Package
: constant Entity_Id
:= Scope
(Called_Subprogram
);
2720 Loc
: constant Source_Ptr
:= Sloc
(N
);
2721 RCI_Locator
: Node_Id
;
2722 RCI_Cache
: Entity_Id
;
2723 Calling_Stubs
: Node_Id
;
2724 E_Calling_Stubs
: Entity_Id
;
2727 E_Calling_Stubs
:= RCI_Calling_Stubs_Table
.Get
(Called_Subprogram
);
2729 if E_Calling_Stubs
= Empty
then
2730 RCI_Cache
:= RCI_Locator_Table
.Get
(RCI_Package
);
2732 if RCI_Cache
= Empty
then
2735 (Loc
, Specification
(Unit_Declaration_Node
(RCI_Package
)));
2736 Prepend_To
(Current_Sem_Unit_Declarations
, RCI_Locator
);
2738 -- The RCI_Locator package is inserted at the top level in the
2739 -- current unit, and must appear in the proper scope, so that it
2740 -- is not prematurely removed by the GCC back-end.
2743 Scop
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
2746 if Ekind
(Scop
) = E_Package_Body
then
2747 Push_Scope
(Spec_Entity
(Scop
));
2749 elsif Ekind
(Scop
) = E_Subprogram_Body
then
2751 (Corresponding_Spec
(Unit_Declaration_Node
(Scop
)));
2757 Analyze
(RCI_Locator
);
2761 RCI_Cache
:= Defining_Unit_Name
(RCI_Locator
);
2764 RCI_Locator
:= Parent
(RCI_Cache
);
2767 Calling_Stubs
:= Build_Subprogram_Calling_Stubs
2768 (Vis_Decl
=> Parent
(Parent
(Called_Subprogram
)),
2770 Build_Subprogram_Id
(Loc
, Called_Subprogram
),
2771 Asynchronous
=> Nkind
(N
) = N_Procedure_Call_Statement
2773 Is_Asynchronous
(Called_Subprogram
),
2774 Locator
=> RCI_Cache
,
2775 New_Name
=> New_Internal_Name
('S'));
2776 Insert_After
(RCI_Locator
, Calling_Stubs
);
2777 Analyze
(Calling_Stubs
);
2778 E_Calling_Stubs
:= Defining_Unit_Name
(Specification
(Calling_Stubs
));
2781 Rewrite
(Name
(N
), New_Occurrence_Of
(E_Calling_Stubs
, Loc
));
2782 end Expand_All_Calls_Remote_Subprogram_Call
;
2784 ---------------------------------
2785 -- Expand_Calling_Stubs_Bodies --
2786 ---------------------------------
2788 procedure Expand_Calling_Stubs_Bodies
(Unit_Node
: Node_Id
) is
2789 Spec
: constant Node_Id
:= Specification
(Unit_Node
);
2790 Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
2792 Push_Scope
(Scope_Of_Spec
(Spec
));
2793 Add_Calling_Stubs_To_Declarations
2794 (Specification
(Unit_Node
), Decls
);
2796 end Expand_Calling_Stubs_Bodies
;
2798 -----------------------------------
2799 -- Expand_Receiving_Stubs_Bodies --
2800 -----------------------------------
2802 procedure Expand_Receiving_Stubs_Bodies
(Unit_Node
: Node_Id
) is
2805 Stubs_Decls
: List_Id
;
2806 Stubs_Stmts
: List_Id
;
2809 if Nkind
(Unit_Node
) = N_Package_Declaration
then
2810 Spec
:= Specification
(Unit_Node
);
2811 Decls
:= Private_Declarations
(Spec
);
2814 Decls
:= Visible_Declarations
(Spec
);
2817 Push_Scope
(Scope_Of_Spec
(Spec
));
2818 Specific_Add_Receiving_Stubs_To_Declarations
(Spec
, Decls
, Decls
);
2822 Package_Specification_Of_Scope
(Corresponding_Spec
(Unit_Node
));
2823 Decls
:= Declarations
(Unit_Node
);
2825 Push_Scope
(Scope_Of_Spec
(Unit_Node
));
2826 Stubs_Decls
:= New_List
;
2827 Stubs_Stmts
:= New_List
;
2828 Specific_Add_Receiving_Stubs_To_Declarations
2829 (Spec
, Stubs_Decls
, Stubs_Stmts
);
2831 Insert_List_Before
(First
(Decls
), Stubs_Decls
);
2834 HSS_Stmts
: constant List_Id
:=
2835 Statements
(Handled_Statement_Sequence
(Unit_Node
));
2837 First_HSS_Stmt
: constant Node_Id
:= First
(HSS_Stmts
);
2840 if No
(First_HSS_Stmt
) then
2841 Append_List_To
(HSS_Stmts
, Stubs_Stmts
);
2843 Insert_List_Before
(First_HSS_Stmt
, Stubs_Stmts
);
2849 end Expand_Receiving_Stubs_Bodies
;
2851 --------------------
2852 -- GARLIC_Support --
2853 --------------------
2855 package body GARLIC_Support
is
2857 -- Local subprograms
2859 procedure Add_RACW_Read_Attribute
2860 (RACW_Type
: Entity_Id
;
2861 Stub_Type
: Entity_Id
;
2862 Stub_Type_Access
: Entity_Id
;
2863 Body_Decls
: List_Id
);
2864 -- Add Read attribute for the RACW type. The declaration and attribute
2865 -- definition clauses are inserted right after the declaration of
2866 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2867 -- appended to it (case where the RACW declaration is in the main unit).
2869 procedure Add_RACW_Write_Attribute
2870 (RACW_Type
: Entity_Id
;
2871 Stub_Type
: Entity_Id
;
2872 Stub_Type_Access
: Entity_Id
;
2873 RPC_Receiver
: Node_Id
;
2874 Body_Decls
: List_Id
);
2875 -- Same as above for the Write attribute
2877 function Stream_Parameter
return Node_Id
;
2878 function Result
return Node_Id
;
2879 function Object
return Node_Id
renames Result
;
2880 -- Functions to create occurrences of the formal parameter names of the
2881 -- 'Read and 'Write attributes.
2884 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2885 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2887 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
2888 -- Add a subprogram body for RAS Access TSS
2890 -------------------------------------
2891 -- Add_Obj_RPC_Receiver_Completion --
2892 -------------------------------------
2894 procedure Add_Obj_RPC_Receiver_Completion
2897 RPC_Receiver
: Entity_Id
;
2898 Stub_Elements
: Stub_Structure
)
2901 -- The RPC receiver body should not be the completion of the
2902 -- declaration recorded in the stub structure, because then the
2903 -- occurrences of the formal parameters within the body should refer
2904 -- to the entities from the declaration, not from the completion, to
2905 -- which we do not have easy access. Instead, the RPC receiver body
2906 -- acts as its own declaration, and the RPC receiver declaration is
2907 -- completed by a renaming-as-body.
2910 Make_Subprogram_Renaming_Declaration
(Loc
,
2912 Copy_Specification
(Loc
,
2913 Specification
(Stub_Elements
.RPC_Receiver_Decl
)),
2914 Name
=> New_Occurrence_Of
(RPC_Receiver
, Loc
)));
2915 end Add_Obj_RPC_Receiver_Completion
;
2917 -----------------------
2918 -- Add_RACW_Features --
2919 -----------------------
2921 procedure Add_RACW_Features
2922 (RACW_Type
: Entity_Id
;
2923 Stub_Type
: Entity_Id
;
2924 Stub_Type_Access
: Entity_Id
;
2925 RPC_Receiver_Decl
: Node_Id
;
2926 Body_Decls
: List_Id
)
2928 RPC_Receiver
: Node_Id
;
2929 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
2932 Loc
:= Sloc
(RACW_Type
);
2936 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2937 -- of the corresponding distributed object type. We retrieve its
2938 -- address from the local proxy object.
2940 RPC_Receiver
:= Make_Selected_Component
(Loc
,
2942 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
), Object
),
2943 Selector_Name
=> Make_Identifier
(Loc
, Name_Receiver
));
2946 RPC_Receiver
:= Make_Attribute_Reference
(Loc
,
2947 Prefix
=> New_Occurrence_Of
(
2948 Defining_Unit_Name
(Specification
(RPC_Receiver_Decl
)), Loc
),
2949 Attribute_Name
=> Name_Address
);
2952 Add_RACW_Write_Attribute
2959 Add_RACW_Read_Attribute
2964 end Add_RACW_Features
;
2966 -----------------------------
2967 -- Add_RACW_Read_Attribute --
2968 -----------------------------
2970 procedure Add_RACW_Read_Attribute
2971 (RACW_Type
: Entity_Id
;
2972 Stub_Type
: Entity_Id
;
2973 Stub_Type_Access
: Entity_Id
;
2974 Body_Decls
: List_Id
)
2976 Proc_Decl
: Node_Id
;
2977 Attr_Decl
: Node_Id
;
2979 Body_Node
: Node_Id
;
2981 Statements
: constant List_Id
:= New_List
;
2983 Local_Statements
: List_Id
;
2984 Remote_Statements
: List_Id
;
2985 -- Various parts of the procedure
2987 Pnam
: constant Entity_Id
:=
2988 Make_Defining_Identifier
2989 (Loc
, New_Internal_Name
('R'));
2990 Asynchronous_Flag
: constant Entity_Id
:=
2991 Asynchronous_Flags_Table
.Get
(RACW_Type
);
2992 pragma Assert
(Present
(Asynchronous_Flag
));
2994 -- Prepare local identifiers
2996 Source_Partition
: Entity_Id
;
2997 Source_Receiver
: Entity_Id
;
2998 Source_Address
: Entity_Id
;
2999 Local_Stub
: Entity_Id
;
3000 Stubbed_Result
: Entity_Id
;
3002 -- Start of processing for Add_RACW_Read_Attribute
3005 Build_Stream_Procedure
(Loc
,
3006 RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> True);
3007 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
3008 Copy_Specification
(Loc
, Specification
(Body_Node
)));
3011 Make_Attribute_Definition_Clause
(Loc
,
3012 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
3016 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
3018 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
3019 Insert_After
(Proc_Decl
, Attr_Decl
);
3021 if No
(Body_Decls
) then
3023 -- Case of processing an RACW type from another unit than the
3024 -- main one: do not generate a body.
3029 -- Prepare local identifiers
3032 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
3034 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
3036 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
3038 Make_Defining_Identifier
(Loc
, New_Internal_Name
('L'));
3040 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
3042 -- Generate object declarations
3045 Make_Object_Declaration
(Loc
,
3046 Defining_Identifier
=> Source_Partition
,
3047 Object_Definition
=>
3048 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
)),
3050 Make_Object_Declaration
(Loc
,
3051 Defining_Identifier
=> Source_Receiver
,
3052 Object_Definition
=>
3053 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3055 Make_Object_Declaration
(Loc
,
3056 Defining_Identifier
=> Source_Address
,
3057 Object_Definition
=>
3058 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3060 Make_Object_Declaration
(Loc
,
3061 Defining_Identifier
=> Local_Stub
,
3062 Aliased_Present
=> True,
3063 Object_Definition
=> New_Occurrence_Of
(Stub_Type
, Loc
)),
3065 Make_Object_Declaration
(Loc
,
3066 Defining_Identifier
=> Stubbed_Result
,
3067 Object_Definition
=>
3068 New_Occurrence_Of
(Stub_Type_Access
, Loc
),
3070 Make_Attribute_Reference
(Loc
,
3072 New_Occurrence_Of
(Local_Stub
, Loc
),
3074 Name_Unchecked_Access
)));
3076 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3078 Append_List_To
(Statements
, New_List
(
3079 Make_Attribute_Reference
(Loc
,
3081 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3082 Attribute_Name
=> Name_Read
,
3083 Expressions
=> New_List
(
3085 New_Occurrence_Of
(Source_Partition
, Loc
))),
3087 Make_Attribute_Reference
(Loc
,
3089 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3092 Expressions
=> New_List
(
3094 New_Occurrence_Of
(Source_Receiver
, Loc
))),
3096 Make_Attribute_Reference
(Loc
,
3098 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3101 Expressions
=> New_List
(
3103 New_Occurrence_Of
(Source_Address
, Loc
)))));
3105 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3107 Set_Etype
(Stubbed_Result
, Stub_Type_Access
);
3109 -- If the Address is Null_Address, then return a null object, unless
3110 -- RACW_Type is null-excluding, in which case unconditionally raise
3111 -- CONSTRAINT_ERROR instead.
3114 Zero_Statements
: List_Id
;
3115 -- Statements executed when a zero value is received
3118 if Can_Never_Be_Null
(RACW_Type
) then
3119 Zero_Statements
:= New_List
(
3120 Make_Raise_Constraint_Error
(Loc
,
3121 Reason
=> CE_Null_Not_Allowed
));
3123 Zero_Statements
:= New_List
(
3124 Make_Assignment_Statement
(Loc
,
3126 Expression
=> Make_Null
(Loc
)),
3127 Make_Simple_Return_Statement
(Loc
));
3130 Append_To
(Statements
,
3131 Make_Implicit_If_Statement
(RACW_Type
,
3134 Left_Opnd
=> New_Occurrence_Of
(Source_Address
, Loc
),
3135 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
3136 Then_Statements
=> Zero_Statements
));
3139 -- If the RACW denotes an object created on the current partition,
3140 -- Local_Statements will be executed. The real object will be used.
3142 Local_Statements
:= New_List
(
3143 Make_Assignment_Statement
(Loc
,
3146 Unchecked_Convert_To
(RACW_Type
,
3147 OK_Convert_To
(RTE
(RE_Address
),
3148 New_Occurrence_Of
(Source_Address
, Loc
)))));
3150 -- If the object is located on another partition, then a stub object
3151 -- will be created with all the information needed to rebuild the
3152 -- real object at the other end.
3154 Remote_Statements
:= New_List
(
3156 Make_Assignment_Statement
(Loc
,
3157 Name
=> Make_Selected_Component
(Loc
,
3158 Prefix
=> Stubbed_Result
,
3159 Selector_Name
=> Name_Origin
),
3161 New_Occurrence_Of
(Source_Partition
, Loc
)),
3163 Make_Assignment_Statement
(Loc
,
3164 Name
=> Make_Selected_Component
(Loc
,
3165 Prefix
=> Stubbed_Result
,
3166 Selector_Name
=> Name_Receiver
),
3168 New_Occurrence_Of
(Source_Receiver
, Loc
)),
3170 Make_Assignment_Statement
(Loc
,
3171 Name
=> Make_Selected_Component
(Loc
,
3172 Prefix
=> Stubbed_Result
,
3173 Selector_Name
=> Name_Addr
),
3175 New_Occurrence_Of
(Source_Address
, Loc
)));
3177 Append_To
(Remote_Statements
,
3178 Make_Assignment_Statement
(Loc
,
3179 Name
=> Make_Selected_Component
(Loc
,
3180 Prefix
=> Stubbed_Result
,
3181 Selector_Name
=> Name_Asynchronous
),
3183 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)));
3185 Append_List_To
(Remote_Statements
,
3186 Build_Get_Unique_RP_Call
(Loc
, Stubbed_Result
, Stub_Type
));
3187 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3188 -- set on the stub type if, and only if, the RACW type has a pragma
3189 -- Asynchronous. This is incorrect for RACWs that implement RAS
3190 -- types, because in that case the /designated subprogram/ (not the
3191 -- type) might be asynchronous, and that causes the stub to need to
3192 -- be asynchronous too. A solution is to transport a RAS as a struct
3193 -- containing a RACW and an asynchronous flag, and to properly alter
3194 -- the Asynchronous component in the stub type in the RAS's Input
3197 Append_To
(Remote_Statements
,
3198 Make_Assignment_Statement
(Loc
,
3200 Expression
=> Unchecked_Convert_To
(RACW_Type
,
3201 New_Occurrence_Of
(Stubbed_Result
, Loc
))));
3203 -- Distinguish between the local and remote cases, and execute the
3204 -- appropriate piece of code.
3206 Append_To
(Statements
,
3207 Make_Implicit_If_Statement
(RACW_Type
,
3211 Make_Function_Call
(Loc
,
3212 Name
=> New_Occurrence_Of
(
3213 RTE
(RE_Get_Local_Partition_Id
), Loc
)),
3214 Right_Opnd
=> New_Occurrence_Of
(Source_Partition
, Loc
)),
3215 Then_Statements
=> Local_Statements
,
3216 Else_Statements
=> Remote_Statements
));
3218 Set_Declarations
(Body_Node
, Decls
);
3219 Append_To
(Body_Decls
, Body_Node
);
3220 end Add_RACW_Read_Attribute
;
3222 ------------------------------
3223 -- Add_RACW_Write_Attribute --
3224 ------------------------------
3226 procedure Add_RACW_Write_Attribute
3227 (RACW_Type
: Entity_Id
;
3228 Stub_Type
: Entity_Id
;
3229 Stub_Type_Access
: Entity_Id
;
3230 RPC_Receiver
: Node_Id
;
3231 Body_Decls
: List_Id
)
3233 Body_Node
: Node_Id
;
3234 Proc_Decl
: Node_Id
;
3235 Attr_Decl
: Node_Id
;
3237 Statements
: constant List_Id
:= New_List
;
3238 Local_Statements
: List_Id
;
3239 Remote_Statements
: List_Id
;
3240 Null_Statements
: List_Id
;
3242 Pnam
: constant Entity_Id
:=
3243 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
3246 Build_Stream_Procedure
3247 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> False);
3249 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
3250 Copy_Specification
(Loc
, Specification
(Body_Node
)));
3253 Make_Attribute_Definition_Clause
(Loc
,
3254 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
3255 Chars
=> Name_Write
,
3258 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
3260 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
3261 Insert_After
(Proc_Decl
, Attr_Decl
);
3263 if No
(Body_Decls
) then
3267 -- Build the code fragment corresponding to the marshalling of a
3270 Local_Statements
:= New_List
(
3272 Pack_Entity_Into_Stream_Access
(Loc
,
3273 Stream
=> Stream_Parameter
,
3274 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
3276 Pack_Node_Into_Stream_Access
(Loc
,
3277 Stream
=> Stream_Parameter
,
3278 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
), RPC_Receiver
),
3279 Etyp
=> RTE
(RE_Unsigned_64
)),
3281 Pack_Node_Into_Stream_Access
(Loc
,
3282 Stream
=> Stream_Parameter
,
3283 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
),
3284 Make_Attribute_Reference
(Loc
,
3286 Make_Explicit_Dereference
(Loc
,
3288 Attribute_Name
=> Name_Address
)),
3289 Etyp
=> RTE
(RE_Unsigned_64
)));
3291 -- Build the code fragment corresponding to the marshalling of
3294 Remote_Statements
:= New_List
(
3295 Pack_Node_Into_Stream_Access
(Loc
,
3296 Stream
=> Stream_Parameter
,
3298 Make_Selected_Component
(Loc
,
3300 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3301 Selector_Name
=> Make_Identifier
(Loc
, Name_Origin
)),
3302 Etyp
=> RTE
(RE_Partition_ID
)),
3304 Pack_Node_Into_Stream_Access
(Loc
,
3305 Stream
=> Stream_Parameter
,
3307 Make_Selected_Component
(Loc
,
3309 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3310 Selector_Name
=> Make_Identifier
(Loc
, Name_Receiver
)),
3311 Etyp
=> RTE
(RE_Unsigned_64
)),
3313 Pack_Node_Into_Stream_Access
(Loc
,
3314 Stream
=> Stream_Parameter
,
3316 Make_Selected_Component
(Loc
,
3318 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3319 Selector_Name
=> Make_Identifier
(Loc
, Name_Addr
)),
3320 Etyp
=> RTE
(RE_Unsigned_64
)));
3322 -- Build code fragment corresponding to marshalling of a null object
3324 Null_Statements
:= New_List
(
3326 Pack_Entity_Into_Stream_Access
(Loc
,
3327 Stream
=> Stream_Parameter
,
3328 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
3330 Pack_Node_Into_Stream_Access
(Loc
,
3331 Stream
=> Stream_Parameter
,
3332 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
), RPC_Receiver
),
3333 Etyp
=> RTE
(RE_Unsigned_64
)),
3335 Pack_Node_Into_Stream_Access
(Loc
,
3336 Stream
=> Stream_Parameter
,
3337 Object
=> Make_Integer_Literal
(Loc
, Uint_0
),
3338 Etyp
=> RTE
(RE_Unsigned_64
)));
3340 Append_To
(Statements
,
3341 Make_Implicit_If_Statement
(RACW_Type
,
3344 Left_Opnd
=> Object
,
3345 Right_Opnd
=> Make_Null
(Loc
)),
3347 Then_Statements
=> Null_Statements
,
3349 Elsif_Parts
=> New_List
(
3350 Make_Elsif_Part
(Loc
,
3354 Make_Attribute_Reference
(Loc
,
3356 Attribute_Name
=> Name_Tag
),
3359 Make_Attribute_Reference
(Loc
,
3360 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
3361 Attribute_Name
=> Name_Tag
)),
3362 Then_Statements
=> Remote_Statements
)),
3363 Else_Statements
=> Local_Statements
));
3365 Append_To
(Body_Decls
, Body_Node
);
3366 end Add_RACW_Write_Attribute
;
3368 ------------------------
3369 -- Add_RAS_Access_TSS --
3370 ------------------------
3372 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
3373 Loc
: constant Source_Ptr
:= Sloc
(N
);
3375 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
3376 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
3377 -- Ras_Type is the access to subprogram type while Fat_Type is the
3378 -- corresponding record type.
3380 RACW_Type
: constant Entity_Id
:=
3381 Underlying_RACW_Type
(Ras_Type
);
3382 Desig
: constant Entity_Id
:=
3383 Etype
(Designated_Type
(RACW_Type
));
3385 Stub_Elements
: constant Stub_Structure
:=
3386 Stubs_Table
.Get
(Desig
);
3387 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
3389 Proc
: constant Entity_Id
:=
3390 Make_Defining_Identifier
(Loc
,
3391 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
3393 Proc_Spec
: Node_Id
;
3395 -- Formal parameters
3397 Package_Name
: constant Entity_Id
:=
3398 Make_Defining_Identifier
(Loc
,
3402 Subp_Id
: constant Entity_Id
:=
3403 Make_Defining_Identifier
(Loc
,
3405 -- Target subprogram
3407 Asynch_P
: constant Entity_Id
:=
3408 Make_Defining_Identifier
(Loc
,
3409 Chars
=> Name_Asynchronous
);
3410 -- Is the procedure to which the 'Access applies asynchronous?
3412 All_Calls_Remote
: constant Entity_Id
:=
3413 Make_Defining_Identifier
(Loc
,
3414 Chars
=> Name_All_Calls_Remote
);
3415 -- True if an All_Calls_Remote pragma applies to the RCI unit
3416 -- that contains the subprogram.
3418 -- Common local variables
3420 Proc_Decls
: List_Id
;
3421 Proc_Statements
: List_Id
;
3423 Origin
: constant Entity_Id
:=
3424 Make_Defining_Identifier
(Loc
,
3425 Chars
=> New_Internal_Name
('P'));
3427 -- Additional local variables for the local case
3429 Proxy_Addr
: constant Entity_Id
:=
3430 Make_Defining_Identifier
(Loc
,
3431 Chars
=> New_Internal_Name
('P'));
3433 -- Additional local variables for the remote case
3435 Local_Stub
: constant Entity_Id
:=
3436 Make_Defining_Identifier
(Loc
,
3437 Chars
=> New_Internal_Name
('L'));
3439 Stub_Ptr
: constant Entity_Id
:=
3440 Make_Defining_Identifier
(Loc
,
3441 Chars
=> New_Internal_Name
('S'));
3444 (Field_Name
: Name_Id
;
3445 Value
: Node_Id
) return Node_Id
;
3446 -- Construct an assignment that sets the named component in the
3454 (Field_Name
: Name_Id
;
3455 Value
: Node_Id
) return Node_Id
3459 Make_Assignment_Statement
(Loc
,
3461 Make_Selected_Component
(Loc
,
3463 Selector_Name
=> Field_Name
),
3464 Expression
=> Value
);
3467 -- Start of processing for Add_RAS_Access_TSS
3470 Proc_Decls
:= New_List
(
3472 -- Common declarations
3474 Make_Object_Declaration
(Loc
,
3475 Defining_Identifier
=> Origin
,
3476 Constant_Present
=> True,
3477 Object_Definition
=>
3478 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3480 Make_Function_Call
(Loc
,
3482 New_Occurrence_Of
(RTE
(RE_Get_Active_Partition_Id
), Loc
),
3483 Parameter_Associations
=> New_List
(
3484 New_Occurrence_Of
(Package_Name
, Loc
)))),
3486 -- Declaration use only in the local case: proxy address
3488 Make_Object_Declaration
(Loc
,
3489 Defining_Identifier
=> Proxy_Addr
,
3490 Object_Definition
=>
3491 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3493 -- Declarations used only in the remote case: stub object and
3496 Make_Object_Declaration
(Loc
,
3497 Defining_Identifier
=> Local_Stub
,
3498 Aliased_Present
=> True,
3499 Object_Definition
=>
3500 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
3502 Make_Object_Declaration
(Loc
,
3503 Defining_Identifier
=>
3505 Object_Definition
=>
3506 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
3508 Make_Attribute_Reference
(Loc
,
3509 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
3510 Attribute_Name
=> Name_Unchecked_Access
)));
3512 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
3514 -- Build_Get_Unique_RP_Call needs above information
3516 -- Note: Here we assume that the Fat_Type is a record
3517 -- containing just a pointer to a proxy or stub object.
3519 Proc_Statements
:= New_List
(
3523 -- Get_RAS_Info (Pkg, Subp, PA);
3524 -- if Origin = Local_Partition_Id
3525 -- and then not All_Calls_Remote
3527 -- return Fat_Type!(PA);
3530 Make_Procedure_Call_Statement
(Loc
,
3531 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
3532 Parameter_Associations
=> New_List
(
3533 New_Occurrence_Of
(Package_Name
, Loc
),
3534 New_Occurrence_Of
(Subp_Id
, Loc
),
3535 New_Occurrence_Of
(Proxy_Addr
, Loc
))),
3537 Make_Implicit_If_Statement
(N
,
3543 New_Occurrence_Of
(Origin
, Loc
),
3545 Make_Function_Call
(Loc
,
3547 RTE
(RE_Get_Local_Partition_Id
), Loc
))),
3551 New_Occurrence_Of
(All_Calls_Remote
, Loc
))),
3553 Then_Statements
=> New_List
(
3554 Make_Simple_Return_Statement
(Loc
,
3555 Unchecked_Convert_To
(Fat_Type
,
3556 OK_Convert_To
(RTE
(RE_Address
),
3557 New_Occurrence_Of
(Proxy_Addr
, Loc
)))))),
3559 Set_Field
(Name_Origin
,
3560 New_Occurrence_Of
(Origin
, Loc
)),
3562 Set_Field
(Name_Receiver
,
3563 Make_Function_Call
(Loc
,
3565 New_Occurrence_Of
(RTE
(RE_Get_RCI_Package_Receiver
), Loc
),
3566 Parameter_Associations
=> New_List
(
3567 New_Occurrence_Of
(Package_Name
, Loc
)))),
3569 Set_Field
(Name_Addr
, New_Occurrence_Of
(Proxy_Addr
, Loc
)),
3571 -- E.4.1(9) A remote call is asynchronous if it is a call to
3572 -- a procedure or a call through a value of an access-to-procedure
3573 -- type to which a pragma Asynchronous applies.
3575 -- Asynch_P is true when the procedure is asynchronous;
3576 -- Asynch_T is true when the type is asynchronous.
3578 Set_Field
(Name_Asynchronous
,
3580 New_Occurrence_Of
(Asynch_P
, Loc
),
3581 New_Occurrence_Of
(Boolean_Literals
(
3582 Is_Asynchronous
(Ras_Type
)), Loc
))));
3584 Append_List_To
(Proc_Statements
,
3585 Build_Get_Unique_RP_Call
3586 (Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
3588 -- Return the newly created value
3590 Append_To
(Proc_Statements
,
3591 Make_Simple_Return_Statement
(Loc
,
3593 Unchecked_Convert_To
(Fat_Type
,
3594 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
3597 Make_Function_Specification
(Loc
,
3598 Defining_Unit_Name
=> Proc
,
3599 Parameter_Specifications
=> New_List
(
3600 Make_Parameter_Specification
(Loc
,
3601 Defining_Identifier
=> Package_Name
,
3603 New_Occurrence_Of
(Standard_String
, Loc
)),
3605 Make_Parameter_Specification
(Loc
,
3606 Defining_Identifier
=> Subp_Id
,
3608 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
)),
3610 Make_Parameter_Specification
(Loc
,
3611 Defining_Identifier
=> Asynch_P
,
3613 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3615 Make_Parameter_Specification
(Loc
,
3616 Defining_Identifier
=> All_Calls_Remote
,
3618 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
3620 Result_Definition
=>
3621 New_Occurrence_Of
(Fat_Type
, Loc
));
3623 -- Set the kind and return type of the function to prevent
3624 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3626 Set_Ekind
(Proc
, E_Function
);
3627 Set_Etype
(Proc
, Fat_Type
);
3630 Make_Subprogram_Body
(Loc
,
3631 Specification
=> Proc_Spec
,
3632 Declarations
=> Proc_Decls
,
3633 Handled_Statement_Sequence
=>
3634 Make_Handled_Sequence_Of_Statements
(Loc
,
3635 Statements
=> Proc_Statements
)));
3637 Set_TSS
(Fat_Type
, Proc
);
3638 end Add_RAS_Access_TSS
;
3640 -----------------------
3641 -- Add_RAST_Features --
3642 -----------------------
3644 procedure Add_RAST_Features
3645 (Vis_Decl
: Node_Id
;
3646 RAS_Type
: Entity_Id
)
3648 pragma Unreferenced
(RAS_Type
);
3650 Add_RAS_Access_TSS
(Vis_Decl
);
3651 end Add_RAST_Features
;
3653 -----------------------------------------
3654 -- Add_Receiving_Stubs_To_Declarations --
3655 -----------------------------------------
3657 procedure Add_Receiving_Stubs_To_Declarations
3658 (Pkg_Spec
: Node_Id
;
3662 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
3664 Request_Parameter
: Node_Id
;
3666 Pkg_RPC_Receiver
: constant Entity_Id
:=
3667 Make_Defining_Identifier
(Loc
,
3668 New_Internal_Name
('H'));
3669 Pkg_RPC_Receiver_Statements
: List_Id
;
3670 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
3671 Pkg_RPC_Receiver_Body
: Node_Id
;
3672 -- A Pkg_RPC_Receiver is built to decode the request
3674 Lookup_RAS_Info
: constant Entity_Id
:=
3675 Make_Defining_Identifier
(Loc
,
3676 Chars
=> New_Internal_Name
('R'));
3677 -- A remote subprogram is created to allow peers to look up
3678 -- RAS information using subprogram ids.
3680 Subp_Id
: Entity_Id
;
3681 Subp_Index
: Entity_Id
;
3682 -- Subprogram_Id as read from the incoming stream
3684 Current_Declaration
: Node_Id
;
3685 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
3686 Current_Stubs
: Node_Id
;
3688 Subp_Info_Array
: constant Entity_Id
:=
3689 Make_Defining_Identifier
(Loc
,
3690 Chars
=> New_Internal_Name
('I'));
3692 Subp_Info_List
: constant List_Id
:= New_List
;
3694 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
3696 All_Calls_Remote_E
: Entity_Id
;
3697 Proxy_Object_Addr
: Entity_Id
;
3699 procedure Append_Stubs_To
3700 (RPC_Receiver_Cases
: List_Id
;
3702 Subprogram_Number
: Int
);
3703 -- Add one case to the specified RPC receiver case list
3704 -- associating Subprogram_Number with the subprogram declared
3705 -- by Declaration, for which we have receiving stubs in Stubs.
3707 ---------------------
3708 -- Append_Stubs_To --
3709 ---------------------
3711 procedure Append_Stubs_To
3712 (RPC_Receiver_Cases
: List_Id
;
3714 Subprogram_Number
: Int
)
3717 Append_To
(RPC_Receiver_Cases
,
3718 Make_Case_Statement_Alternative
(Loc
,
3720 New_List
(Make_Integer_Literal
(Loc
, Subprogram_Number
)),
3723 Make_Procedure_Call_Statement
(Loc
,
3725 New_Occurrence_Of
(Defining_Entity
(Stubs
), Loc
),
3726 Parameter_Associations
=> New_List
(
3727 New_Occurrence_Of
(Request_Parameter
, Loc
))))));
3728 end Append_Stubs_To
;
3730 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3733 -- Building receiving stubs consist in several operations:
3735 -- - a package RPC receiver must be built. This subprogram
3736 -- will get a Subprogram_Id from the incoming stream
3737 -- and will dispatch the call to the right subprogram;
3739 -- - a receiving stub for each subprogram visible in the package
3740 -- spec. This stub will read all the parameters from the stream,
3741 -- and put the result as well as the exception occurrence in the
3744 -- - a dummy package with an empty spec and a body made of an
3745 -- elaboration part, whose job is to register the receiving
3746 -- part of this RCI package on the name server. This is done
3747 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3749 Build_RPC_Receiver_Body
(
3750 RPC_Receiver
=> Pkg_RPC_Receiver
,
3751 Request
=> Request_Parameter
,
3753 Subp_Index
=> Subp_Index
,
3754 Stmts
=> Pkg_RPC_Receiver_Statements
,
3755 Decl
=> Pkg_RPC_Receiver_Body
);
3756 pragma Assert
(Subp_Id
= Subp_Index
);
3758 -- A null subp_id denotes a call through a RAS, in which case the
3759 -- next Uint_64 element in the stream is the address of the local
3760 -- proxy object, from which we can retrieve the actual subprogram id.
3762 Append_To
(Pkg_RPC_Receiver_Statements
,
3763 Make_Implicit_If_Statement
(Pkg_Spec
,
3766 New_Occurrence_Of
(Subp_Id
, Loc
),
3767 Make_Integer_Literal
(Loc
, 0)),
3769 Then_Statements
=> New_List
(
3770 Make_Assignment_Statement
(Loc
,
3772 New_Occurrence_Of
(Subp_Id
, Loc
),
3775 Make_Selected_Component
(Loc
,
3777 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
3778 OK_Convert_To
(RTE
(RE_Address
),
3779 Make_Attribute_Reference
(Loc
,
3781 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3784 Expressions
=> New_List
(
3785 Make_Selected_Component
(Loc
,
3786 Prefix
=> Request_Parameter
,
3787 Selector_Name
=> Name_Params
))))),
3790 Make_Identifier
(Loc
, Name_Subp_Id
))))));
3792 -- Build a subprogram for RAS information lookups
3794 Current_Declaration
:=
3795 Make_Subprogram_Declaration
(Loc
,
3797 Make_Function_Specification
(Loc
,
3798 Defining_Unit_Name
=>
3800 Parameter_Specifications
=> New_List
(
3801 Make_Parameter_Specification
(Loc
,
3802 Defining_Identifier
=>
3803 Make_Defining_Identifier
(Loc
, Name_Subp_Id
),
3807 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))),
3808 Result_Definition
=>
3809 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)));
3811 Append_To
(Decls
, Current_Declaration
);
3812 Analyze
(Current_Declaration
);
3814 Current_Stubs
:= Build_Subprogram_Receiving_Stubs
3815 (Vis_Decl
=> Current_Declaration
,
3816 Asynchronous
=> False);
3817 Append_To
(Decls
, Current_Stubs
);
3818 Analyze
(Current_Stubs
);
3820 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3823 Subprogram_Number
=> 1);
3825 -- For each subprogram, the receiving stub will be built and a
3826 -- case statement will be made on the Subprogram_Id to dispatch
3827 -- to the right subprogram.
3829 All_Calls_Remote_E
:=
3831 (Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
3833 Overload_Counter_Table
.Reset
;
3835 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
3836 while Present
(Current_Declaration
) loop
3837 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
3838 and then Comes_From_Source
(Current_Declaration
)
3841 Loc
: constant Source_Ptr
:= Sloc
(Current_Declaration
);
3842 -- While specifically processing Current_Declaration, use
3843 -- its Sloc as the location of all generated nodes.
3845 Subp_Def
: constant Entity_Id
:=
3847 (Specification
(Current_Declaration
));
3849 Subp_Val
: String_Id
;
3850 pragma Warnings
(Off
, Subp_Val
);
3853 -- Build receiving stub
3856 Build_Subprogram_Receiving_Stubs
3857 (Vis_Decl
=> Current_Declaration
,
3859 Nkind
(Specification
(Current_Declaration
)) =
3860 N_Procedure_Specification
3861 and then Is_Asynchronous
(Subp_Def
));
3863 Append_To
(Decls
, Current_Stubs
);
3864 Analyze
(Current_Stubs
);
3868 Add_RAS_Proxy_And_Analyze
(Decls
,
3869 Vis_Decl
=> Current_Declaration
,
3870 All_Calls_Remote_E
=> All_Calls_Remote_E
,
3871 Proxy_Object_Addr
=> Proxy_Object_Addr
);
3873 -- Compute distribution identifier
3875 Assign_Subprogram_Identifier
3877 Current_Subprogram_Number
,
3881 (Current_Subprogram_Number
= Get_Subprogram_Id
(Subp_Def
));
3883 -- Add subprogram descriptor (RCI_Subp_Info) to the
3884 -- subprograms table for this receiver. The aggregate
3885 -- below must be kept consistent with the declaration
3886 -- of type RCI_Subp_Info in System.Partition_Interface.
3888 Append_To
(Subp_Info_List
,
3889 Make_Component_Association
(Loc
,
3890 Choices
=> New_List
(
3891 Make_Integer_Literal
(Loc
,
3892 Current_Subprogram_Number
)),
3895 Make_Aggregate
(Loc
,
3896 Component_Associations
=> New_List
(
3897 Make_Component_Association
(Loc
,
3898 Choices
=> New_List
(
3899 Make_Identifier
(Loc
, Name_Addr
)),
3902 Proxy_Object_Addr
, Loc
))))));
3904 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3905 Stubs
=> Current_Stubs
,
3906 Subprogram_Number
=> Current_Subprogram_Number
);
3909 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
3912 Next
(Current_Declaration
);
3915 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3916 -- rather than raising an exception since we do not want someone
3917 -- to crash a remote partition by sending invalid subprogram ids.
3918 -- This is consistent with the other parts of the case statement
3919 -- since even in presence of incorrect parameters in the stream,
3920 -- every exception will be caught and (if the subprogram is not an
3921 -- APC) put into the result stream and sent away.
3923 Append_To
(Pkg_RPC_Receiver_Cases
,
3924 Make_Case_Statement_Alternative
(Loc
,
3925 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
3926 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
3928 Append_To
(Pkg_RPC_Receiver_Statements
,
3929 Make_Case_Statement
(Loc
,
3930 Expression
=> New_Occurrence_Of
(Subp_Id
, Loc
),
3931 Alternatives
=> Pkg_RPC_Receiver_Cases
));
3934 Make_Object_Declaration
(Loc
,
3935 Defining_Identifier
=> Subp_Info_Array
,
3936 Constant_Present
=> True,
3937 Aliased_Present
=> True,
3938 Object_Definition
=>
3939 Make_Subtype_Indication
(Loc
,
3941 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
3943 Make_Index_Or_Discriminant_Constraint
(Loc
,
3946 Low_Bound
=> Make_Integer_Literal
(Loc
,
3947 First_RCI_Subprogram_Id
),
3949 Make_Integer_Literal
(Loc
,
3951 First_RCI_Subprogram_Id
3952 + List_Length
(Subp_Info_List
) - 1)))))));
3954 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
3955 -- has zero length, and the declaration is for an empty array, in
3956 -- which case no initialization aggregate must be generated.
3958 if Present
(First
(Subp_Info_List
)) then
3959 Set_Expression
(Last
(Decls
),
3960 Make_Aggregate
(Loc
,
3961 Component_Associations
=> Subp_Info_List
));
3963 -- No initialization provided: remove CONSTANT so that the
3964 -- declaration is not an incomplete deferred constant.
3967 Set_Constant_Present
(Last
(Decls
), False);
3970 Analyze
(Last
(Decls
));
3973 Subp_Info_Addr
: Node_Id
;
3974 -- Return statement for Lookup_RAS_Info: address of the subprogram
3975 -- information record for the requested subprogram id.
3978 if Present
(First
(Subp_Info_List
)) then
3980 Make_Selected_Component
(Loc
,
3982 Make_Indexed_Component
(Loc
,
3983 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3984 Expressions
=> New_List
(
3985 Convert_To
(Standard_Integer
,
3986 Make_Identifier
(Loc
, Name_Subp_Id
)))),
3987 Selector_Name
=> Make_Identifier
(Loc
, Name_Addr
));
3989 -- Case of no visible subprogram: just raise Constraint_Error, we
3990 -- know for sure we got junk from a remote partition.
3994 Make_Raise_Constraint_Error
(Loc
,
3995 Reason
=> CE_Range_Check_Failed
);
3996 Set_Etype
(Subp_Info_Addr
, RTE
(RE_Unsigned_64
));
4000 Make_Subprogram_Body
(Loc
,
4002 Copy_Specification
(Loc
, Parent
(Lookup_RAS_Info
)),
4003 Declarations
=> No_List
,
4004 Handled_Statement_Sequence
=>
4005 Make_Handled_Sequence_Of_Statements
(Loc
,
4006 Statements
=> New_List
(
4007 Make_Simple_Return_Statement
(Loc
,
4010 (RTE
(RE_Unsigned_64
), Subp_Info_Addr
))))));
4013 Analyze
(Last
(Decls
));
4015 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
4016 Analyze
(Last
(Decls
));
4018 Get_Library_Unit_Name_String
(Pkg_Spec
);
4022 Append_To
(Register_Pkg_Actuals
,
4023 Make_String_Literal
(Loc
,
4024 Strval
=> String_From_Name_Buffer
));
4028 Append_To
(Register_Pkg_Actuals
,
4029 Make_Attribute_Reference
(Loc
,
4030 Prefix
=> New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
4031 Attribute_Name
=> Name_Unrestricted_Access
));
4035 Append_To
(Register_Pkg_Actuals
,
4036 Make_Attribute_Reference
(Loc
,
4038 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
4039 Attribute_Name
=> Name_Version
));
4043 Append_To
(Register_Pkg_Actuals
,
4044 Make_Attribute_Reference
(Loc
,
4045 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
4046 Attribute_Name
=> Name_Address
));
4050 Append_To
(Register_Pkg_Actuals
,
4051 Make_Attribute_Reference
(Loc
,
4052 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
4053 Attribute_Name
=> Name_Length
));
4055 -- Generate the call
4058 Make_Procedure_Call_Statement
(Loc
,
4060 New_Occurrence_Of
(RTE
(RE_Register_Receiving_Stub
), Loc
),
4061 Parameter_Associations
=> Register_Pkg_Actuals
));
4062 Analyze
(Last
(Stmts
));
4063 end Add_Receiving_Stubs_To_Declarations
;
4065 ---------------------------------
4066 -- Build_General_Calling_Stubs --
4067 ---------------------------------
4069 procedure Build_General_Calling_Stubs
4071 Statements
: List_Id
;
4072 Target_Partition
: Entity_Id
;
4073 Target_RPC_Receiver
: Node_Id
;
4074 Subprogram_Id
: Node_Id
;
4075 Asynchronous
: Node_Id
:= Empty
;
4076 Is_Known_Asynchronous
: Boolean := False;
4077 Is_Known_Non_Asynchronous
: Boolean := False;
4078 Is_Function
: Boolean;
4080 Stub_Type
: Entity_Id
:= Empty
;
4081 RACW_Type
: Entity_Id
:= Empty
;
4084 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
4086 Stream_Parameter
: Node_Id
;
4087 -- Name of the stream used to transmit parameters to the
4090 Result_Parameter
: Node_Id
;
4091 -- Name of the result parameter (in non-APC cases) which get the
4092 -- result of the remote subprogram.
4094 Exception_Return_Parameter
: Node_Id
;
4095 -- Name of the parameter which will hold the exception sent by the
4096 -- remote subprogram.
4098 Current_Parameter
: Node_Id
;
4099 -- Current parameter being handled
4101 Ordered_Parameters_List
: constant List_Id
:=
4102 Build_Ordered_Parameters_List
(Spec
);
4104 Asynchronous_Statements
: List_Id
:= No_List
;
4105 Non_Asynchronous_Statements
: List_Id
:= No_List
;
4106 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4108 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4109 -- List of statements for extra formal parameters. It will appear
4110 -- after the regular statements for writing out parameters.
4112 pragma Unreferenced
(RACW_Type
);
4113 -- Used only for the PolyORB case
4116 -- The general form of a calling stub for a given subprogram is:
4118 -- procedure X (...) is P : constant Partition_ID :=
4119 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4120 -- System.RPC.Params_Stream_Type (0); begin
4121 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4122 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4123 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4124 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4126 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4128 -- There are some variations: Do_APC is called for an asynchronous
4129 -- procedure and the part after the call is completely ommitted as
4130 -- well as the declaration of Result. For a function call, 'Input is
4131 -- always used to read the result even if it is constrained.
4134 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
4137 Make_Object_Declaration
(Loc
,
4138 Defining_Identifier
=> Stream_Parameter
,
4139 Aliased_Present
=> True,
4140 Object_Definition
=>
4141 Make_Subtype_Indication
(Loc
,
4143 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
4145 Make_Index_Or_Discriminant_Constraint
(Loc
,
4147 New_List
(Make_Integer_Literal
(Loc
, 0))))));
4149 if not Is_Known_Asynchronous
then
4151 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4154 Make_Object_Declaration
(Loc
,
4155 Defining_Identifier
=> Result_Parameter
,
4156 Aliased_Present
=> True,
4157 Object_Definition
=>
4158 Make_Subtype_Indication
(Loc
,
4160 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
4162 Make_Index_Or_Discriminant_Constraint
(Loc
,
4164 New_List
(Make_Integer_Literal
(Loc
, 0))))));
4166 Exception_Return_Parameter
:=
4167 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
4170 Make_Object_Declaration
(Loc
,
4171 Defining_Identifier
=> Exception_Return_Parameter
,
4172 Object_Definition
=>
4173 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
4176 Result_Parameter
:= Empty
;
4177 Exception_Return_Parameter
:= Empty
;
4180 -- Put first the RPC receiver corresponding to the remote package
4182 Append_To
(Statements
,
4183 Make_Attribute_Reference
(Loc
,
4185 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
4186 Attribute_Name
=> Name_Write
,
4187 Expressions
=> New_List
(
4188 Make_Attribute_Reference
(Loc
,
4189 Prefix
=> New_Occurrence_Of
(Stream_Parameter
, Loc
),
4190 Attribute_Name
=> Name_Access
),
4191 Target_RPC_Receiver
)));
4193 -- Then put the Subprogram_Id of the subprogram we want to call in
4196 Append_To
(Statements
,
4197 Make_Attribute_Reference
(Loc
,
4198 Prefix
=> New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4199 Attribute_Name
=> Name_Write
,
4200 Expressions
=> New_List
(
4201 Make_Attribute_Reference
(Loc
,
4202 Prefix
=> New_Occurrence_Of
(Stream_Parameter
, Loc
),
4203 Attribute_Name
=> Name_Access
),
4206 Current_Parameter
:= First
(Ordered_Parameters_List
);
4207 while Present
(Current_Parameter
) loop
4209 Typ
: constant Node_Id
:=
4210 Parameter_Type
(Current_Parameter
);
4212 Constrained
: Boolean;
4214 Extra_Parameter
: Entity_Id
;
4217 if Is_RACW_Controlling_Formal
4218 (Current_Parameter
, Stub_Type
)
4220 -- In the case of a controlling formal argument, we marshall
4221 -- its addr field rather than the local stub.
4223 Append_To
(Statements
,
4224 Pack_Node_Into_Stream
(Loc
,
4225 Stream
=> Stream_Parameter
,
4227 Make_Selected_Component
(Loc
,
4229 Defining_Identifier
(Current_Parameter
),
4230 Selector_Name
=> Name_Addr
),
4231 Etyp
=> RTE
(RE_Unsigned_64
)));
4236 (Defining_Identifier
(Current_Parameter
), Loc
);
4238 -- Access type parameters are transmitted as in out
4239 -- parameters. However, a dereference is needed so that
4240 -- we marshall the designated object.
4242 if Nkind
(Typ
) = N_Access_Definition
then
4243 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4244 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4246 Etyp
:= Etype
(Typ
);
4249 Constrained
:= not Transmit_As_Unconstrained
(Etyp
);
4251 -- Any parameter but unconstrained out parameters are
4252 -- transmitted to the peer.
4254 if In_Present
(Current_Parameter
)
4255 or else not Out_Present
(Current_Parameter
)
4256 or else not Constrained
4258 Append_To
(Statements
,
4259 Make_Attribute_Reference
(Loc
,
4260 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4262 Output_From_Constrained
(Constrained
),
4263 Expressions
=> New_List
(
4264 Make_Attribute_Reference
(Loc
,
4266 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4267 Attribute_Name
=> Name_Access
),
4272 -- If the current parameter has a dynamic constrained status,
4273 -- then this status is transmitted as well.
4274 -- This should be done for accessibility as well ???
4276 if Nkind
(Typ
) /= N_Access_Definition
4277 and then Need_Extra_Constrained
(Current_Parameter
)
4279 -- In this block, we do not use the extra formal that has
4280 -- been created because it does not exist at the time of
4281 -- expansion when building calling stubs for remote access
4282 -- to subprogram types. We create an extra variable of this
4283 -- type and push it in the stream after the regular
4286 Extra_Parameter
:= Make_Defining_Identifier
4287 (Loc
, New_Internal_Name
('P'));
4290 Make_Object_Declaration
(Loc
,
4291 Defining_Identifier
=> Extra_Parameter
,
4292 Constant_Present
=> True,
4293 Object_Definition
=>
4294 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4296 Make_Attribute_Reference
(Loc
,
4299 Defining_Identifier
(Current_Parameter
), Loc
),
4300 Attribute_Name
=> Name_Constrained
)));
4302 Append_To
(Extra_Formal_Statements
,
4303 Make_Attribute_Reference
(Loc
,
4305 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4306 Attribute_Name
=> Name_Write
,
4307 Expressions
=> New_List
(
4308 Make_Attribute_Reference
(Loc
,
4311 (Stream_Parameter
, Loc
), Attribute_Name
=>
4313 New_Occurrence_Of
(Extra_Parameter
, Loc
))));
4316 Next
(Current_Parameter
);
4320 -- Append the formal statements list to the statements
4322 Append_List_To
(Statements
, Extra_Formal_Statements
);
4324 if not Is_Known_Non_Asynchronous
then
4326 -- Build the call to System.RPC.Do_APC
4328 Asynchronous_Statements
:= New_List
(
4329 Make_Procedure_Call_Statement
(Loc
,
4331 New_Occurrence_Of
(RTE
(RE_Do_Apc
), Loc
),
4332 Parameter_Associations
=> New_List
(
4333 New_Occurrence_Of
(Target_Partition
, Loc
),
4334 Make_Attribute_Reference
(Loc
,
4336 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4337 Attribute_Name
=> Name_Access
))));
4339 Asynchronous_Statements
:= No_List
;
4342 if not Is_Known_Asynchronous
then
4344 -- Build the call to System.RPC.Do_RPC
4346 Non_Asynchronous_Statements
:= New_List
(
4347 Make_Procedure_Call_Statement
(Loc
,
4349 New_Occurrence_Of
(RTE
(RE_Do_Rpc
), Loc
),
4350 Parameter_Associations
=> New_List
(
4351 New_Occurrence_Of
(Target_Partition
, Loc
),
4353 Make_Attribute_Reference
(Loc
,
4355 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4356 Attribute_Name
=> Name_Access
),
4358 Make_Attribute_Reference
(Loc
,
4360 New_Occurrence_Of
(Result_Parameter
, Loc
),
4361 Attribute_Name
=> Name_Access
))));
4363 -- Read the exception occurrence from the result stream and
4364 -- reraise it. It does no harm if this is a Null_Occurrence since
4365 -- this does nothing.
4367 Append_To
(Non_Asynchronous_Statements
,
4368 Make_Attribute_Reference
(Loc
,
4370 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4372 Attribute_Name
=> Name_Read
,
4374 Expressions
=> New_List
(
4375 Make_Attribute_Reference
(Loc
,
4377 New_Occurrence_Of
(Result_Parameter
, Loc
),
4378 Attribute_Name
=> Name_Access
),
4379 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
4381 Append_To
(Non_Asynchronous_Statements
,
4382 Make_Procedure_Call_Statement
(Loc
,
4384 New_Occurrence_Of
(RTE
(RE_Reraise_Occurrence
), Loc
),
4385 Parameter_Associations
=> New_List
(
4386 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
4390 -- If this is a function call, then read the value and return
4391 -- it. The return value is written/read using 'Output/'Input.
4393 Append_To
(Non_Asynchronous_Statements
,
4394 Make_Tag_Check
(Loc
,
4395 Make_Simple_Return_Statement
(Loc
,
4397 Make_Attribute_Reference
(Loc
,
4400 Etype
(Result_Definition
(Spec
)), Loc
),
4402 Attribute_Name
=> Name_Input
,
4404 Expressions
=> New_List
(
4405 Make_Attribute_Reference
(Loc
,
4407 New_Occurrence_Of
(Result_Parameter
, Loc
),
4408 Attribute_Name
=> Name_Access
))))));
4411 -- Loop around parameters and assign out (or in out)
4412 -- parameters. In the case of RACW, controlling arguments
4413 -- cannot possibly have changed since they are remote, so we do
4414 -- not read them from the stream.
4416 Current_Parameter
:= First
(Ordered_Parameters_List
);
4417 while Present
(Current_Parameter
) loop
4419 Typ
: constant Node_Id
:=
4420 Parameter_Type
(Current_Parameter
);
4427 (Defining_Identifier
(Current_Parameter
), Loc
);
4429 if Nkind
(Typ
) = N_Access_Definition
then
4430 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4431 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4433 Etyp
:= Etype
(Typ
);
4436 if (Out_Present
(Current_Parameter
)
4437 or else Nkind
(Typ
) = N_Access_Definition
)
4438 and then Etyp
/= Stub_Type
4440 Append_To
(Non_Asynchronous_Statements
,
4441 Make_Attribute_Reference
(Loc
,
4443 New_Occurrence_Of
(Etyp
, Loc
),
4445 Attribute_Name
=> Name_Read
,
4447 Expressions
=> New_List
(
4448 Make_Attribute_Reference
(Loc
,
4450 New_Occurrence_Of
(Result_Parameter
, Loc
),
4451 Attribute_Name
=> Name_Access
),
4456 Next
(Current_Parameter
);
4461 if Is_Known_Asynchronous
then
4462 Append_List_To
(Statements
, Asynchronous_Statements
);
4464 elsif Is_Known_Non_Asynchronous
then
4465 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
4468 pragma Assert
(Present
(Asynchronous
));
4469 Prepend_To
(Asynchronous_Statements
,
4470 Make_Attribute_Reference
(Loc
,
4471 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4472 Attribute_Name
=> Name_Write
,
4473 Expressions
=> New_List
(
4474 Make_Attribute_Reference
(Loc
,
4476 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4477 Attribute_Name
=> Name_Access
),
4478 New_Occurrence_Of
(Standard_True
, Loc
))));
4480 Prepend_To
(Non_Asynchronous_Statements
,
4481 Make_Attribute_Reference
(Loc
,
4482 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4483 Attribute_Name
=> Name_Write
,
4484 Expressions
=> New_List
(
4485 Make_Attribute_Reference
(Loc
,
4487 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4488 Attribute_Name
=> Name_Access
),
4489 New_Occurrence_Of
(Standard_False
, Loc
))));
4491 Append_To
(Statements
,
4492 Make_Implicit_If_Statement
(Nod
,
4493 Condition
=> Asynchronous
,
4494 Then_Statements
=> Asynchronous_Statements
,
4495 Else_Statements
=> Non_Asynchronous_Statements
));
4497 end Build_General_Calling_Stubs
;
4499 -----------------------------
4500 -- Build_RPC_Receiver_Body --
4501 -----------------------------
4503 procedure Build_RPC_Receiver_Body
4504 (RPC_Receiver
: Entity_Id
;
4505 Request
: out Entity_Id
;
4506 Subp_Id
: out Entity_Id
;
4507 Subp_Index
: out Entity_Id
;
4508 Stmts
: out List_Id
;
4511 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
4513 RPC_Receiver_Spec
: Node_Id
;
4514 RPC_Receiver_Decls
: List_Id
;
4517 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
4519 RPC_Receiver_Spec
:=
4520 Build_RPC_Receiver_Specification
4521 (RPC_Receiver
=> RPC_Receiver
,
4522 Request_Parameter
=> Request
);
4524 Subp_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4525 Subp_Index
:= Subp_Id
;
4527 -- Subp_Id may not be a constant, because in the case of the RPC
4528 -- receiver for an RCI package, when a call is received from a RAS
4529 -- dereference, it will be assigned during subsequent processing.
4531 RPC_Receiver_Decls
:= New_List
(
4532 Make_Object_Declaration
(Loc
,
4533 Defining_Identifier
=> Subp_Id
,
4534 Object_Definition
=>
4535 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4537 Make_Attribute_Reference
(Loc
,
4539 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4540 Attribute_Name
=> Name_Input
,
4541 Expressions
=> New_List
(
4542 Make_Selected_Component
(Loc
,
4544 Selector_Name
=> Name_Params
)))));
4549 Make_Subprogram_Body
(Loc
,
4550 Specification
=> RPC_Receiver_Spec
,
4551 Declarations
=> RPC_Receiver_Decls
,
4552 Handled_Statement_Sequence
=>
4553 Make_Handled_Sequence_Of_Statements
(Loc
,
4554 Statements
=> Stmts
));
4555 end Build_RPC_Receiver_Body
;
4557 -----------------------
4558 -- Build_Stub_Target --
4559 -----------------------
4561 function Build_Stub_Target
4564 RCI_Locator
: Entity_Id
;
4565 Controlling_Parameter
: Entity_Id
) return RPC_Target
4567 Target_Info
: RPC_Target
(PCS_Kind
=> Name_GARLIC_DSA
);
4569 Target_Info
.Partition
:=
4570 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4571 if Present
(Controlling_Parameter
) then
4573 Make_Object_Declaration
(Loc
,
4574 Defining_Identifier
=> Target_Info
.Partition
,
4575 Constant_Present
=> True,
4576 Object_Definition
=>
4577 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4580 Make_Selected_Component
(Loc
,
4581 Prefix
=> Controlling_Parameter
,
4582 Selector_Name
=> Name_Origin
)));
4584 Target_Info
.RPC_Receiver
:=
4585 Make_Selected_Component
(Loc
,
4586 Prefix
=> Controlling_Parameter
,
4587 Selector_Name
=> Name_Receiver
);
4591 Make_Object_Declaration
(Loc
,
4592 Defining_Identifier
=> Target_Info
.Partition
,
4593 Constant_Present
=> True,
4594 Object_Definition
=>
4595 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4598 Make_Function_Call
(Loc
,
4599 Name
=> Make_Selected_Component
(Loc
,
4601 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4603 Make_Identifier
(Loc
,
4604 Name_Get_Active_Partition_ID
)))));
4606 Target_Info
.RPC_Receiver
:=
4607 Make_Selected_Component
(Loc
,
4609 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4611 Make_Identifier
(Loc
, Name_Get_RCI_Package_Receiver
));
4614 end Build_Stub_Target
;
4616 ---------------------
4617 -- Build_Stub_Type --
4618 ---------------------
4620 procedure Build_Stub_Type
4621 (RACW_Type
: Entity_Id
;
4622 Stub_Type
: Entity_Id
;
4623 Stub_Type_Decl
: out Node_Id
;
4624 RPC_Receiver_Decl
: out Node_Id
)
4626 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
4627 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
4631 Make_Full_Type_Declaration
(Loc
,
4632 Defining_Identifier
=> Stub_Type
,
4634 Make_Record_Definition
(Loc
,
4635 Tagged_Present
=> True,
4636 Limited_Present
=> True,
4638 Make_Component_List
(Loc
,
4639 Component_Items
=> New_List
(
4641 Make_Component_Declaration
(Loc
,
4642 Defining_Identifier
=>
4643 Make_Defining_Identifier
(Loc
, Name_Origin
),
4644 Component_Definition
=>
4645 Make_Component_Definition
(Loc
,
4646 Aliased_Present
=> False,
4647 Subtype_Indication
=>
4649 RTE
(RE_Partition_ID
), Loc
))),
4651 Make_Component_Declaration
(Loc
,
4652 Defining_Identifier
=>
4653 Make_Defining_Identifier
(Loc
, Name_Receiver
),
4654 Component_Definition
=>
4655 Make_Component_Definition
(Loc
,
4656 Aliased_Present
=> False,
4657 Subtype_Indication
=>
4658 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4660 Make_Component_Declaration
(Loc
,
4661 Defining_Identifier
=>
4662 Make_Defining_Identifier
(Loc
, Name_Addr
),
4663 Component_Definition
=>
4664 Make_Component_Definition
(Loc
,
4665 Aliased_Present
=> False,
4666 Subtype_Indication
=>
4667 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4669 Make_Component_Declaration
(Loc
,
4670 Defining_Identifier
=>
4671 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
4672 Component_Definition
=>
4673 Make_Component_Definition
(Loc
,
4674 Aliased_Present
=> False,
4675 Subtype_Indication
=>
4677 Standard_Boolean
, Loc
)))))));
4680 RPC_Receiver_Decl
:= Empty
;
4683 RPC_Receiver_Request
: constant Entity_Id
:=
4684 Make_Defining_Identifier
(Loc
, Name_R
);
4686 RPC_Receiver_Decl
:=
4687 Make_Subprogram_Declaration
(Loc
,
4688 Build_RPC_Receiver_Specification
(
4689 RPC_Receiver
=> Make_Defining_Identifier
(Loc
,
4690 New_Internal_Name
('R')),
4691 Request_Parameter
=> RPC_Receiver_Request
));
4694 end Build_Stub_Type
;
4696 --------------------------------------
4697 -- Build_Subprogram_Receiving_Stubs --
4698 --------------------------------------
4700 function Build_Subprogram_Receiving_Stubs
4701 (Vis_Decl
: Node_Id
;
4702 Asynchronous
: Boolean;
4703 Dynamically_Asynchronous
: Boolean := False;
4704 Stub_Type
: Entity_Id
:= Empty
;
4705 RACW_Type
: Entity_Id
:= Empty
;
4706 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
4708 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
4710 Request_Parameter
: constant Entity_Id
:=
4711 Make_Defining_Identifier
(Loc
,
4712 New_Internal_Name
('R'));
4713 -- Formal parameter for receiving stubs: a descriptor for an incoming
4716 Decls
: constant List_Id
:= New_List
;
4717 -- All the parameters will get declared before calling the real
4718 -- subprograms. Also the out parameters will be declared.
4720 Statements
: constant List_Id
:= New_List
;
4722 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4723 -- Statements concerning extra formal parameters
4725 After_Statements
: constant List_Id
:= New_List
;
4726 -- Statements to be executed after the subprogram call
4728 Inner_Decls
: List_Id
:= No_List
;
4729 -- In case of a function, the inner declarations are needed since
4730 -- the result may be unconstrained.
4732 Excep_Handlers
: List_Id
:= No_List
;
4733 Excep_Choice
: Entity_Id
;
4734 Excep_Code
: List_Id
;
4736 Parameter_List
: constant List_Id
:= New_List
;
4737 -- List of parameters to be passed to the subprogram
4739 Current_Parameter
: Node_Id
;
4741 Ordered_Parameters_List
: constant List_Id
:=
4742 Build_Ordered_Parameters_List
4743 (Specification
(Vis_Decl
));
4745 Subp_Spec
: Node_Id
;
4746 -- Subprogram specification
4748 Called_Subprogram
: Node_Id
;
4749 -- The subprogram to call
4751 Null_Raise_Statement
: Node_Id
;
4753 Dynamic_Async
: Entity_Id
;
4756 if Present
(RACW_Type
) then
4757 Called_Subprogram
:= New_Occurrence_Of
(Parent_Primitive
, Loc
);
4759 Called_Subprogram
:=
4761 (Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
4764 if Dynamically_Asynchronous
then
4766 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
4768 Dynamic_Async
:= Empty
;
4771 if not Asynchronous
or Dynamically_Asynchronous
then
4773 -- The first statement after the subprogram call is a statement to
4774 -- write a Null_Occurrence into the result stream.
4776 Null_Raise_Statement
:=
4777 Make_Attribute_Reference
(Loc
,
4779 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4780 Attribute_Name
=> Name_Write
,
4781 Expressions
=> New_List
(
4782 Make_Selected_Component
(Loc
,
4783 Prefix
=> Request_Parameter
,
4784 Selector_Name
=> Name_Result
),
4785 New_Occurrence_Of
(RTE
(RE_Null_Occurrence
), Loc
)));
4787 if Dynamically_Asynchronous
then
4788 Null_Raise_Statement
:=
4789 Make_Implicit_If_Statement
(Vis_Decl
,
4791 Make_Op_Not
(Loc
, New_Occurrence_Of
(Dynamic_Async
, Loc
)),
4792 Then_Statements
=> New_List
(Null_Raise_Statement
));
4795 Append_To
(After_Statements
, Null_Raise_Statement
);
4798 -- Loop through every parameter and get its value from the stream. If
4799 -- the parameter is unconstrained, then the parameter is read using
4800 -- 'Input at the point of declaration.
4802 Current_Parameter
:= First
(Ordered_Parameters_List
);
4803 while Present
(Current_Parameter
) loop
4806 Constrained
: Boolean;
4808 Need_Extra_Constrained
: Boolean;
4809 -- True when an Extra_Constrained actual is required
4811 Object
: constant Entity_Id
:=
4812 Make_Defining_Identifier
(Loc
,
4813 New_Internal_Name
('P'));
4815 Expr
: Node_Id
:= Empty
;
4817 Is_Controlling_Formal
: constant Boolean :=
4818 Is_RACW_Controlling_Formal
4819 (Current_Parameter
, Stub_Type
);
4822 if Is_Controlling_Formal
then
4824 -- We have a controlling formal parameter. Read its address
4825 -- rather than a real object. The address is in Unsigned_64
4828 Etyp
:= RTE
(RE_Unsigned_64
);
4830 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
4833 Constrained
:= not Transmit_As_Unconstrained
(Etyp
);
4835 if In_Present
(Current_Parameter
)
4836 or else not Out_Present
(Current_Parameter
)
4837 or else not Constrained
4838 or else Is_Controlling_Formal
4840 -- If an input parameter is constrained, then the read of
4841 -- the parameter is deferred until the beginning of the
4842 -- subprogram body. If it is unconstrained, then an
4843 -- expression is built for the object declaration and the
4844 -- variable is set using 'Input instead of 'Read. Note that
4845 -- this deferral does not change the order in which the
4846 -- actuals are read because Build_Ordered_Parameter_List
4847 -- puts them unconstrained first.
4850 Append_To
(Statements
,
4851 Make_Attribute_Reference
(Loc
,
4852 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4853 Attribute_Name
=> Name_Read
,
4854 Expressions
=> New_List
(
4855 Make_Selected_Component
(Loc
,
4856 Prefix
=> Request_Parameter
,
4857 Selector_Name
=> Name_Params
),
4858 New_Occurrence_Of
(Object
, Loc
))));
4862 -- Build and append Input_With_Tag_Check function
4865 Input_With_Tag_Check
(Loc
,
4868 Make_Selected_Component
(Loc
,
4869 Prefix
=> Request_Parameter
,
4870 Selector_Name
=> Name_Params
)));
4872 -- Prepare function call expression
4875 Make_Function_Call
(Loc
,
4879 (Specification
(Last
(Decls
))), Loc
));
4883 Need_Extra_Constrained
:=
4884 Nkind
(Parameter_Type
(Current_Parameter
)) /=
4887 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
4889 Present
(Extra_Constrained
4890 (Defining_Identifier
(Current_Parameter
)));
4892 -- We may not associate an extra constrained actual to a
4893 -- constant object, so if one is needed, declare the actual
4894 -- as a variable even if it won't be modified.
4896 Build_Actual_Object_Declaration
4899 Variable
=> Need_Extra_Constrained
4900 or else Out_Present
(Current_Parameter
),
4904 -- An out parameter may be written back using a 'Write
4905 -- attribute instead of a 'Output because it has been
4906 -- constrained by the parameter given to the caller. Note that
4907 -- out controlling arguments in the case of a RACW are not put
4908 -- back in the stream because the pointer on them has not
4911 if Out_Present
(Current_Parameter
)
4913 Etype
(Parameter_Type
(Current_Parameter
)) /= Stub_Type
4915 Append_To
(After_Statements
,
4916 Make_Attribute_Reference
(Loc
,
4917 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4918 Attribute_Name
=> Name_Write
,
4919 Expressions
=> New_List
(
4920 Make_Selected_Component
(Loc
,
4921 Prefix
=> Request_Parameter
,
4922 Selector_Name
=> Name_Result
),
4923 New_Occurrence_Of
(Object
, Loc
))));
4926 -- For RACW controlling formals, the Etyp of Object is always
4927 -- an RACW, even if the parameter is not of an anonymous access
4928 -- type. In such case, we need to dereference it at call time.
4930 if Is_Controlling_Formal
then
4931 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
4934 Append_To
(Parameter_List
,
4935 Make_Parameter_Association
(Loc
,
4938 Defining_Identifier
(Current_Parameter
), Loc
),
4939 Explicit_Actual_Parameter
=>
4940 Make_Explicit_Dereference
(Loc
,
4941 Unchecked_Convert_To
(RACW_Type
,
4942 OK_Convert_To
(RTE
(RE_Address
),
4943 New_Occurrence_Of
(Object
, Loc
))))));
4946 Append_To
(Parameter_List
,
4947 Make_Parameter_Association
(Loc
,
4950 Defining_Identifier
(Current_Parameter
), Loc
),
4951 Explicit_Actual_Parameter
=>
4952 Unchecked_Convert_To
(RACW_Type
,
4953 OK_Convert_To
(RTE
(RE_Address
),
4954 New_Occurrence_Of
(Object
, Loc
)))));
4958 Append_To
(Parameter_List
,
4959 Make_Parameter_Association
(Loc
,
4962 Defining_Identifier
(Current_Parameter
), Loc
),
4963 Explicit_Actual_Parameter
=>
4964 New_Occurrence_Of
(Object
, Loc
)));
4967 -- If the current parameter needs an extra formal, then read it
4968 -- from the stream and set the corresponding semantic field in
4969 -- the variable. If the kind of the parameter identifier is
4970 -- E_Void, then this is a compiler generated parameter that
4971 -- doesn't need an extra constrained status.
4973 -- The case of Extra_Accessibility should also be handled ???
4975 if Need_Extra_Constrained
then
4977 Extra_Parameter
: constant Entity_Id
:=
4979 (Defining_Identifier
4980 (Current_Parameter
));
4982 Formal_Entity
: constant Entity_Id
:=
4983 Make_Defining_Identifier
4984 (Loc
, Chars
(Extra_Parameter
));
4986 Formal_Type
: constant Entity_Id
:=
4987 Etype
(Extra_Parameter
);
4991 Make_Object_Declaration
(Loc
,
4992 Defining_Identifier
=> Formal_Entity
,
4993 Object_Definition
=>
4994 New_Occurrence_Of
(Formal_Type
, Loc
)));
4996 Append_To
(Extra_Formal_Statements
,
4997 Make_Attribute_Reference
(Loc
,
4998 Prefix
=> New_Occurrence_Of
(
5000 Attribute_Name
=> Name_Read
,
5001 Expressions
=> New_List
(
5002 Make_Selected_Component
(Loc
,
5003 Prefix
=> Request_Parameter
,
5004 Selector_Name
=> Name_Params
),
5005 New_Occurrence_Of
(Formal_Entity
, Loc
))));
5007 -- Note: the call to Set_Extra_Constrained below relies
5008 -- on the fact that Object's Ekind has been set by
5009 -- Build_Actual_Object_Declaration.
5011 Set_Extra_Constrained
(Object
, Formal_Entity
);
5016 Next
(Current_Parameter
);
5019 -- Append the formal statements list at the end of regular statements
5021 Append_List_To
(Statements
, Extra_Formal_Statements
);
5023 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
5025 -- The remote subprogram is a function. We build an inner block to
5026 -- be able to hold a potentially unconstrained result in a
5030 Etyp
: constant Entity_Id
:=
5031 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
5032 Result
: constant Node_Id
:=
5033 Make_Defining_Identifier
(Loc
,
5034 New_Internal_Name
('R'));
5036 Inner_Decls
:= New_List
(
5037 Make_Object_Declaration
(Loc
,
5038 Defining_Identifier
=> Result
,
5039 Constant_Present
=> True,
5040 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
5042 Make_Function_Call
(Loc
,
5043 Name
=> Called_Subprogram
,
5044 Parameter_Associations
=> Parameter_List
)));
5046 if Is_Class_Wide_Type
(Etyp
) then
5048 -- For a remote call to a function with a class-wide type,
5049 -- check that the returned value satisfies the requirements
5052 Append_To
(Inner_Decls
,
5053 Make_Transportable_Check
(Loc
,
5054 New_Occurrence_Of
(Result
, Loc
)));
5058 Append_To
(After_Statements
,
5059 Make_Attribute_Reference
(Loc
,
5060 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5061 Attribute_Name
=> Name_Output
,
5062 Expressions
=> New_List
(
5063 Make_Selected_Component
(Loc
,
5064 Prefix
=> Request_Parameter
,
5065 Selector_Name
=> Name_Result
),
5066 New_Occurrence_Of
(Result
, Loc
))));
5069 Append_To
(Statements
,
5070 Make_Block_Statement
(Loc
,
5071 Declarations
=> Inner_Decls
,
5072 Handled_Statement_Sequence
=>
5073 Make_Handled_Sequence_Of_Statements
(Loc
,
5074 Statements
=> After_Statements
)));
5077 -- The remote subprogram is a procedure. We do not need any inner
5078 -- block in this case.
5080 if Dynamically_Asynchronous
then
5082 Make_Object_Declaration
(Loc
,
5083 Defining_Identifier
=> Dynamic_Async
,
5084 Object_Definition
=>
5085 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
5087 Append_To
(Statements
,
5088 Make_Attribute_Reference
(Loc
,
5089 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
5090 Attribute_Name
=> Name_Read
,
5091 Expressions
=> New_List
(
5092 Make_Selected_Component
(Loc
,
5093 Prefix
=> Request_Parameter
,
5094 Selector_Name
=> Name_Params
),
5095 New_Occurrence_Of
(Dynamic_Async
, Loc
))));
5098 Append_To
(Statements
,
5099 Make_Procedure_Call_Statement
(Loc
,
5100 Name
=> Called_Subprogram
,
5101 Parameter_Associations
=> Parameter_List
));
5103 Append_List_To
(Statements
, After_Statements
);
5106 if Asynchronous
and then not Dynamically_Asynchronous
then
5108 -- For an asynchronous procedure, add a null exception handler
5110 Excep_Handlers
:= New_List
(
5111 Make_Implicit_Exception_Handler
(Loc
,
5112 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5113 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
5116 -- In the other cases, if an exception is raised, then the
5117 -- exception occurrence is copied into the output stream and
5118 -- no other output parameter is written.
5121 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
5123 Excep_Code
:= New_List
(
5124 Make_Attribute_Reference
(Loc
,
5126 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
5127 Attribute_Name
=> Name_Write
,
5128 Expressions
=> New_List
(
5129 Make_Selected_Component
(Loc
,
5130 Prefix
=> Request_Parameter
,
5131 Selector_Name
=> Name_Result
),
5132 New_Occurrence_Of
(Excep_Choice
, Loc
))));
5134 if Dynamically_Asynchronous
then
5135 Excep_Code
:= New_List
(
5136 Make_Implicit_If_Statement
(Vis_Decl
,
5137 Condition
=> Make_Op_Not
(Loc
,
5138 New_Occurrence_Of
(Dynamic_Async
, Loc
)),
5139 Then_Statements
=> Excep_Code
));
5142 Excep_Handlers
:= New_List
(
5143 Make_Implicit_Exception_Handler
(Loc
,
5144 Choice_Parameter
=> Excep_Choice
,
5145 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5146 Statements
=> Excep_Code
));
5151 Make_Procedure_Specification
(Loc
,
5152 Defining_Unit_Name
=>
5153 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
5155 Parameter_Specifications
=> New_List
(
5156 Make_Parameter_Specification
(Loc
,
5157 Defining_Identifier
=> Request_Parameter
,
5159 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
5162 Make_Subprogram_Body
(Loc
,
5163 Specification
=> Subp_Spec
,
5164 Declarations
=> Decls
,
5165 Handled_Statement_Sequence
=>
5166 Make_Handled_Sequence_Of_Statements
(Loc
,
5167 Statements
=> Statements
,
5168 Exception_Handlers
=> Excep_Handlers
));
5169 end Build_Subprogram_Receiving_Stubs
;
5175 function Result
return Node_Id
is
5177 return Make_Identifier
(Loc
, Name_V
);
5180 ----------------------
5181 -- Stream_Parameter --
5182 ----------------------
5184 function Stream_Parameter
return Node_Id
is
5186 return Make_Identifier
(Loc
, Name_S
);
5187 end Stream_Parameter
;
5191 -------------------------------
5192 -- Get_And_Reset_RACW_Bodies --
5193 -------------------------------
5195 function Get_And_Reset_RACW_Bodies
(RACW_Type
: Entity_Id
) return List_Id
is
5196 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
5197 Stub_Elements
: Stub_Structure
:= Stubs_Table
.Get
(Desig
);
5199 Body_Decls
: List_Id
;
5200 -- Returned list of declarations
5203 if Stub_Elements
= Empty_Stub_Structure
then
5205 -- Stub elements may be missing as a consequence of a previously
5211 Body_Decls
:= Stub_Elements
.Body_Decls
;
5212 Stub_Elements
.Body_Decls
:= No_List
;
5213 Stubs_Table
.Set
(Desig
, Stub_Elements
);
5215 end Get_And_Reset_RACW_Bodies
;
5217 -----------------------
5218 -- Get_Stub_Elements --
5219 -----------------------
5221 function Get_Stub_Elements
(RACW_Type
: Entity_Id
) return Stub_Structure
is
5222 Desig
: constant Entity_Id
:=
5223 Etype
(Designated_Type
(RACW_Type
));
5224 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
5226 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5227 return Stub_Elements
;
5228 end Get_Stub_Elements
;
5230 -----------------------
5231 -- Get_Subprogram_Id --
5232 -----------------------
5234 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
is
5235 Result
: constant String_Id
:= Get_Subprogram_Ids
(Def
).Str_Identifier
;
5237 pragma Assert
(Result
/= No_String
);
5239 end Get_Subprogram_Id
;
5241 -----------------------
5242 -- Get_Subprogram_Id --
5243 -----------------------
5245 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
is
5247 return Get_Subprogram_Ids
(Def
).Int_Identifier
;
5248 end Get_Subprogram_Id
;
5250 ------------------------
5251 -- Get_Subprogram_Ids --
5252 ------------------------
5254 function Get_Subprogram_Ids
5255 (Def
: Entity_Id
) return Subprogram_Identifiers
5258 return Subprogram_Identifier_Table
.Get
(Def
);
5259 end Get_Subprogram_Ids
;
5265 function Hash
(F
: Entity_Id
) return Hash_Index
is
5267 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
5270 function Hash
(F
: Name_Id
) return Hash_Index
is
5272 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
5275 --------------------------
5276 -- Input_With_Tag_Check --
5277 --------------------------
5279 function Input_With_Tag_Check
5281 Var_Type
: Entity_Id
;
5282 Stream
: Node_Id
) return Node_Id
5286 Make_Subprogram_Body
(Loc
,
5287 Specification
=> Make_Function_Specification
(Loc
,
5288 Defining_Unit_Name
=>
5289 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S')),
5290 Result_Definition
=> New_Occurrence_Of
(Var_Type
, Loc
)),
5291 Declarations
=> No_List
,
5292 Handled_Statement_Sequence
=>
5293 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
5294 Make_Tag_Check
(Loc
,
5295 Make_Simple_Return_Statement
(Loc
,
5296 Make_Attribute_Reference
(Loc
,
5297 Prefix
=> New_Occurrence_Of
(Var_Type
, Loc
),
5298 Attribute_Name
=> Name_Input
,
5300 New_List
(Stream
)))))));
5301 end Input_With_Tag_Check
;
5303 --------------------------------
5304 -- Is_RACW_Controlling_Formal --
5305 --------------------------------
5307 function Is_RACW_Controlling_Formal
5308 (Parameter
: Node_Id
;
5309 Stub_Type
: Entity_Id
) return Boolean
5314 -- If the kind of the parameter is E_Void, then it is not a
5315 -- controlling formal (this can happen in the context of RAS).
5317 if Ekind
(Defining_Identifier
(Parameter
)) = E_Void
then
5321 -- If the parameter is not a controlling formal, then it cannot
5322 -- be possibly a RACW_Controlling_Formal.
5324 if not Is_Controlling_Formal
(Defining_Identifier
(Parameter
)) then
5328 Typ
:= Parameter_Type
(Parameter
);
5329 return (Nkind
(Typ
) = N_Access_Definition
5330 and then Etype
(Subtype_Mark
(Typ
)) = Stub_Type
)
5331 or else Etype
(Typ
) = Stub_Type
;
5332 end Is_RACW_Controlling_Formal
;
5334 ------------------------------
5335 -- Make_Transportable_Check --
5336 ------------------------------
5338 function Make_Transportable_Check
5340 Expr
: Node_Id
) return Node_Id
is
5343 Make_Raise_Program_Error
(Loc
,
5346 Build_Get_Transportable
(Loc
,
5347 Make_Selected_Component
(Loc
,
5349 Selector_Name
=> Make_Identifier
(Loc
, Name_uTag
)))),
5350 Reason
=> PE_Non_Transportable_Actual
);
5351 end Make_Transportable_Check
;
5353 -----------------------------
5354 -- Make_Selected_Component --
5355 -----------------------------
5357 function Make_Selected_Component
5360 Selector_Name
: Name_Id
) return Node_Id
5363 return Make_Selected_Component
(Loc
,
5364 Prefix
=> New_Occurrence_Of
(Prefix
, Loc
),
5365 Selector_Name
=> Make_Identifier
(Loc
, Selector_Name
));
5366 end Make_Selected_Component
;
5368 --------------------
5369 -- Make_Tag_Check --
5370 --------------------
5372 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
is
5373 Occ
: constant Entity_Id
:=
5374 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
5377 return Make_Block_Statement
(Loc
,
5378 Handled_Statement_Sequence
=>
5379 Make_Handled_Sequence_Of_Statements
(Loc
,
5380 Statements
=> New_List
(N
),
5382 Exception_Handlers
=> New_List
(
5383 Make_Implicit_Exception_Handler
(Loc
,
5384 Choice_Parameter
=> Occ
,
5386 Exception_Choices
=>
5387 New_List
(New_Occurrence_Of
(RTE
(RE_Tag_Error
), Loc
)),
5390 New_List
(Make_Procedure_Call_Statement
(Loc
,
5392 (RTE
(RE_Raise_Program_Error_Unknown_Tag
), Loc
),
5393 New_List
(New_Occurrence_Of
(Occ
, Loc
))))))));
5396 ----------------------------
5397 -- Need_Extra_Constrained --
5398 ----------------------------
5400 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean is
5401 Etyp
: constant Entity_Id
:= Etype
(Parameter_Type
(Parameter
));
5403 return Out_Present
(Parameter
)
5404 and then Has_Discriminants
(Etyp
)
5405 and then not Is_Constrained
(Etyp
)
5406 and then not Is_Indefinite_Subtype
(Etyp
);
5407 end Need_Extra_Constrained
;
5409 ------------------------------------
5410 -- Pack_Entity_Into_Stream_Access --
5411 ------------------------------------
5413 function Pack_Entity_Into_Stream_Access
5417 Etyp
: Entity_Id
:= Empty
) return Node_Id
5422 if Present
(Etyp
) then
5425 Typ
:= Etype
(Object
);
5429 Pack_Node_Into_Stream_Access
(Loc
,
5431 Object
=> New_Occurrence_Of
(Object
, Loc
),
5433 end Pack_Entity_Into_Stream_Access
;
5435 ---------------------------
5436 -- Pack_Node_Into_Stream --
5437 ---------------------------
5439 function Pack_Node_Into_Stream
5443 Etyp
: Entity_Id
) return Node_Id
5445 Write_Attribute
: Name_Id
:= Name_Write
;
5448 if not Is_Constrained
(Etyp
) then
5449 Write_Attribute
:= Name_Output
;
5453 Make_Attribute_Reference
(Loc
,
5454 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5455 Attribute_Name
=> Write_Attribute
,
5456 Expressions
=> New_List
(
5457 Make_Attribute_Reference
(Loc
,
5458 Prefix
=> New_Occurrence_Of
(Stream
, Loc
),
5459 Attribute_Name
=> Name_Access
),
5461 end Pack_Node_Into_Stream
;
5463 ----------------------------------
5464 -- Pack_Node_Into_Stream_Access --
5465 ----------------------------------
5467 function Pack_Node_Into_Stream_Access
5471 Etyp
: Entity_Id
) return Node_Id
5473 Write_Attribute
: Name_Id
:= Name_Write
;
5476 if not Is_Constrained
(Etyp
) then
5477 Write_Attribute
:= Name_Output
;
5481 Make_Attribute_Reference
(Loc
,
5482 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5483 Attribute_Name
=> Write_Attribute
,
5484 Expressions
=> New_List
(
5487 end Pack_Node_Into_Stream_Access
;
5489 ---------------------
5490 -- PolyORB_Support --
5491 ---------------------
5493 package body PolyORB_Support
is
5495 -- Local subprograms
5497 procedure Add_RACW_Read_Attribute
5498 (RACW_Type
: Entity_Id
;
5499 Stub_Type
: Entity_Id
;
5500 Stub_Type_Access
: Entity_Id
;
5501 Body_Decls
: List_Id
);
5502 -- Add Read attribute for the RACW type. The declaration and attribute
5503 -- definition clauses are inserted right after the declaration of
5504 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5505 -- appended to it (case where the RACW declaration is in the main unit).
5507 procedure Add_RACW_Write_Attribute
5508 (RACW_Type
: Entity_Id
;
5509 Stub_Type
: Entity_Id
;
5510 Stub_Type_Access
: Entity_Id
;
5511 Body_Decls
: List_Id
);
5512 -- Same as above for the Write attribute
5514 procedure Add_RACW_From_Any
5515 (RACW_Type
: Entity_Id
;
5516 Body_Decls
: List_Id
);
5517 -- Add the From_Any TSS for this RACW type
5519 procedure Add_RACW_To_Any
5520 (RACW_Type
: Entity_Id
;
5521 Body_Decls
: List_Id
);
5522 -- Add the To_Any TSS for this RACW type
5524 procedure Add_RACW_TypeCode
5525 (Designated_Type
: Entity_Id
;
5526 RACW_Type
: Entity_Id
;
5527 Body_Decls
: List_Id
);
5528 -- Add the TypeCode TSS for this RACW type
5530 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
);
5531 -- Add the From_Any TSS for this RAS type
5533 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
);
5534 -- Add the To_Any TSS for this RAS type
5536 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
);
5537 -- Add the TypeCode TSS for this RAS type
5539 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
5540 -- Add a subprogram body for RAS Access TSS
5542 -------------------------------------
5543 -- Add_Obj_RPC_Receiver_Completion --
5544 -------------------------------------
5546 procedure Add_Obj_RPC_Receiver_Completion
5549 RPC_Receiver
: Entity_Id
;
5550 Stub_Elements
: Stub_Structure
)
5552 Desig
: constant Entity_Id
:=
5553 Etype
(Designated_Type
(Stub_Elements
.RACW_Type
));
5556 Make_Procedure_Call_Statement
(Loc
,
5559 RTE
(RE_Register_Obj_Receiving_Stub
), Loc
),
5561 Parameter_Associations
=> New_List
(
5565 Make_String_Literal
(Loc
,
5566 Full_Qualified_Name
(Desig
)),
5570 Make_Attribute_Reference
(Loc
,
5573 Defining_Unit_Name
(Parent
(RPC_Receiver
)), Loc
),
5579 Make_Attribute_Reference
(Loc
,
5582 Defining_Identifier
(
5583 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5586 end Add_Obj_RPC_Receiver_Completion
;
5588 -----------------------
5589 -- Add_RACW_Features --
5590 -----------------------
5592 procedure Add_RACW_Features
5593 (RACW_Type
: Entity_Id
;
5595 Stub_Type
: Entity_Id
;
5596 Stub_Type_Access
: Entity_Id
;
5597 RPC_Receiver_Decl
: Node_Id
;
5598 Body_Decls
: List_Id
)
5600 pragma Unreferenced
(RPC_Receiver_Decl
);
5604 (RACW_Type
=> RACW_Type
,
5605 Body_Decls
=> Body_Decls
);
5608 (RACW_Type
=> RACW_Type
,
5609 Body_Decls
=> Body_Decls
);
5611 Add_RACW_Write_Attribute
5612 (RACW_Type
=> RACW_Type
,
5613 Stub_Type
=> Stub_Type
,
5614 Stub_Type_Access
=> Stub_Type_Access
,
5615 Body_Decls
=> Body_Decls
);
5617 Add_RACW_Read_Attribute
5618 (RACW_Type
=> RACW_Type
,
5619 Stub_Type
=> Stub_Type
,
5620 Stub_Type_Access
=> Stub_Type_Access
,
5621 Body_Decls
=> Body_Decls
);
5624 (Designated_Type
=> Desig
,
5625 RACW_Type
=> RACW_Type
,
5626 Body_Decls
=> Body_Decls
);
5627 end Add_RACW_Features
;
5629 -----------------------
5630 -- Add_RACW_From_Any --
5631 -----------------------
5633 procedure Add_RACW_From_Any
5634 (RACW_Type
: Entity_Id
;
5635 Body_Decls
: List_Id
)
5637 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5638 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5640 Fnam
: constant Entity_Id
:=
5641 Make_Defining_Identifier
(Loc
,
5642 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'F'));
5644 Func_Spec
: Node_Id
;
5645 Func_Decl
: Node_Id
;
5646 Func_Body
: Node_Id
;
5648 Statements
: List_Id
;
5649 -- Various parts of the subprogram
5651 Any_Parameter
: constant Entity_Id
:=
5652 Make_Defining_Identifier
(Loc
, Name_A
);
5654 Asynchronous_Flag
: constant Entity_Id
:=
5655 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5656 -- The flag object declared in Add_RACW_Asynchronous_Flag
5660 Make_Function_Specification
(Loc
,
5661 Defining_Unit_Name
=>
5663 Parameter_Specifications
=> New_List
(
5664 Make_Parameter_Specification
(Loc
,
5665 Defining_Identifier
=>
5668 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
5669 Result_Definition
=> New_Occurrence_Of
(RACW_Type
, Loc
));
5671 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5672 -- entity in the declaration spec, not those of the body spec.
5674 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5675 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5676 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_From_Any
);
5678 if No
(Body_Decls
) then
5682 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5683 -- set on the stub type if, and only if, the RACW type has a pragma
5684 -- Asynchronous. This is incorrect for RACWs that implement RAS
5685 -- types, because in that case the /designated subprogram/ (not the
5686 -- type) might be asynchronous, and that causes the stub to need to
5687 -- be asynchronous too. A solution is to transport a RAS as a struct
5688 -- containing a RACW and an asynchronous flag, and to properly alter
5689 -- the Asynchronous component in the stub type in the RAS's _From_Any
5692 Statements
:= New_List
(
5693 Make_Simple_Return_Statement
(Loc
,
5694 Expression
=> Unchecked_Convert_To
(RACW_Type
,
5695 Make_Function_Call
(Loc
,
5696 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RACW
), Loc
),
5697 Parameter_Associations
=> New_List
(
5698 Make_Function_Call
(Loc
,
5699 Name
=> New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
5700 Parameter_Associations
=> New_List
(
5701 New_Occurrence_Of
(Any_Parameter
, Loc
))),
5702 Build_Stub_Tag
(Loc
, RACW_Type
),
5703 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5704 New_Occurrence_Of
(Asynchronous_Flag
, Loc
))))));
5707 Make_Subprogram_Body
(Loc
,
5708 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
5709 Declarations
=> No_List
,
5710 Handled_Statement_Sequence
=>
5711 Make_Handled_Sequence_Of_Statements
(Loc
,
5712 Statements
=> Statements
));
5714 Append_To
(Body_Decls
, Func_Body
);
5715 end Add_RACW_From_Any
;
5717 -----------------------------
5718 -- Add_RACW_Read_Attribute --
5719 -----------------------------
5721 procedure Add_RACW_Read_Attribute
5722 (RACW_Type
: Entity_Id
;
5723 Stub_Type
: Entity_Id
;
5724 Stub_Type_Access
: Entity_Id
;
5725 Body_Decls
: List_Id
)
5727 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
5729 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5731 Proc_Decl
: Node_Id
;
5732 Attr_Decl
: Node_Id
;
5734 Body_Node
: Node_Id
;
5736 Decls
: constant List_Id
:= New_List
;
5737 Statements
: constant List_Id
:= New_List
;
5738 Reference
: constant Entity_Id
:=
5739 Make_Defining_Identifier
(Loc
, Name_R
);
5740 -- Various parts of the procedure
5742 Pnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
5743 New_Internal_Name
('R'));
5745 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5747 Asynchronous_Flag
: constant Entity_Id
:=
5748 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5749 pragma Assert
(Present
(Asynchronous_Flag
));
5751 function Stream_Parameter
return Node_Id
;
5752 function Result
return Node_Id
;
5754 -- Functions to create occurrences of the formal parameter names
5760 function Result
return Node_Id
is
5762 return Make_Identifier
(Loc
, Name_V
);
5765 ----------------------
5766 -- Stream_Parameter --
5767 ----------------------
5769 function Stream_Parameter
return Node_Id
is
5771 return Make_Identifier
(Loc
, Name_S
);
5772 end Stream_Parameter
;
5774 -- Start of processing for Add_RACW_Read_Attribute
5777 Build_Stream_Procedure
5778 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> True);
5780 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
5781 Copy_Specification
(Loc
, Specification
(Body_Node
)));
5784 Make_Attribute_Definition_Clause
(Loc
,
5785 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
5789 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
5791 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
5792 Insert_After
(Proc_Decl
, Attr_Decl
);
5794 if No
(Body_Decls
) then
5799 Make_Object_Declaration
(Loc
,
5800 Defining_Identifier
=>
5802 Object_Definition
=>
5803 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)));
5805 Append_List_To
(Statements
, New_List
(
5806 Make_Attribute_Reference
(Loc
,
5808 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5809 Attribute_Name
=> Name_Read
,
5810 Expressions
=> New_List
(
5812 New_Occurrence_Of
(Reference
, Loc
))),
5814 Make_Assignment_Statement
(Loc
,
5818 Unchecked_Convert_To
(RACW_Type
,
5819 Make_Function_Call
(Loc
,
5821 New_Occurrence_Of
(RTE
(RE_Get_RACW
), Loc
),
5822 Parameter_Associations
=> New_List
(
5823 New_Occurrence_Of
(Reference
, Loc
),
5824 Build_Stub_Tag
(Loc
, RACW_Type
),
5825 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5826 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)))))));
5828 Set_Declarations
(Body_Node
, Decls
);
5829 Append_To
(Body_Decls
, Body_Node
);
5830 end Add_RACW_Read_Attribute
;
5832 ---------------------
5833 -- Add_RACW_To_Any --
5834 ---------------------
5836 procedure Add_RACW_To_Any
5837 (RACW_Type
: Entity_Id
;
5838 Body_Decls
: List_Id
)
5840 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5842 Fnam
: constant Entity_Id
:=
5843 Make_Defining_Identifier
(Loc
,
5844 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'T'));
5846 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5848 Stub_Elements
: constant Stub_Structure
:=
5849 Get_Stub_Elements
(RACW_Type
);
5851 Func_Spec
: Node_Id
;
5852 Func_Decl
: Node_Id
;
5853 Func_Body
: Node_Id
;
5856 Statements
: List_Id
;
5857 -- Various parts of the subprogram
5859 RACW_Parameter
: constant Entity_Id
:=
5860 Make_Defining_Identifier
(Loc
, Name_R
);
5862 Reference
: constant Entity_Id
:=
5863 Make_Defining_Identifier
5864 (Loc
, New_Internal_Name
('R'));
5865 Any
: constant Entity_Id
:=
5866 Make_Defining_Identifier
5867 (Loc
, New_Internal_Name
('A'));
5871 Make_Function_Specification
(Loc
,
5872 Defining_Unit_Name
=>
5874 Parameter_Specifications
=> New_List
(
5875 Make_Parameter_Specification
(Loc
,
5876 Defining_Identifier
=>
5879 New_Occurrence_Of
(RACW_Type
, Loc
))),
5880 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
5882 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5883 -- entity in the declaration spec, not in the body spec.
5885 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5887 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5888 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_To_Any
);
5890 if No
(Body_Decls
) then
5896 -- R : constant Object_Ref :=
5902 -- RPC_Receiver'Access);
5906 Make_Object_Declaration
(Loc
,
5907 Defining_Identifier
=> Reference
,
5908 Constant_Present
=> True,
5909 Object_Definition
=>
5910 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5912 Make_Function_Call
(Loc
,
5913 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
5914 Parameter_Associations
=> New_List
(
5915 Unchecked_Convert_To
(RTE
(RE_Address
),
5916 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5917 Make_String_Literal
(Loc
,
5918 Strval
=> Full_Qualified_Name
5919 (Etype
(Designated_Type
(RACW_Type
)))),
5920 Build_Stub_Tag
(Loc
, RACW_Type
),
5921 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5922 Make_Attribute_Reference
(Loc
,
5925 (Defining_Identifier
5926 (Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5927 Attribute_Name
=> Name_Access
)))),
5929 Make_Object_Declaration
(Loc
,
5930 Defining_Identifier
=> Any
,
5931 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
5935 -- Any := TA_ObjRef (Reference);
5936 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
5939 Statements
:= New_List
(
5940 Make_Assignment_Statement
(Loc
,
5941 Name
=> New_Occurrence_Of
(Any
, Loc
),
5943 Make_Function_Call
(Loc
,
5944 Name
=> New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
5945 Parameter_Associations
=> New_List
(
5946 New_Occurrence_Of
(Reference
, Loc
)))),
5948 Make_Procedure_Call_Statement
(Loc
,
5949 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
5950 Parameter_Associations
=> New_List
(
5951 New_Occurrence_Of
(Any
, Loc
),
5952 Make_Selected_Component
(Loc
,
5954 Defining_Identifier
(
5955 Stub_Elements
.RPC_Receiver_Decl
),
5956 Selector_Name
=> Name_Obj_TypeCode
))),
5958 Make_Simple_Return_Statement
(Loc
,
5959 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
5962 Make_Subprogram_Body
(Loc
,
5963 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
5964 Declarations
=> Decls
,
5965 Handled_Statement_Sequence
=>
5966 Make_Handled_Sequence_Of_Statements
(Loc
,
5967 Statements
=> Statements
));
5968 Append_To
(Body_Decls
, Func_Body
);
5969 end Add_RACW_To_Any
;
5971 -----------------------
5972 -- Add_RACW_TypeCode --
5973 -----------------------
5975 procedure Add_RACW_TypeCode
5976 (Designated_Type
: Entity_Id
;
5977 RACW_Type
: Entity_Id
;
5978 Body_Decls
: List_Id
)
5980 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5982 Fnam
: constant Entity_Id
:=
5983 Make_Defining_Identifier
(Loc
,
5984 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'Y'));
5986 Stub_Elements
: constant Stub_Structure
:=
5987 Stubs_Table
.Get
(Designated_Type
);
5988 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5990 Func_Spec
: Node_Id
;
5991 Func_Decl
: Node_Id
;
5992 Func_Body
: Node_Id
;
5996 -- The spec for this subprogram has a dummy 'access RACW' argument,
5997 -- which serves only for overloading purposes.
6000 Make_Function_Specification
(Loc
,
6001 Defining_Unit_Name
=> Fnam
,
6002 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6004 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6005 -- entity in the declaration spec, not those of the body spec.
6007 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
6008 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
6009 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_TypeCode
);
6011 if No
(Body_Decls
) then
6016 Make_Subprogram_Body
(Loc
,
6017 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
6018 Declarations
=> Empty_List
,
6019 Handled_Statement_Sequence
=>
6020 Make_Handled_Sequence_Of_Statements
(Loc
,
6021 Statements
=> New_List
(
6022 Make_Simple_Return_Statement
(Loc
,
6024 Make_Selected_Component
(Loc
,
6027 (Stub_Elements
.RPC_Receiver_Decl
),
6028 Selector_Name
=> Name_Obj_TypeCode
)))));
6030 Append_To
(Body_Decls
, Func_Body
);
6031 end Add_RACW_TypeCode
;
6033 ------------------------------
6034 -- Add_RACW_Write_Attribute --
6035 ------------------------------
6037 procedure Add_RACW_Write_Attribute
6038 (RACW_Type
: Entity_Id
;
6039 Stub_Type
: Entity_Id
;
6040 Stub_Type_Access
: Entity_Id
;
6041 Body_Decls
: List_Id
)
6043 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
6045 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
6047 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
6049 Stub_Elements
: constant Stub_Structure
:=
6050 Get_Stub_Elements
(RACW_Type
);
6052 Body_Node
: Node_Id
;
6053 Proc_Decl
: Node_Id
;
6054 Attr_Decl
: Node_Id
;
6056 Statements
: constant List_Id
:= New_List
;
6057 Pnam
: constant Entity_Id
:=
6058 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
6060 function Stream_Parameter
return Node_Id
;
6061 function Object
return Node_Id
;
6062 -- Functions to create occurrences of the formal parameter names
6068 function Object
return Node_Id
is
6070 return Make_Identifier
(Loc
, Name_V
);
6073 ----------------------
6074 -- Stream_Parameter --
6075 ----------------------
6077 function Stream_Parameter
return Node_Id
is
6079 return Make_Identifier
(Loc
, Name_S
);
6080 end Stream_Parameter
;
6082 -- Start of processing for Add_RACW_Write_Attribute
6085 Build_Stream_Procedure
6086 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> False);
6089 Make_Subprogram_Declaration
(Loc
,
6090 Copy_Specification
(Loc
, Specification
(Body_Node
)));
6093 Make_Attribute_Definition_Clause
(Loc
,
6094 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
6095 Chars
=> Name_Write
,
6098 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
6100 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
6101 Insert_After
(Proc_Decl
, Attr_Decl
);
6103 if No
(Body_Decls
) then
6107 Append_To
(Statements
,
6108 Pack_Node_Into_Stream_Access
(Loc
,
6109 Stream
=> Stream_Parameter
,
6111 Make_Function_Call
(Loc
,
6112 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
6113 Parameter_Associations
=> New_List
(
6114 Unchecked_Convert_To
(RTE
(RE_Address
), Object
),
6115 Make_String_Literal
(Loc
,
6116 Strval
=> Full_Qualified_Name
6117 (Etype
(Designated_Type
(RACW_Type
)))),
6118 Build_Stub_Tag
(Loc
, RACW_Type
),
6119 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
6120 Make_Attribute_Reference
(Loc
,
6123 (Defining_Identifier
6124 (Stub_Elements
.RPC_Receiver_Decl
), Loc
),
6125 Attribute_Name
=> Name_Access
))),
6127 Etyp
=> RTE
(RE_Object_Ref
)));
6129 Append_To
(Body_Decls
, Body_Node
);
6130 end Add_RACW_Write_Attribute
;
6132 -----------------------
6133 -- Add_RAST_Features --
6134 -----------------------
6136 procedure Add_RAST_Features
6137 (Vis_Decl
: Node_Id
;
6138 RAS_Type
: Entity_Id
)
6141 Add_RAS_Access_TSS
(Vis_Decl
);
6143 Add_RAS_From_Any
(RAS_Type
);
6144 Add_RAS_TypeCode
(RAS_Type
);
6146 -- To_Any uses TypeCode, and therefore needs to be generated last
6148 Add_RAS_To_Any
(RAS_Type
);
6149 end Add_RAST_Features
;
6151 ------------------------
6152 -- Add_RAS_Access_TSS --
6153 ------------------------
6155 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
6156 Loc
: constant Source_Ptr
:= Sloc
(N
);
6158 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
6159 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
6160 -- Ras_Type is the access to subprogram type; Fat_Type is the
6161 -- corresponding record type.
6163 RACW_Type
: constant Entity_Id
:=
6164 Underlying_RACW_Type
(Ras_Type
);
6166 Stub_Elements
: constant Stub_Structure
:=
6167 Get_Stub_Elements
(RACW_Type
);
6169 Proc
: constant Entity_Id
:=
6170 Make_Defining_Identifier
(Loc
,
6171 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
6173 Proc_Spec
: Node_Id
;
6175 -- Formal parameters
6177 Package_Name
: constant Entity_Id
:=
6178 Make_Defining_Identifier
(Loc
,
6183 Subp_Id
: constant Entity_Id
:=
6184 Make_Defining_Identifier
(Loc
,
6187 -- Target subprogram
6189 Asynch_P
: constant Entity_Id
:=
6190 Make_Defining_Identifier
(Loc
,
6191 Chars
=> Name_Asynchronous
);
6192 -- Is the procedure to which the 'Access applies asynchronous?
6194 All_Calls_Remote
: constant Entity_Id
:=
6195 Make_Defining_Identifier
(Loc
,
6196 Chars
=> Name_All_Calls_Remote
);
6197 -- True if an All_Calls_Remote pragma applies to the RCI unit
6198 -- that contains the subprogram.
6200 -- Common local variables
6202 Proc_Decls
: List_Id
;
6203 Proc_Statements
: List_Id
;
6205 Subp_Ref
: constant Entity_Id
:=
6206 Make_Defining_Identifier
(Loc
, Name_R
);
6207 -- Reference that designates the target subprogram (returned
6208 -- by Get_RAS_Info).
6210 Is_Local
: constant Entity_Id
:=
6211 Make_Defining_Identifier
(Loc
, Name_L
);
6212 Local_Addr
: constant Entity_Id
:=
6213 Make_Defining_Identifier
(Loc
, Name_A
);
6214 -- For the call to Get_Local_Address
6216 -- Additional local variables for the remote case
6218 Local_Stub
: constant Entity_Id
:=
6219 Make_Defining_Identifier
(Loc
,
6220 Chars
=> New_Internal_Name
('L'));
6222 Stub_Ptr
: constant Entity_Id
:=
6223 Make_Defining_Identifier
(Loc
,
6224 Chars
=> New_Internal_Name
('S'));
6227 (Field_Name
: Name_Id
;
6228 Value
: Node_Id
) return Node_Id
;
6229 -- Construct an assignment that sets the named component in the
6237 (Field_Name
: Name_Id
;
6238 Value
: Node_Id
) return Node_Id
6242 Make_Assignment_Statement
(Loc
,
6244 Make_Selected_Component
(Loc
,
6246 Selector_Name
=> Field_Name
),
6247 Expression
=> Value
);
6250 -- Start of processing for Add_RAS_Access_TSS
6253 Proc_Decls
:= New_List
(
6255 -- Common declarations
6257 Make_Object_Declaration
(Loc
,
6258 Defining_Identifier
=> Subp_Ref
,
6259 Object_Definition
=>
6260 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
6262 Make_Object_Declaration
(Loc
,
6263 Defining_Identifier
=> Is_Local
,
6264 Object_Definition
=>
6265 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6267 Make_Object_Declaration
(Loc
,
6268 Defining_Identifier
=> Local_Addr
,
6269 Object_Definition
=>
6270 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
6272 Make_Object_Declaration
(Loc
,
6273 Defining_Identifier
=> Local_Stub
,
6274 Aliased_Present
=> True,
6275 Object_Definition
=>
6276 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
6278 Make_Object_Declaration
(Loc
,
6279 Defining_Identifier
=> Stub_Ptr
,
6280 Object_Definition
=>
6281 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
6283 Make_Attribute_Reference
(Loc
,
6284 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
6285 Attribute_Name
=> Name_Unchecked_Access
)));
6287 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
6288 -- Build_Get_Unique_RP_Call needs this information
6290 -- Get_RAS_Info (Pkg, Subp, R);
6291 -- Obtain a reference to the target subprogram
6293 Proc_Statements
:= New_List
(
6294 Make_Procedure_Call_Statement
(Loc
,
6295 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
6296 Parameter_Associations
=> New_List
(
6297 New_Occurrence_Of
(Package_Name
, Loc
),
6298 New_Occurrence_Of
(Subp_Id
, Loc
),
6299 New_Occurrence_Of
(Subp_Ref
, Loc
))),
6301 -- Get_Local_Address (R, L, A);
6302 -- Determine whether the subprogram is local (L), and if so
6303 -- obtain the local address of its proxy (A).
6305 Make_Procedure_Call_Statement
(Loc
,
6306 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6307 Parameter_Associations
=> New_List
(
6308 New_Occurrence_Of
(Subp_Ref
, Loc
),
6309 New_Occurrence_Of
(Is_Local
, Loc
),
6310 New_Occurrence_Of
(Local_Addr
, Loc
))));
6312 -- Note: Here we assume that the Fat_Type is a record containing just
6313 -- an access to a proxy or stub object.
6315 Append_To
(Proc_Statements
,
6319 Make_Implicit_If_Statement
(N
,
6320 Condition
=> New_Occurrence_Of
(Is_Local
, Loc
),
6322 Then_Statements
=> New_List
(
6324 -- if A.Target = null then
6326 Make_Implicit_If_Statement
(N
,
6329 Make_Selected_Component
(Loc
,
6331 Unchecked_Convert_To
6332 (RTE
(RE_RAS_Proxy_Type_Access
),
6333 New_Occurrence_Of
(Local_Addr
, Loc
)),
6334 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)),
6337 Then_Statements
=> New_List
(
6339 -- A.Target := Entity_Of (Ref);
6341 Make_Assignment_Statement
(Loc
,
6343 Make_Selected_Component
(Loc
,
6345 Unchecked_Convert_To
6346 (RTE
(RE_RAS_Proxy_Type_Access
),
6347 New_Occurrence_Of
(Local_Addr
, Loc
)),
6348 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)),
6350 Make_Function_Call
(Loc
,
6351 Name
=> New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6352 Parameter_Associations
=> New_List
(
6353 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6355 -- Inc_Usage (A.Target);
6357 Make_Procedure_Call_Statement
(Loc
,
6358 Name
=> New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6359 Parameter_Associations
=> New_List
(
6360 Make_Selected_Component
(Loc
,
6362 Unchecked_Convert_To
6363 (RTE
(RE_RAS_Proxy_Type_Access
),
6364 New_Occurrence_Of
(Local_Addr
, Loc
)),
6366 Make_Identifier
(Loc
, Name_Target
)))))),
6369 -- if not All_Calls_Remote then
6370 -- return Fat_Type!(A);
6373 Make_Implicit_If_Statement
(N
,
6377 New_Occurrence_Of
(All_Calls_Remote
, Loc
)),
6379 Then_Statements
=> New_List
(
6380 Make_Simple_Return_Statement
(Loc
,
6382 Unchecked_Convert_To
6383 (Fat_Type
, New_Occurrence_Of
(Local_Addr
, Loc
))))))));
6385 Append_List_To
(Proc_Statements
, New_List
(
6387 -- Stub.Target := Entity_Of (Ref);
6389 Set_Field
(Name_Target
,
6390 Make_Function_Call
(Loc
,
6391 Name
=> New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6392 Parameter_Associations
=> New_List
(
6393 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6395 -- Inc_Usage (Stub.Target);
6397 Make_Procedure_Call_Statement
(Loc
,
6398 Name
=> New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6399 Parameter_Associations
=> New_List
(
6400 Make_Selected_Component
(Loc
,
6402 Selector_Name
=> Name_Target
))),
6404 -- E.4.1(9) A remote call is asynchronous if it is a call to
6405 -- a procedure, or a call through a value of an access-to-procedure
6406 -- type, to which a pragma Asynchronous applies.
6408 -- Parameter Asynch_P is true when the procedure is asynchronous;
6409 -- Expression Asynch_T is true when the type is asynchronous.
6411 Set_Field
(Name_Asynchronous
,
6413 Left_Opnd
=> New_Occurrence_Of
(Asynch_P
, Loc
),
6416 (Boolean_Literals
(Is_Asynchronous
(Ras_Type
)), Loc
)))));
6418 Append_List_To
(Proc_Statements
,
6419 Build_Get_Unique_RP_Call
(Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
6421 Append_To
(Proc_Statements
,
6422 Make_Simple_Return_Statement
(Loc
,
6424 Unchecked_Convert_To
(Fat_Type
,
6425 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
6428 Make_Function_Specification
(Loc
,
6429 Defining_Unit_Name
=> Proc
,
6430 Parameter_Specifications
=> New_List
(
6431 Make_Parameter_Specification
(Loc
,
6432 Defining_Identifier
=> Package_Name
,
6434 New_Occurrence_Of
(Standard_String
, Loc
)),
6436 Make_Parameter_Specification
(Loc
,
6437 Defining_Identifier
=> Subp_Id
,
6439 New_Occurrence_Of
(Standard_String
, Loc
)),
6441 Make_Parameter_Specification
(Loc
,
6442 Defining_Identifier
=> Asynch_P
,
6444 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6446 Make_Parameter_Specification
(Loc
,
6447 Defining_Identifier
=> All_Calls_Remote
,
6449 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
6451 Result_Definition
=>
6452 New_Occurrence_Of
(Fat_Type
, Loc
));
6454 -- Set the kind and return type of the function to prevent
6455 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6457 Set_Ekind
(Proc
, E_Function
);
6458 Set_Etype
(Proc
, Fat_Type
);
6461 Make_Subprogram_Body
(Loc
,
6462 Specification
=> Proc_Spec
,
6463 Declarations
=> Proc_Decls
,
6464 Handled_Statement_Sequence
=>
6465 Make_Handled_Sequence_Of_Statements
(Loc
,
6466 Statements
=> Proc_Statements
)));
6468 Set_TSS
(Fat_Type
, Proc
);
6469 end Add_RAS_Access_TSS
;
6471 ----------------------
6472 -- Add_RAS_From_Any --
6473 ----------------------
6475 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
) is
6476 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6478 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6479 Make_TSS_Name
(RAS_Type
, TSS_From_Any
));
6481 Func_Spec
: Node_Id
;
6483 Statements
: List_Id
;
6485 Any_Parameter
: constant Entity_Id
:=
6486 Make_Defining_Identifier
(Loc
, Name_A
);
6489 Statements
:= New_List
(
6490 Make_Simple_Return_Statement
(Loc
,
6492 Make_Aggregate
(Loc
,
6493 Component_Associations
=> New_List
(
6494 Make_Component_Association
(Loc
,
6495 Choices
=> New_List
(
6496 Make_Identifier
(Loc
, Name_Ras
)),
6498 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
6499 Underlying_RACW_Type
(RAS_Type
),
6500 New_Occurrence_Of
(Any_Parameter
, Loc
),
6504 Make_Function_Specification
(Loc
,
6505 Defining_Unit_Name
=> Fnam
,
6506 Parameter_Specifications
=> New_List
(
6507 Make_Parameter_Specification
(Loc
,
6508 Defining_Identifier
=> Any_Parameter
,
6509 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
6510 Result_Definition
=> New_Occurrence_Of
(RAS_Type
, Loc
));
6513 Make_Subprogram_Body
(Loc
,
6514 Specification
=> Func_Spec
,
6515 Declarations
=> No_List
,
6516 Handled_Statement_Sequence
=>
6517 Make_Handled_Sequence_Of_Statements
(Loc
,
6518 Statements
=> Statements
)));
6519 Set_TSS
(RAS_Type
, Fnam
);
6520 end Add_RAS_From_Any
;
6522 --------------------
6523 -- Add_RAS_To_Any --
6524 --------------------
6526 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
) is
6527 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6529 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6530 Make_TSS_Name
(RAS_Type
, TSS_To_Any
));
6533 Statements
: List_Id
;
6535 Func_Spec
: Node_Id
;
6537 Any
: constant Entity_Id
:=
6538 Make_Defining_Identifier
(Loc
,
6539 Chars
=> New_Internal_Name
('A'));
6540 RAS_Parameter
: constant Entity_Id
:=
6541 Make_Defining_Identifier
(Loc
,
6542 Chars
=> New_Internal_Name
('R'));
6543 RACW_Parameter
: constant Node_Id
:=
6544 Make_Selected_Component
(Loc
,
6545 Prefix
=> RAS_Parameter
,
6546 Selector_Name
=> Name_Ras
);
6549 -- Object declarations
6551 Set_Etype
(RACW_Parameter
, Underlying_RACW_Type
(RAS_Type
));
6553 Make_Object_Declaration
(Loc
,
6554 Defining_Identifier
=> Any
,
6555 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
6557 PolyORB_Support
.Helpers
.Build_To_Any_Call
6558 (RACW_Parameter
, No_List
)));
6560 Statements
:= New_List
(
6561 Make_Procedure_Call_Statement
(Loc
,
6562 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
6563 Parameter_Associations
=> New_List
(
6564 New_Occurrence_Of
(Any
, Loc
),
6565 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
6568 Make_Simple_Return_Statement
(Loc
,
6569 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
6572 Make_Function_Specification
(Loc
,
6573 Defining_Unit_Name
=> Fnam
,
6574 Parameter_Specifications
=> New_List
(
6575 Make_Parameter_Specification
(Loc
,
6576 Defining_Identifier
=> RAS_Parameter
,
6577 Parameter_Type
=> New_Occurrence_Of
(RAS_Type
, Loc
))),
6578 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
6581 Make_Subprogram_Body
(Loc
,
6582 Specification
=> Func_Spec
,
6583 Declarations
=> Decls
,
6584 Handled_Statement_Sequence
=>
6585 Make_Handled_Sequence_Of_Statements
(Loc
,
6586 Statements
=> Statements
)));
6587 Set_TSS
(RAS_Type
, Fnam
);
6590 ----------------------
6591 -- Add_RAS_TypeCode --
6592 ----------------------
6594 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
) is
6595 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6597 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6598 Make_TSS_Name
(RAS_Type
, TSS_TypeCode
));
6600 Func_Spec
: Node_Id
;
6601 Decls
: constant List_Id
:= New_List
;
6602 Name_String
: String_Id
;
6603 Repo_Id_String
: String_Id
;
6607 Make_Function_Specification
(Loc
,
6608 Defining_Unit_Name
=> Fnam
,
6609 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6611 PolyORB_Support
.Helpers
.Build_Name_And_Repository_Id
6612 (RAS_Type
, Name_Str
=> Name_String
, Repo_Id_Str
=> Repo_Id_String
);
6615 Make_Subprogram_Body
(Loc
,
6616 Specification
=> Func_Spec
,
6617 Declarations
=> Decls
,
6618 Handled_Statement_Sequence
=>
6619 Make_Handled_Sequence_Of_Statements
(Loc
,
6620 Statements
=> New_List
(
6621 Make_Simple_Return_Statement
(Loc
,
6623 Make_Function_Call
(Loc
,
6624 Name
=> New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
6625 Parameter_Associations
=> New_List
(
6626 New_Occurrence_Of
(RTE
(RE_TC_Object
), Loc
),
6627 Make_Aggregate
(Loc
,
6630 Make_Function_Call
(Loc
,
6633 (RTE
(RE_TA_Std_String
), Loc
),
6634 Parameter_Associations
=> New_List
(
6635 Make_String_Literal
(Loc
, Name_String
))),
6636 Make_Function_Call
(Loc
,
6639 (RTE
(RE_TA_Std_String
), Loc
),
6640 Parameter_Associations
=> New_List
(
6641 Make_String_Literal
(Loc
,
6642 Strval
=> Repo_Id_String
))))))))))));
6643 Set_TSS
(RAS_Type
, Fnam
);
6644 end Add_RAS_TypeCode
;
6646 -----------------------------------------
6647 -- Add_Receiving_Stubs_To_Declarations --
6648 -----------------------------------------
6650 procedure Add_Receiving_Stubs_To_Declarations
6651 (Pkg_Spec
: Node_Id
;
6655 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
6657 Pkg_RPC_Receiver
: constant Entity_Id
:=
6658 Make_Defining_Identifier
(Loc
,
6659 New_Internal_Name
('H'));
6660 Pkg_RPC_Receiver_Object
: Node_Id
;
6661 Pkg_RPC_Receiver_Body
: Node_Id
;
6662 Pkg_RPC_Receiver_Decls
: List_Id
;
6663 Pkg_RPC_Receiver_Statements
: List_Id
;
6665 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
6666 -- A Pkg_RPC_Receiver is built to decode the request
6669 -- Request object received from neutral layer
6671 Subp_Id
: Entity_Id
;
6672 -- Subprogram identifier as received from the neutral
6673 -- distribution core.
6675 Subp_Index
: Entity_Id
;
6676 -- Internal index as determined by matching either the method name
6677 -- from the request structure, or the local subprogram address (in
6680 Is_Local
: constant Entity_Id
:=
6681 Make_Defining_Identifier
(Loc
,
6682 Chars
=> New_Internal_Name
('L'));
6684 Local_Address
: constant Entity_Id
:=
6685 Make_Defining_Identifier
(Loc
,
6686 Chars
=> New_Internal_Name
('A'));
6687 -- Address of a local subprogram designated by a reference
6688 -- corresponding to a RAS.
6690 Dispatch_On_Address
: constant List_Id
:= New_List
;
6691 Dispatch_On_Name
: constant List_Id
:= New_List
;
6693 Current_Declaration
: Node_Id
;
6694 Current_Stubs
: Node_Id
;
6695 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
6697 Subp_Info_Array
: constant Entity_Id
:=
6698 Make_Defining_Identifier
(Loc
,
6699 Chars
=> New_Internal_Name
('I'));
6701 Subp_Info_List
: constant List_Id
:= New_List
;
6703 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
6705 All_Calls_Remote_E
: Entity_Id
;
6707 procedure Append_Stubs_To
6708 (RPC_Receiver_Cases
: List_Id
;
6709 Declaration
: Node_Id
;
6712 Subp_Dist_Name
: Entity_Id
;
6713 Subp_Proxy_Addr
: Entity_Id
);
6714 -- Add one case to the specified RPC receiver case list associating
6715 -- Subprogram_Number with the subprogram declared by Declaration, for
6716 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6717 -- subprogram index. Subp_Dist_Name is the string used to call the
6718 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6719 -- object, used in the context of calls through remote
6720 -- access-to-subprogram types.
6722 ---------------------
6723 -- Append_Stubs_To --
6724 ---------------------
6726 procedure Append_Stubs_To
6727 (RPC_Receiver_Cases
: List_Id
;
6728 Declaration
: Node_Id
;
6731 Subp_Dist_Name
: Entity_Id
;
6732 Subp_Proxy_Addr
: Entity_Id
)
6734 Case_Stmts
: List_Id
;
6736 Case_Stmts
:= New_List
(
6737 Make_Procedure_Call_Statement
(Loc
,
6740 Defining_Entity
(Stubs
), Loc
),
6741 Parameter_Associations
=>
6742 New_List
(New_Occurrence_Of
(Request
, Loc
))));
6744 if Nkind
(Specification
(Declaration
)) = N_Function_Specification
6746 Is_Asynchronous
(Defining_Entity
(Specification
(Declaration
)))
6748 Append_To
(Case_Stmts
, Make_Simple_Return_Statement
(Loc
));
6751 Append_To
(RPC_Receiver_Cases
,
6752 Make_Case_Statement_Alternative
(Loc
,
6754 New_List
(Make_Integer_Literal
(Loc
, Subp_Number
)),
6755 Statements
=> Case_Stmts
));
6757 Append_To
(Dispatch_On_Name
,
6758 Make_Elsif_Part
(Loc
,
6760 Make_Function_Call
(Loc
,
6762 New_Occurrence_Of
(RTE
(RE_Caseless_String_Eq
), Loc
),
6763 Parameter_Associations
=> New_List
(
6764 New_Occurrence_Of
(Subp_Id
, Loc
),
6765 New_Occurrence_Of
(Subp_Dist_Name
, Loc
))),
6767 Then_Statements
=> New_List
(
6768 Make_Assignment_Statement
(Loc
,
6769 New_Occurrence_Of
(Subp_Index
, Loc
),
6770 Make_Integer_Literal
(Loc
, Subp_Number
)))));
6772 Append_To
(Dispatch_On_Address
,
6773 Make_Elsif_Part
(Loc
,
6776 Left_Opnd
=> New_Occurrence_Of
(Local_Address
, Loc
),
6777 Right_Opnd
=> New_Occurrence_Of
(Subp_Proxy_Addr
, Loc
)),
6779 Then_Statements
=> New_List
(
6780 Make_Assignment_Statement
(Loc
,
6781 New_Occurrence_Of
(Subp_Index
, Loc
),
6782 Make_Integer_Literal
(Loc
, Subp_Number
)))));
6783 end Append_Stubs_To
;
6785 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6788 -- Building receiving stubs consist in several operations:
6790 -- - a package RPC receiver must be built. This subprogram
6791 -- will get a Subprogram_Id from the incoming stream
6792 -- and will dispatch the call to the right subprogram;
6794 -- - a receiving stub for each subprogram visible in the package
6795 -- spec. This stub will read all the parameters from the stream,
6796 -- and put the result as well as the exception occurrence in the
6799 -- - a dummy package with an empty spec and a body made of an
6800 -- elaboration part, whose job is to register the receiving
6801 -- part of this RCI package on the name server. This is done
6802 -- by calling System.Partition_Interface.Register_Receiving_Stub.
6804 Build_RPC_Receiver_Body
(
6805 RPC_Receiver
=> Pkg_RPC_Receiver
,
6808 Subp_Index
=> Subp_Index
,
6809 Stmts
=> Pkg_RPC_Receiver_Statements
,
6810 Decl
=> Pkg_RPC_Receiver_Body
);
6811 Pkg_RPC_Receiver_Decls
:= Declarations
(Pkg_RPC_Receiver_Body
);
6813 -- Extract local address information from the target reference:
6814 -- if non-null, that means that this is a reference that denotes
6815 -- one particular operation, and hence that the operation name
6816 -- must not be taken into account for dispatching.
6818 Append_To
(Pkg_RPC_Receiver_Decls
,
6819 Make_Object_Declaration
(Loc
,
6820 Defining_Identifier
=> Is_Local
,
6821 Object_Definition
=>
6822 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
6824 Append_To
(Pkg_RPC_Receiver_Decls
,
6825 Make_Object_Declaration
(Loc
,
6826 Defining_Identifier
=> Local_Address
,
6827 Object_Definition
=>
6828 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6830 Append_To
(Pkg_RPC_Receiver_Statements
,
6831 Make_Procedure_Call_Statement
(Loc
,
6832 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6833 Parameter_Associations
=> New_List
(
6834 Make_Selected_Component
(Loc
,
6836 Selector_Name
=> Name_Target
),
6837 New_Occurrence_Of
(Is_Local
, Loc
),
6838 New_Occurrence_Of
(Local_Address
, Loc
))));
6840 -- For each subprogram, the receiving stub will be built and a
6841 -- case statement will be made on the Subprogram_Id to dispatch
6842 -- to the right subprogram.
6844 All_Calls_Remote_E
:= Boolean_Literals
(
6845 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
6847 Overload_Counter_Table
.Reset
;
6848 Reserve_NamingContext_Methods
;
6850 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
6851 while Present
(Current_Declaration
) loop
6852 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
6853 and then Comes_From_Source
(Current_Declaration
)
6856 Loc
: constant Source_Ptr
:= Sloc
(Current_Declaration
);
6857 -- While specifically processing Current_Declaration, use
6858 -- its Sloc as the location of all generated nodes.
6860 Subp_Def
: constant Entity_Id
:=
6862 (Specification
(Current_Declaration
));
6864 Subp_Val
: String_Id
;
6866 Subp_Dist_Name
: constant Entity_Id
:=
6867 Make_Defining_Identifier
(Loc
,
6870 (Related_Id
=> Chars
(Subp_Def
),
6872 Suffix_Index
=> -1));
6874 Proxy_Object_Addr
: Entity_Id
;
6877 -- Build receiving stub
6880 Build_Subprogram_Receiving_Stubs
6881 (Vis_Decl
=> Current_Declaration
,
6883 Nkind
(Specification
(Current_Declaration
)) =
6884 N_Procedure_Specification
6885 and then Is_Asynchronous
(Subp_Def
));
6887 Append_To
(Decls
, Current_Stubs
);
6888 Analyze
(Current_Stubs
);
6892 Add_RAS_Proxy_And_Analyze
(Decls
,
6893 Vis_Decl
=> Current_Declaration
,
6894 All_Calls_Remote_E
=> All_Calls_Remote_E
,
6895 Proxy_Object_Addr
=> Proxy_Object_Addr
);
6897 -- Compute distribution identifier
6899 Assign_Subprogram_Identifier
6901 Current_Subprogram_Number
,
6905 (Current_Subprogram_Number
= Get_Subprogram_Id
(Subp_Def
));
6908 Make_Object_Declaration
(Loc
,
6909 Defining_Identifier
=> Subp_Dist_Name
,
6910 Constant_Present
=> True,
6911 Object_Definition
=>
6912 New_Occurrence_Of
(Standard_String
, Loc
),
6914 Make_String_Literal
(Loc
, Subp_Val
)));
6915 Analyze
(Last
(Decls
));
6917 -- Add subprogram descriptor (RCI_Subp_Info) to the
6918 -- subprograms table for this receiver. The aggregate
6919 -- below must be kept consistent with the declaration
6920 -- of type RCI_Subp_Info in System.Partition_Interface.
6922 Append_To
(Subp_Info_List
,
6923 Make_Component_Association
(Loc
,
6924 Choices
=> New_List
(
6925 Make_Integer_Literal
(Loc
, Current_Subprogram_Number
)),
6928 Make_Aggregate
(Loc
,
6929 Expressions
=> New_List
(
6930 Make_Attribute_Reference
(Loc
,
6932 New_Occurrence_Of
(Subp_Dist_Name
, Loc
),
6933 Attribute_Name
=> Name_Address
),
6935 Make_Attribute_Reference
(Loc
,
6937 New_Occurrence_Of
(Subp_Dist_Name
, Loc
),
6938 Attribute_Name
=> Name_Length
),
6940 New_Occurrence_Of
(Proxy_Object_Addr
, Loc
)))));
6942 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
6943 Declaration
=> Current_Declaration
,
6944 Stubs
=> Current_Stubs
,
6945 Subp_Number
=> Current_Subprogram_Number
,
6946 Subp_Dist_Name
=> Subp_Dist_Name
,
6947 Subp_Proxy_Addr
=> Proxy_Object_Addr
);
6950 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
6953 Next
(Current_Declaration
);
6957 Make_Object_Declaration
(Loc
,
6958 Defining_Identifier
=> Subp_Info_Array
,
6959 Constant_Present
=> True,
6960 Aliased_Present
=> True,
6961 Object_Definition
=>
6962 Make_Subtype_Indication
(Loc
,
6964 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
6966 Make_Index_Or_Discriminant_Constraint
(Loc
,
6970 Make_Integer_Literal
(Loc
,
6971 Intval
=> First_RCI_Subprogram_Id
),
6973 Make_Integer_Literal
(Loc
,
6975 First_RCI_Subprogram_Id
6976 + List_Length
(Subp_Info_List
) - 1)))))));
6978 if Present
(First
(Subp_Info_List
)) then
6979 Set_Expression
(Last
(Decls
),
6980 Make_Aggregate
(Loc
,
6981 Component_Associations
=> Subp_Info_List
));
6983 -- Generate the dispatch statement to determine the subprogram id
6984 -- of the called subprogram.
6986 -- We first test whether the reference that was used to make the
6987 -- call was the base RCI reference (in which case Local_Address is
6988 -- zero, and the method identifier from the request must be used
6989 -- to determine which subprogram is called) or a reference
6990 -- identifying one particular subprogram (in which case
6991 -- Local_Address is the address of that subprogram, and the
6992 -- method name from the request is ignored). The latter occurs
6993 -- for the case of a call through a remote access-to-subprogram.
6995 -- In each case, cascaded elsifs are used to determine the proper
6996 -- subprogram index. Using hash tables might be more efficient.
6998 Append_To
(Pkg_RPC_Receiver_Statements
,
6999 Make_Implicit_If_Statement
(Pkg_Spec
,
7002 Left_Opnd
=> New_Occurrence_Of
(Local_Address
, Loc
),
7003 Right_Opnd
=> New_Occurrence_Of
7004 (RTE
(RE_Null_Address
), Loc
)),
7006 Then_Statements
=> New_List
(
7007 Make_Implicit_If_Statement
(Pkg_Spec
,
7008 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
7009 Then_Statements
=> New_List
(
7010 Make_Null_Statement
(Loc
)),
7011 Elsif_Parts
=> Dispatch_On_Address
)),
7013 Else_Statements
=> New_List
(
7014 Make_Implicit_If_Statement
(Pkg_Spec
,
7015 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
7016 Then_Statements
=> New_List
(Make_Null_Statement
(Loc
)),
7017 Elsif_Parts
=> Dispatch_On_Name
))));
7020 -- For a degenerate RCI with no visible subprograms,
7021 -- Subp_Info_List has zero length, and the declaration is for an
7022 -- empty array, in which case no initialization aggregate must be
7023 -- generated. We do not generate a Dispatch_Statement either.
7025 -- No initialization provided: remove CONSTANT so that the
7026 -- declaration is not an incomplete deferred constant.
7028 Set_Constant_Present
(Last
(Decls
), False);
7031 -- Analyze Subp_Info_Array declaration
7033 Analyze
(Last
(Decls
));
7035 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7036 -- rather than raising an exception since we do not want someone
7037 -- to crash a remote partition by sending invalid subprogram ids.
7038 -- This is consistent with the other parts of the case statement
7039 -- since even in presence of incorrect parameters in the stream,
7040 -- every exception will be caught and (if the subprogram is not an
7041 -- APC) put into the result stream and sent away.
7043 Append_To
(Pkg_RPC_Receiver_Cases
,
7044 Make_Case_Statement_Alternative
(Loc
,
7045 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7046 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
7048 Append_To
(Pkg_RPC_Receiver_Statements
,
7049 Make_Case_Statement
(Loc
,
7050 Expression
=> New_Occurrence_Of
(Subp_Index
, Loc
),
7051 Alternatives
=> Pkg_RPC_Receiver_Cases
));
7053 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7056 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
7057 Analyze
(Last
(Decls
));
7059 Pkg_RPC_Receiver_Object
:=
7060 Make_Object_Declaration
(Loc
,
7061 Defining_Identifier
=>
7062 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
7063 Aliased_Present
=> True,
7064 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7065 Append_To
(Decls
, Pkg_RPC_Receiver_Object
);
7066 Analyze
(Last
(Decls
));
7068 Get_Library_Unit_Name_String
(Pkg_Spec
);
7072 Append_To
(Register_Pkg_Actuals
,
7073 Make_String_Literal
(Loc
,
7074 Strval
=> String_From_Name_Buffer
));
7078 Append_To
(Register_Pkg_Actuals
,
7079 Make_Attribute_Reference
(Loc
,
7082 (Defining_Entity
(Pkg_Spec
), Loc
),
7083 Attribute_Name
=> Name_Version
));
7087 Append_To
(Register_Pkg_Actuals
,
7088 Make_Attribute_Reference
(Loc
,
7090 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
7091 Attribute_Name
=> Name_Access
));
7095 Append_To
(Register_Pkg_Actuals
,
7096 Make_Attribute_Reference
(Loc
,
7099 Defining_Identifier
(Pkg_RPC_Receiver_Object
), Loc
),
7100 Attribute_Name
=> Name_Access
));
7104 Append_To
(Register_Pkg_Actuals
,
7105 Make_Attribute_Reference
(Loc
,
7106 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
7107 Attribute_Name
=> Name_Address
));
7111 Append_To
(Register_Pkg_Actuals
,
7112 Make_Attribute_Reference
(Loc
,
7113 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
7114 Attribute_Name
=> Name_Length
));
7116 -- Is_All_Calls_Remote
7118 Append_To
(Register_Pkg_Actuals
,
7119 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
));
7124 Make_Procedure_Call_Statement
(Loc
,
7126 New_Occurrence_Of
(RTE
(RE_Register_Pkg_Receiving_Stub
), Loc
),
7127 Parameter_Associations
=> Register_Pkg_Actuals
));
7128 Analyze
(Last
(Stmts
));
7129 end Add_Receiving_Stubs_To_Declarations
;
7131 ---------------------------------
7132 -- Build_General_Calling_Stubs --
7133 ---------------------------------
7135 procedure Build_General_Calling_Stubs
7137 Statements
: List_Id
;
7138 Target_Object
: Node_Id
;
7139 Subprogram_Id
: Node_Id
;
7140 Asynchronous
: Node_Id
:= Empty
;
7141 Is_Known_Asynchronous
: Boolean := False;
7142 Is_Known_Non_Asynchronous
: Boolean := False;
7143 Is_Function
: Boolean;
7145 Stub_Type
: Entity_Id
:= Empty
;
7146 RACW_Type
: Entity_Id
:= Empty
;
7149 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
7151 Request
: constant Entity_Id
:=
7152 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
7153 -- The request object constructed by these stubs
7154 -- Could we use Name_R instead??? (see GLADE client stubs)
7156 function Make_Request_RTE_Call
7158 Actuals
: List_Id
:= New_List
) return Node_Id
;
7159 -- Generate a procedure call statement calling RE with the given
7160 -- actuals. Request is appended to the list.
7162 ---------------------------
7163 -- Make_Request_RTE_Call --
7164 ---------------------------
7166 function Make_Request_RTE_Call
7168 Actuals
: List_Id
:= New_List
) return Node_Id
7171 Append_To
(Actuals
, New_Occurrence_Of
(Request
, Loc
));
7172 return Make_Procedure_Call_Statement
(Loc
,
7174 New_Occurrence_Of
(RTE
(RE
), Loc
),
7175 Parameter_Associations
=> Actuals
);
7176 end Make_Request_RTE_Call
;
7178 Arguments
: Node_Id
;
7179 -- Name of the named values list used to transmit parameters
7180 -- to the remote package
7183 -- Name of the result named value (in non-APC cases) which get the
7184 -- result of the remote subprogram.
7186 Result_TC
: Node_Id
;
7187 -- Typecode expression for the result of the request (void
7188 -- typecode for procedures).
7190 Exception_Return_Parameter
: Node_Id
;
7191 -- Name of the parameter which will hold the exception sent by the
7192 -- remote subprogram.
7194 Current_Parameter
: Node_Id
;
7195 -- Current parameter being handled
7197 Ordered_Parameters_List
: constant List_Id
:=
7198 Build_Ordered_Parameters_List
(Spec
);
7200 Asynchronous_P
: Node_Id
;
7201 -- A Boolean expression indicating whether this call is asynchronous
7203 Asynchronous_Statements
: List_Id
:= No_List
;
7204 Non_Asynchronous_Statements
: List_Id
:= No_List
;
7205 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7207 Extra_Formal_Statements
: constant List_Id
:= New_List
;
7208 -- List of statements for extra formal parameters. It will appear
7209 -- after the regular statements for writing out parameters.
7211 After_Statements
: constant List_Id
:= New_List
;
7212 -- Statements to be executed after call returns (to assign IN OUT or
7213 -- OUT parameter values).
7216 -- The type of the formal parameter being processed
7218 Is_Controlling_Formal
: Boolean;
7219 Is_First_Controlling_Formal
: Boolean;
7220 First_Controlling_Formal_Seen
: Boolean := False;
7221 -- Controlling formal parameters of distributed object primitives
7222 -- require special handling, and the first such parameter needs even
7223 -- more special handling.
7226 -- ??? document general form of stub subprograms for the PolyORB case
7229 Make_Object_Declaration
(Loc
,
7230 Defining_Identifier
=> Request
,
7231 Aliased_Present
=> False,
7232 Object_Definition
=>
7233 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
)));
7236 Make_Defining_Identifier
(Loc
,
7237 Chars
=> New_Internal_Name
('R'));
7241 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7242 (Loc
, Etype
(Result_Definition
(Spec
)), Decls
);
7244 Result_TC
:= New_Occurrence_Of
(RTE
(RE_TC_Void
), Loc
);
7248 Make_Object_Declaration
(Loc
,
7249 Defining_Identifier
=> Result
,
7250 Aliased_Present
=> False,
7251 Object_Definition
=>
7252 New_Occurrence_Of
(RTE
(RE_NamedValue
), Loc
),
7254 Make_Aggregate
(Loc
,
7255 Component_Associations
=> New_List
(
7256 Make_Component_Association
(Loc
,
7257 Choices
=> New_List
(Make_Identifier
(Loc
, Name_Name
)),
7259 New_Occurrence_Of
(RTE
(RE_Result_Name
), Loc
)),
7260 Make_Component_Association
(Loc
,
7261 Choices
=> New_List
(
7262 Make_Identifier
(Loc
, Name_Argument
)),
7264 Make_Function_Call
(Loc
,
7265 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7266 Parameter_Associations
=> New_List
(Result_TC
))),
7267 Make_Component_Association
(Loc
,
7268 Choices
=> New_List
(
7269 Make_Identifier
(Loc
, Name_Arg_Modes
)),
7270 Expression
=> Make_Integer_Literal
(Loc
, 0))))));
7272 if not Is_Known_Asynchronous
then
7273 Exception_Return_Parameter
:=
7274 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
7277 Make_Object_Declaration
(Loc
,
7278 Defining_Identifier
=> Exception_Return_Parameter
,
7279 Object_Definition
=>
7280 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
7283 Exception_Return_Parameter
:= Empty
;
7286 -- Initialize and fill in arguments list
7289 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
7290 Declare_Create_NVList
(Loc
, Arguments
, Decls
, Statements
);
7292 Current_Parameter
:= First
(Ordered_Parameters_List
);
7293 while Present
(Current_Parameter
) loop
7294 if Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
) then
7295 Is_Controlling_Formal
:= True;
7296 Is_First_Controlling_Formal
:=
7297 not First_Controlling_Formal_Seen
;
7298 First_Controlling_Formal_Seen
:= True;
7301 Is_Controlling_Formal
:= False;
7302 Is_First_Controlling_Formal
:= False;
7305 if Is_Controlling_Formal
then
7307 -- For a controlling formal argument, we send its reference
7312 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7315 -- The first controlling formal parameter is treated specially:
7316 -- it is used to set the target object of the call.
7318 if not Is_First_Controlling_Formal
then
7320 Constrained
: constant Boolean :=
7321 Is_Constrained
(Etyp
)
7322 or else Is_Elementary_Type
(Etyp
);
7324 Any
: constant Entity_Id
:=
7325 Make_Defining_Identifier
(Loc
,
7326 New_Internal_Name
('A'));
7328 Actual_Parameter
: Node_Id
:=
7330 Defining_Identifier
(
7331 Current_Parameter
), Loc
);
7336 if Is_Controlling_Formal
then
7338 -- For a controlling formal parameter (other than the
7339 -- first one), use the corresponding RACW. If the
7340 -- parameter is not an anonymous access parameter, that
7341 -- involves taking its 'Unrestricted_Access.
7343 if Nkind
(Parameter_Type
(Current_Parameter
))
7344 = N_Access_Definition
7346 Actual_Parameter
:= OK_Convert_To
7347 (Etyp
, Actual_Parameter
);
7349 Actual_Parameter
:= OK_Convert_To
(Etyp
,
7350 Make_Attribute_Reference
(Loc
,
7351 Prefix
=> Actual_Parameter
,
7352 Attribute_Name
=> Name_Unrestricted_Access
));
7357 if In_Present
(Current_Parameter
)
7358 or else not Out_Present
(Current_Parameter
)
7359 or else not Constrained
7360 or else Is_Controlling_Formal
7362 -- The parameter has an input value, is constrained at
7363 -- runtime by an input value, or is a controlling formal
7364 -- parameter (always passed as a reference) other than
7367 Expr
:= PolyORB_Support
.Helpers
.Build_To_Any_Call
7368 (Actual_Parameter
, Decls
);
7371 Expr
:= Make_Function_Call
(Loc
,
7372 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7373 Parameter_Associations
=> New_List
(
7374 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7375 (Loc
, Etyp
, Decls
)));
7379 Make_Object_Declaration
(Loc
,
7380 Defining_Identifier
=> Any
,
7381 Aliased_Present
=> False,
7382 Object_Definition
=>
7383 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7384 Expression
=> Expr
));
7386 Append_To
(Statements
,
7387 Add_Parameter_To_NVList
(Loc
,
7388 Parameter
=> Current_Parameter
,
7389 NVList
=> Arguments
,
7390 Constrained
=> Constrained
,
7393 if Out_Present
(Current_Parameter
)
7394 and then not Is_Controlling_Formal
7396 Append_To
(After_Statements
,
7397 Make_Assignment_Statement
(Loc
,
7400 Defining_Identifier
(Current_Parameter
), Loc
),
7402 PolyORB_Support
.Helpers
.Build_From_Any_Call
7403 (Etype
(Parameter_Type
(Current_Parameter
)),
7404 New_Occurrence_Of
(Any
, Loc
),
7411 -- If the current parameter has a dynamic constrained status, then
7412 -- this status is transmitted as well.
7413 -- This should be done for accessibility as well ???
7415 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7417 and then Need_Extra_Constrained
(Current_Parameter
)
7419 -- In this block, we do not use the extra formal that has been
7420 -- created because it does not exist at the time of expansion
7421 -- when building calling stubs for remote access to subprogram
7422 -- types. We create an extra variable of this type and push it
7423 -- in the stream after the regular parameters.
7426 Extra_Any_Parameter
: constant Entity_Id
:=
7427 Make_Defining_Identifier
7428 (Loc
, New_Internal_Name
('P'));
7430 Parameter_Exp
: constant Node_Id
:=
7431 Make_Attribute_Reference
(Loc
,
7432 Prefix
=> New_Occurrence_Of
(
7433 Defining_Identifier
(Current_Parameter
), Loc
),
7434 Attribute_Name
=> Name_Constrained
);
7437 Set_Etype
(Parameter_Exp
, Etype
(Standard_Boolean
));
7440 Make_Object_Declaration
(Loc
,
7441 Defining_Identifier
=> Extra_Any_Parameter
,
7442 Aliased_Present
=> False,
7443 Object_Definition
=>
7444 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7446 PolyORB_Support
.Helpers
.Build_To_Any_Call
7447 (Parameter_Exp
, Decls
)));
7449 Append_To
(Extra_Formal_Statements
,
7450 Add_Parameter_To_NVList
(Loc
,
7451 Parameter
=> Extra_Any_Parameter
,
7452 NVList
=> Arguments
,
7453 Constrained
=> True,
7454 Any
=> Extra_Any_Parameter
));
7458 Next
(Current_Parameter
);
7461 -- Append the formal statements list to the statements
7463 Append_List_To
(Statements
, Extra_Formal_Statements
);
7465 Append_To
(Statements
,
7466 Make_Request_RTE_Call
(RE_Request_Create
, New_List
(
7469 New_Occurrence_Of
(Arguments
, Loc
),
7470 New_Occurrence_Of
(Result
, Loc
),
7472 (RTE
(RE_Nil_Exc_List
), Loc
))));
7475 (not (Is_Known_Non_Asynchronous
and Is_Known_Asynchronous
));
7477 if Is_Known_Non_Asynchronous
or Is_Known_Asynchronous
then
7480 (Boolean_Literals
(Is_Known_Asynchronous
), Loc
);
7483 pragma Assert
(Present
(Asynchronous
));
7484 Asynchronous_P
:= New_Copy_Tree
(Asynchronous
);
7486 -- The expression node Asynchronous will be used to build an 'if'
7487 -- statement at the end of Build_General_Calling_Stubs: we need to
7488 -- make a copy here.
7491 Append_To
(Parameter_Associations
(Last
(Statements
)),
7492 Make_Indexed_Component
(Loc
,
7495 RTE
(RE_Asynchronous_P_To_Sync_Scope
), Loc
),
7496 Expressions
=> New_List
(Asynchronous_P
)));
7498 Append_To
(Statements
, Make_Request_RTE_Call
(RE_Request_Invoke
));
7500 -- Asynchronous case
7502 if not Is_Known_Non_Asynchronous
then
7503 Asynchronous_Statements
:=
7504 New_List
(Make_Request_RTE_Call
(RE_Request_Destroy
));
7507 -- Non-asynchronous case
7509 if not Is_Known_Asynchronous
then
7510 -- Reraise an exception occurrence from the completed request.
7511 -- If the exception occurrence is empty, this is a no-op.
7513 Non_Asynchronous_Statements
:= New_List
(
7514 Make_Procedure_Call_Statement
(Loc
,
7516 New_Occurrence_Of
(RTE
(RE_Request_Raise_Occurrence
), Loc
),
7517 Parameter_Associations
=> New_List
(
7518 New_Occurrence_Of
(Request
, Loc
))));
7522 Append_To
(Non_Asynchronous_Statements
,
7523 Make_Request_RTE_Call
(RE_Request_Destroy
));
7525 -- If this is a function call, read the value and return it
7527 Append_To
(Non_Asynchronous_Statements
,
7528 Make_Tag_Check
(Loc
,
7529 Make_Simple_Return_Statement
(Loc
,
7530 PolyORB_Support
.Helpers
.Build_From_Any_Call
7531 (Etype
(Result_Definition
(Spec
)),
7532 Make_Selected_Component
(Loc
,
7534 Selector_Name
=> Name_Argument
),
7539 -- Case of a procedure: deal with IN OUT and OUT formals
7541 Append_List_To
(Non_Asynchronous_Statements
, After_Statements
);
7543 Append_To
(Non_Asynchronous_Statements
,
7544 Make_Request_RTE_Call
(RE_Request_Destroy
));
7548 if Is_Known_Asynchronous
then
7549 Append_List_To
(Statements
, Asynchronous_Statements
);
7551 elsif Is_Known_Non_Asynchronous
then
7552 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
7555 pragma Assert
(Present
(Asynchronous
));
7556 Append_To
(Statements
,
7557 Make_Implicit_If_Statement
(Nod
,
7558 Condition
=> Asynchronous
,
7559 Then_Statements
=> Asynchronous_Statements
,
7560 Else_Statements
=> Non_Asynchronous_Statements
));
7562 end Build_General_Calling_Stubs
;
7564 -----------------------
7565 -- Build_Stub_Target --
7566 -----------------------
7568 function Build_Stub_Target
7571 RCI_Locator
: Entity_Id
;
7572 Controlling_Parameter
: Entity_Id
) return RPC_Target
7574 Target_Info
: RPC_Target
(PCS_Kind
=> Name_PolyORB_DSA
);
7575 Target_Reference
: constant Entity_Id
:=
7576 Make_Defining_Identifier
(Loc
,
7577 New_Internal_Name
('T'));
7579 if Present
(Controlling_Parameter
) then
7581 Make_Object_Declaration
(Loc
,
7582 Defining_Identifier
=> Target_Reference
,
7584 Object_Definition
=>
7585 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
7588 Make_Function_Call
(Loc
,
7590 New_Occurrence_Of
(RTE
(RE_Make_Ref
), Loc
),
7591 Parameter_Associations
=> New_List
(
7592 Make_Selected_Component
(Loc
,
7593 Prefix
=> Controlling_Parameter
,
7594 Selector_Name
=> Name_Target
)))));
7596 -- Note: Controlling_Parameter has the same components as
7597 -- System.Partition_Interface.RACW_Stub_Type.
7599 Target_Info
.Object
:= New_Occurrence_Of
(Target_Reference
, Loc
);
7602 Target_Info
.Object
:=
7603 Make_Selected_Component
(Loc
,
7604 Prefix
=> Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
7606 Make_Identifier
(Loc
, Name_Get_RCI_Package_Ref
));
7610 end Build_Stub_Target
;
7612 ---------------------
7613 -- Build_Stub_Type --
7614 ---------------------
7616 procedure Build_Stub_Type
7617 (RACW_Type
: Entity_Id
;
7618 Stub_Type
: Entity_Id
;
7619 Stub_Type_Decl
: out Node_Id
;
7620 RPC_Receiver_Decl
: out Node_Id
)
7622 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
7624 pragma Unreferenced
(RACW_Type
);
7628 Make_Full_Type_Declaration
(Loc
,
7629 Defining_Identifier
=> Stub_Type
,
7631 Make_Record_Definition
(Loc
,
7632 Tagged_Present
=> True,
7633 Limited_Present
=> True,
7635 Make_Component_List
(Loc
,
7636 Component_Items
=> New_List
(
7638 Make_Component_Declaration
(Loc
,
7639 Defining_Identifier
=>
7640 Make_Defining_Identifier
(Loc
, Name_Target
),
7641 Component_Definition
=>
7642 Make_Component_Definition
(Loc
,
7643 Aliased_Present
=> False,
7644 Subtype_Indication
=>
7645 New_Occurrence_Of
(RTE
(RE_Entity_Ptr
), Loc
))),
7647 Make_Component_Declaration
(Loc
,
7648 Defining_Identifier
=>
7649 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
7651 Component_Definition
=>
7652 Make_Component_Definition
(Loc
,
7653 Aliased_Present
=> False,
7654 Subtype_Indication
=>
7655 New_Occurrence_Of
(Standard_Boolean
, Loc
)))))));
7657 RPC_Receiver_Decl
:=
7658 Make_Object_Declaration
(Loc
,
7659 Defining_Identifier
=> Make_Defining_Identifier
(Loc
,
7660 New_Internal_Name
('R')),
7661 Aliased_Present
=> True,
7662 Object_Definition
=>
7663 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7664 end Build_Stub_Type
;
7666 -----------------------------
7667 -- Build_RPC_Receiver_Body --
7668 -----------------------------
7670 procedure Build_RPC_Receiver_Body
7671 (RPC_Receiver
: Entity_Id
;
7672 Request
: out Entity_Id
;
7673 Subp_Id
: out Entity_Id
;
7674 Subp_Index
: out Entity_Id
;
7675 Stmts
: out List_Id
;
7678 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
7680 RPC_Receiver_Spec
: Node_Id
;
7681 RPC_Receiver_Decls
: List_Id
;
7684 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
7686 RPC_Receiver_Spec
:=
7687 Build_RPC_Receiver_Specification
7688 (RPC_Receiver
=> RPC_Receiver
,
7689 Request_Parameter
=> Request
);
7691 Subp_Id
:= Make_Defining_Identifier
(Loc
, Name_P
);
7692 Subp_Index
:= Make_Defining_Identifier
(Loc
, Name_I
);
7694 RPC_Receiver_Decls
:= New_List
(
7695 Make_Object_Renaming_Declaration
(Loc
,
7696 Defining_Identifier
=> Subp_Id
,
7697 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
7699 Make_Explicit_Dereference
(Loc
,
7701 Make_Selected_Component
(Loc
,
7703 Selector_Name
=> Name_Operation
))),
7705 Make_Object_Declaration
(Loc
,
7706 Defining_Identifier
=> Subp_Index
,
7707 Object_Definition
=>
7708 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7710 Make_Attribute_Reference
(Loc
,
7712 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7713 Attribute_Name
=> Name_Last
)));
7718 Make_Subprogram_Body
(Loc
,
7719 Specification
=> RPC_Receiver_Spec
,
7720 Declarations
=> RPC_Receiver_Decls
,
7721 Handled_Statement_Sequence
=>
7722 Make_Handled_Sequence_Of_Statements
(Loc
,
7723 Statements
=> Stmts
));
7724 end Build_RPC_Receiver_Body
;
7726 --------------------------------------
7727 -- Build_Subprogram_Receiving_Stubs --
7728 --------------------------------------
7730 function Build_Subprogram_Receiving_Stubs
7731 (Vis_Decl
: Node_Id
;
7732 Asynchronous
: Boolean;
7733 Dynamically_Asynchronous
: Boolean := False;
7734 Stub_Type
: Entity_Id
:= Empty
;
7735 RACW_Type
: Entity_Id
:= Empty
;
7736 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
7738 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
7740 Request_Parameter
: constant Entity_Id
:=
7741 Make_Defining_Identifier
(Loc
,
7742 New_Internal_Name
('R'));
7743 -- Formal parameter for receiving stubs: a descriptor for an incoming
7746 Outer_Decls
: constant List_Id
:= New_List
;
7747 -- At the outermost level, an NVList and Any's are declared for all
7748 -- parameters. The Dynamic_Async flag also needs to be declared there
7749 -- to be visible from the exception handling code.
7751 Outer_Statements
: constant List_Id
:= New_List
;
7752 -- Statements that occur prior to the declaration of the actual
7753 -- parameter variables.
7755 Outer_Extra_Formal_Statements
: constant List_Id
:= New_List
;
7756 -- Statements concerning extra formal parameters, prior to the
7757 -- declaration of the actual parameter variables.
7759 Decls
: constant List_Id
:= New_List
;
7760 -- All the parameters will get declared before calling the real
7761 -- subprograms. Also the out parameters will be declared.
7762 -- At this level, parameters may be unconstrained.
7764 Statements
: constant List_Id
:= New_List
;
7766 After_Statements
: constant List_Id
:= New_List
;
7767 -- Statements to be executed after the subprogram call
7769 Inner_Decls
: List_Id
:= No_List
;
7770 -- In case of a function, the inner declarations are needed since
7771 -- the result may be unconstrained.
7773 Excep_Handlers
: List_Id
:= No_List
;
7775 Parameter_List
: constant List_Id
:= New_List
;
7776 -- List of parameters to be passed to the subprogram
7778 First_Controlling_Formal_Seen
: Boolean := False;
7780 Current_Parameter
: Node_Id
;
7782 Ordered_Parameters_List
: constant List_Id
:=
7783 Build_Ordered_Parameters_List
7784 (Specification
(Vis_Decl
));
7786 Arguments
: constant Entity_Id
:=
7787 Make_Defining_Identifier
(Loc
,
7788 New_Internal_Name
('A'));
7789 -- Name of the named values list used to retrieve parameters
7791 Subp_Spec
: Node_Id
;
7792 -- Subprogram specification
7794 Called_Subprogram
: Node_Id
;
7795 -- The subprogram to call
7798 if Present
(RACW_Type
) then
7799 Called_Subprogram
:=
7800 New_Occurrence_Of
(Parent_Primitive
, Loc
);
7802 Called_Subprogram
:=
7804 (Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
7807 Declare_Create_NVList
(Loc
, Arguments
, Outer_Decls
, Outer_Statements
);
7809 -- Loop through every parameter and get its value from the stream. If
7810 -- the parameter is unconstrained, then the parameter is read using
7811 -- 'Input at the point of declaration.
7813 Current_Parameter
:= First
(Ordered_Parameters_List
);
7814 while Present
(Current_Parameter
) loop
7817 Constrained
: Boolean;
7818 Any
: Entity_Id
:= Empty
;
7819 Object
: constant Entity_Id
:=
7820 Make_Defining_Identifier
(Loc
,
7821 Chars
=> New_Internal_Name
('P'));
7822 Expr
: Node_Id
:= Empty
;
7824 Is_Controlling_Formal
: constant Boolean :=
7825 Is_RACW_Controlling_Formal
7826 (Current_Parameter
, Stub_Type
);
7828 Is_First_Controlling_Formal
: Boolean := False;
7830 Need_Extra_Constrained
: Boolean;
7831 -- True when an extra constrained actual is required
7834 if Is_Controlling_Formal
then
7836 -- Controlling formals in distributed object primitive
7837 -- operations are handled specially:
7838 -- - the first controlling formal is used as the
7839 -- target of the call;
7840 -- - the remaining controlling formals are transmitted
7844 Is_First_Controlling_Formal
:=
7845 not First_Controlling_Formal_Seen
;
7846 First_Controlling_Formal_Seen
:= True;
7849 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7853 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
7855 if not Is_First_Controlling_Formal
then
7857 Make_Defining_Identifier
(Loc
,
7858 Chars
=> New_Internal_Name
('A'));
7860 Append_To
(Outer_Decls
,
7861 Make_Object_Declaration
(Loc
,
7862 Defining_Identifier
=> Any
,
7863 Object_Definition
=>
7864 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7866 Make_Function_Call
(Loc
,
7867 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7868 Parameter_Associations
=> New_List
(
7869 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7870 (Loc
, Etyp
, Outer_Decls
)))));
7872 Append_To
(Outer_Statements
,
7873 Add_Parameter_To_NVList
(Loc
,
7874 Parameter
=> Current_Parameter
,
7875 NVList
=> Arguments
,
7876 Constrained
=> Constrained
,
7880 if Is_First_Controlling_Formal
then
7882 Addr
: constant Entity_Id
:=
7883 Make_Defining_Identifier
(Loc
,
7884 Chars
=> New_Internal_Name
('A'));
7886 Is_Local
: constant Entity_Id
:=
7887 Make_Defining_Identifier
(Loc
,
7888 Chars
=> New_Internal_Name
('L'));
7891 -- Special case: obtain the first controlling formal
7892 -- from the target of the remote call, instead of the
7895 Append_To
(Outer_Decls
,
7896 Make_Object_Declaration
(Loc
,
7897 Defining_Identifier
=> Addr
,
7898 Object_Definition
=>
7899 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
7901 Append_To
(Outer_Decls
,
7902 Make_Object_Declaration
(Loc
,
7903 Defining_Identifier
=> Is_Local
,
7904 Object_Definition
=>
7905 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7907 Append_To
(Outer_Statements
,
7908 Make_Procedure_Call_Statement
(Loc
,
7910 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
7911 Parameter_Associations
=> New_List
(
7912 Make_Selected_Component
(Loc
,
7915 Request_Parameter
, Loc
),
7917 Make_Identifier
(Loc
, Name_Target
)),
7918 New_Occurrence_Of
(Is_Local
, Loc
),
7919 New_Occurrence_Of
(Addr
, Loc
))));
7921 Expr
:= Unchecked_Convert_To
(RACW_Type
,
7922 New_Occurrence_Of
(Addr
, Loc
));
7925 elsif In_Present
(Current_Parameter
)
7926 or else not Out_Present
(Current_Parameter
)
7927 or else not Constrained
7929 -- If an input parameter is constrained, then its reading is
7930 -- deferred until the beginning of the subprogram body. If
7931 -- it is unconstrained, then an expression is built for
7932 -- the object declaration and the variable is set using
7933 -- 'Input instead of 'Read.
7935 Expr
:= PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7936 Etyp
, New_Occurrence_Of
(Any
, Loc
), Decls
);
7939 Append_To
(Statements
,
7940 Make_Assignment_Statement
(Loc
,
7941 Name
=> New_Occurrence_Of
(Object
, Loc
),
7942 Expression
=> Expr
));
7947 -- Expr will be used to initialize (and constrain) the
7948 -- parameter when it is declared.
7953 Need_Extra_Constrained
:=
7954 Nkind
(Parameter_Type
(Current_Parameter
)) /=
7957 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
7959 Present
(Extra_Constrained
7960 (Defining_Identifier
(Current_Parameter
)));
7962 -- We may not associate an extra constrained actual to a
7963 -- constant object, so if one is needed, declare the actual
7964 -- as a variable even if it won't be modified.
7966 Build_Actual_Object_Declaration
7969 Variable
=> Need_Extra_Constrained
7970 or else Out_Present
(Current_Parameter
),
7973 Set_Etype
(Object
, Etyp
);
7975 -- An out parameter may be written back using a 'Write
7976 -- attribute instead of a 'Output because it has been
7977 -- constrained by the parameter given to the caller. Note that
7978 -- out controlling arguments in the case of a RACW are not put
7979 -- back in the stream because the pointer on them has not
7982 if Out_Present
(Current_Parameter
)
7983 and then not Is_Controlling_Formal
7985 Append_To
(After_Statements
,
7986 Make_Procedure_Call_Statement
(Loc
,
7987 Name
=> New_Occurrence_Of
(RTE
(RE_Move_Any_Value
), Loc
),
7988 Parameter_Associations
=> New_List
(
7989 New_Occurrence_Of
(Any
, Loc
),
7990 PolyORB_Support
.Helpers
.Build_To_Any_Call
7991 (New_Occurrence_Of
(Object
, Loc
), Decls
))));
7994 -- For RACW controlling formals, the Etyp of Object is always
7995 -- an RACW, even if the parameter is not of an anonymous access
7996 -- type. In such case, we need to dereference it at call time.
7998 if Is_Controlling_Formal
then
7999 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
8002 Append_To
(Parameter_List
,
8003 Make_Parameter_Association
(Loc
,
8006 (Defining_Identifier
(Current_Parameter
), Loc
),
8007 Explicit_Actual_Parameter
=>
8008 Make_Explicit_Dereference
(Loc
,
8010 Unchecked_Convert_To
(RACW_Type
,
8011 OK_Convert_To
(RTE
(RE_Address
),
8012 New_Occurrence_Of
(Object
, Loc
))))));
8015 Append_To
(Parameter_List
,
8016 Make_Parameter_Association
(Loc
,
8019 (Defining_Identifier
(Current_Parameter
), Loc
),
8021 Explicit_Actual_Parameter
=>
8022 Unchecked_Convert_To
(RACW_Type
,
8023 OK_Convert_To
(RTE
(RE_Address
),
8024 New_Occurrence_Of
(Object
, Loc
)))));
8028 Append_To
(Parameter_List
,
8029 Make_Parameter_Association
(Loc
,
8032 Defining_Identifier
(Current_Parameter
), Loc
),
8033 Explicit_Actual_Parameter
=>
8034 New_Occurrence_Of
(Object
, Loc
)));
8037 -- If the current parameter needs an extra formal, then read it
8038 -- from the stream and set the corresponding semantic field in
8039 -- the variable. If the kind of the parameter identifier is
8040 -- E_Void, then this is a compiler generated parameter that
8041 -- doesn't need an extra constrained status.
8043 -- The case of Extra_Accessibility should also be handled ???
8045 if Need_Extra_Constrained
then
8047 Extra_Parameter
: constant Entity_Id
:=
8049 (Defining_Identifier
8050 (Current_Parameter
));
8052 Extra_Any
: constant Entity_Id
:=
8053 Make_Defining_Identifier
(Loc
,
8054 Chars
=> New_Internal_Name
('A'));
8056 Formal_Entity
: constant Entity_Id
:=
8057 Make_Defining_Identifier
(Loc
,
8058 Chars
=> Chars
(Extra_Parameter
));
8060 Formal_Type
: constant Entity_Id
:=
8061 Etype
(Extra_Parameter
);
8064 Append_To
(Outer_Decls
,
8065 Make_Object_Declaration
(Loc
,
8066 Defining_Identifier
=> Extra_Any
,
8067 Object_Definition
=>
8068 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8070 Make_Function_Call
(Loc
,
8072 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
8073 Parameter_Associations
=> New_List
(
8074 PolyORB_Support
.Helpers
.Build_TypeCode_Call
8075 (Loc
, Formal_Type
, Outer_Decls
)))));
8077 Append_To
(Outer_Extra_Formal_Statements
,
8078 Add_Parameter_To_NVList
(Loc
,
8079 Parameter
=> Extra_Parameter
,
8080 NVList
=> Arguments
,
8081 Constrained
=> True,
8085 Make_Object_Declaration
(Loc
,
8086 Defining_Identifier
=> Formal_Entity
,
8087 Object_Definition
=>
8088 New_Occurrence_Of
(Formal_Type
, Loc
)));
8090 Append_To
(Statements
,
8091 Make_Assignment_Statement
(Loc
,
8092 Name
=> New_Occurrence_Of
(Formal_Entity
, Loc
),
8094 PolyORB_Support
.Helpers
.Build_From_Any_Call
8096 New_Occurrence_Of
(Extra_Any
, Loc
),
8098 Set_Extra_Constrained
(Object
, Formal_Entity
);
8103 Next
(Current_Parameter
);
8106 -- Extra Formals should go after all the other parameters
8108 Append_List_To
(Outer_Statements
, Outer_Extra_Formal_Statements
);
8110 Append_To
(Outer_Statements
,
8111 Make_Procedure_Call_Statement
(Loc
,
8112 Name
=> New_Occurrence_Of
(RTE
(RE_Request_Arguments
), Loc
),
8113 Parameter_Associations
=> New_List
(
8114 New_Occurrence_Of
(Request_Parameter
, Loc
),
8115 New_Occurrence_Of
(Arguments
, Loc
))));
8117 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
8119 -- The remote subprogram is a function: Build an inner block to be
8120 -- able to hold a potentially unconstrained result in a variable.
8123 Etyp
: constant Entity_Id
:=
8124 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
8125 Result
: constant Node_Id
:=
8126 Make_Defining_Identifier
(Loc
,
8127 Chars
=> New_Internal_Name
('R'));
8130 Inner_Decls
:= New_List
(
8131 Make_Object_Declaration
(Loc
,
8132 Defining_Identifier
=> Result
,
8133 Constant_Present
=> True,
8134 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
8136 Make_Function_Call
(Loc
,
8137 Name
=> Called_Subprogram
,
8138 Parameter_Associations
=> Parameter_List
)));
8140 if Is_Class_Wide_Type
(Etyp
) then
8142 -- For a remote call to a function with a class-wide type,
8143 -- check that the returned value satisfies the requirements
8146 Append_To
(Inner_Decls
,
8147 Make_Transportable_Check
(Loc
,
8148 New_Occurrence_Of
(Result
, Loc
)));
8152 Set_Etype
(Result
, Etyp
);
8153 Append_To
(After_Statements
,
8154 Make_Procedure_Call_Statement
(Loc
,
8155 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Result
), Loc
),
8156 Parameter_Associations
=> New_List
(
8157 New_Occurrence_Of
(Request_Parameter
, Loc
),
8158 PolyORB_Support
.Helpers
.Build_To_Any_Call
8159 (New_Occurrence_Of
(Result
, Loc
), Decls
))));
8161 -- A DSA function does not have out or inout arguments
8164 Append_To
(Statements
,
8165 Make_Block_Statement
(Loc
,
8166 Declarations
=> Inner_Decls
,
8167 Handled_Statement_Sequence
=>
8168 Make_Handled_Sequence_Of_Statements
(Loc
,
8169 Statements
=> After_Statements
)));
8172 -- The remote subprogram is a procedure. We do not need any inner
8173 -- block in this case. No specific processing is required here for
8174 -- the dynamically asynchronous case: the indication of whether
8175 -- call is asynchronous or not is managed by the Sync_Scope
8176 -- attibute of the request, and is handled entirely in the
8179 Append_To
(After_Statements
,
8180 Make_Procedure_Call_Statement
(Loc
,
8181 Name
=> New_Occurrence_Of
(RTE
(RE_Request_Set_Out
), Loc
),
8182 Parameter_Associations
=> New_List
(
8183 New_Occurrence_Of
(Request_Parameter
, Loc
))));
8185 Append_To
(Statements
,
8186 Make_Procedure_Call_Statement
(Loc
,
8187 Name
=> Called_Subprogram
,
8188 Parameter_Associations
=> Parameter_List
));
8190 Append_List_To
(Statements
, After_Statements
);
8194 Make_Procedure_Specification
(Loc
,
8195 Defining_Unit_Name
=>
8196 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
8198 Parameter_Specifications
=> New_List
(
8199 Make_Parameter_Specification
(Loc
,
8200 Defining_Identifier
=> Request_Parameter
,
8202 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
8204 -- An exception raised during the execution of an incoming
8205 -- remote subprogram call and that needs to be sent back
8206 -- to the caller is propagated by the receiving stubs, and
8207 -- will be handled by the caller (the distribution runtime).
8209 if Asynchronous
and then not Dynamically_Asynchronous
then
8211 -- For an asynchronous procedure, add a null exception handler
8213 Excep_Handlers
:= New_List
(
8214 Make_Implicit_Exception_Handler
(Loc
,
8215 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8216 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
8219 -- In the other cases, if an exception is raised, then the
8220 -- exception occurrence is propagated.
8225 Append_To
(Outer_Statements
,
8226 Make_Block_Statement
(Loc
,
8227 Declarations
=> Decls
,
8228 Handled_Statement_Sequence
=>
8229 Make_Handled_Sequence_Of_Statements
(Loc
,
8230 Statements
=> Statements
)));
8233 Make_Subprogram_Body
(Loc
,
8234 Specification
=> Subp_Spec
,
8235 Declarations
=> Outer_Decls
,
8236 Handled_Statement_Sequence
=>
8237 Make_Handled_Sequence_Of_Statements
(Loc
,
8238 Statements
=> Outer_Statements
,
8239 Exception_Handlers
=> Excep_Handlers
));
8240 end Build_Subprogram_Receiving_Stubs
;
8246 package body Helpers
is
8248 -----------------------
8249 -- Local Subprograms --
8250 -----------------------
8252 function Find_Numeric_Representation
8253 (Typ
: Entity_Id
) return Entity_Id
;
8254 -- Given a numeric type Typ, return the smallest integer or floating
8255 -- point type from Standard, or the smallest unsigned (modular) type
8256 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8258 function Make_Helper_Function_Name
8261 Nam
: Name_Id
) return Entity_Id
;
8262 -- Return the name to be assigned for helper subprogram Nam of Typ
8264 ------------------------------------------------------------
8265 -- Common subprograms for building various tree fragments --
8266 ------------------------------------------------------------
8268 function Build_Get_Aggregate_Element
8272 Idx
: Node_Id
) return Node_Id
;
8273 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8274 -- returning the Idx'th element.
8277 Subprogram
: Entity_Id
;
8278 -- Reference location for constructed nodes
8281 -- For 'Range and Etype
8284 -- For the construction of the innermost element expression
8286 with procedure Add_Process_Element
8289 Counter
: Entity_Id
;
8292 procedure Append_Array_Traversal
8295 Counter
: Entity_Id
:= Empty
;
8297 -- Build nested loop statements that iterate over the elements of an
8298 -- array Arry. The statement(s) built by Add_Process_Element are
8299 -- executed for each element; Indices is the list of indices to be
8300 -- used in the construction of the indexed component that denotes the
8301 -- current element. Subprogram is the entity for the subprogram for
8302 -- which this iterator is generated. The generated statements are
8303 -- appended to Stmts.
8307 -- The record entity being dealt with
8309 with procedure Add_Process_Element
8311 Container
: Node_Or_Entity_Id
;
8312 Counter
: in out Int
;
8315 -- Rec is the instance of the record type, or Empty.
8316 -- Field is either the N_Defining_Identifier for a component,
8317 -- or an N_Variant_Part.
8319 procedure Append_Record_Traversal
8322 Container
: Node_Or_Entity_Id
;
8323 Counter
: in out Int
);
8324 -- Process component list Clist. Individual fields are passed
8325 -- to Field_Processing. Each variant part is also processed.
8326 -- Container is the outer Any (for From_Any/To_Any),
8327 -- the outer typecode (for TC) to which the operation applies.
8329 -----------------------------
8330 -- Append_Record_Traversal --
8331 -----------------------------
8333 procedure Append_Record_Traversal
8336 Container
: Node_Or_Entity_Id
;
8337 Counter
: in out Int
)
8341 -- Clist's Component_Items and Variant_Part
8351 CI
:= Component_Items
(Clist
);
8352 VP
:= Variant_Part
(Clist
);
8355 while Present
(Item
) loop
8356 Def
:= Defining_Identifier
(Item
);
8358 if not Is_Internal_Name
(Chars
(Def
)) then
8360 (Stmts
, Container
, Counter
, Rec
, Def
);
8366 if Present
(VP
) then
8367 Add_Process_Element
(Stmts
, Container
, Counter
, Rec
, VP
);
8369 end Append_Record_Traversal
;
8371 -------------------------
8372 -- Build_From_Any_Call --
8373 -------------------------
8375 function Build_From_Any_Call
8378 Decls
: List_Id
) return Node_Id
8380 Loc
: constant Source_Ptr
:= Sloc
(N
);
8382 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
8384 Fnam
: Entity_Id
:= Empty
;
8385 Lib_RE
: RE_Id
:= RE_Null
;
8389 -- First simple case where the From_Any function is present
8390 -- in the type's TSS.
8392 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_From_Any
);
8394 if Sloc
(U_Type
) <= Standard_Location
then
8395 U_Type
:= Base_Type
(U_Type
);
8398 -- Check first for Boolean and Character. These are enumeration
8399 -- types, but we treat them specially, since they may require
8400 -- special handling in the transfer protocol. However, this
8401 -- special handling only applies if they have standard
8402 -- representation, otherwise they are treated like any other
8403 -- enumeration type.
8405 if Present
(Fnam
) then
8408 elsif U_Type
= Standard_Boolean
then
8411 elsif U_Type
= Standard_Character
then
8414 elsif U_Type
= Standard_Wide_Character
then
8417 elsif U_Type
= Standard_Wide_Wide_Character
then
8418 Lib_RE
:= RE_FA_WWC
;
8420 -- Floating point types
8422 elsif U_Type
= Standard_Short_Float
then
8425 elsif U_Type
= Standard_Float
then
8428 elsif U_Type
= Standard_Long_Float
then
8431 elsif U_Type
= Standard_Long_Long_Float
then
8432 Lib_RE
:= RE_FA_LLF
;
8436 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
8437 Lib_RE
:= RE_FA_SSI
;
8439 elsif U_Type
= Etype
(Standard_Short_Integer
) then
8442 elsif U_Type
= Etype
(Standard_Integer
) then
8445 elsif U_Type
= Etype
(Standard_Long_Integer
) then
8448 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
8449 Lib_RE
:= RE_FA_LLI
;
8451 -- Unsigned integer types
8453 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
8454 Lib_RE
:= RE_FA_SSU
;
8456 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
8459 elsif U_Type
= RTE
(RE_Unsigned
) then
8462 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
8465 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
8466 Lib_RE
:= RE_FA_LLU
;
8468 elsif Is_RTE
(U_Type
, RE_Unbounded_String
) then
8469 Lib_RE
:= RE_FA_String
;
8471 -- Special DSA types
8473 elsif Is_RTE
(U_Type
, RE_Any_Container_Ptr
) then
8476 -- Other (non-primitive) types
8481 Typ
: Entity_Id
:= U_Type
;
8484 -- For the subtype representing a generic actual type, go
8485 -- to the base type.
8487 if Is_Generic_Actual_Type
(Typ
) then
8488 Typ
:= Base_Type
(Typ
);
8491 Build_From_Any_Function
(Loc
, Typ
, Decl
, Fnam
);
8492 Append_To
(Decls
, Decl
);
8496 -- Call the function
8498 if Lib_RE
/= RE_Null
then
8499 pragma Assert
(No
(Fnam
));
8500 Fnam
:= RTE
(Lib_RE
);
8504 Make_Function_Call
(Loc
,
8505 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
8506 Parameter_Associations
=> New_List
(N
));
8508 -- We must set the type of Result, so the unchecked conversion
8509 -- from the underlying type to the base type is properly done.
8511 Set_Etype
(Result
, U_Type
);
8513 return Unchecked_Convert_To
(Typ
, Result
);
8514 end Build_From_Any_Call
;
8516 -----------------------------
8517 -- Build_From_Any_Function --
8518 -----------------------------
8520 procedure Build_From_Any_Function
8524 Fnam
: out Entity_Id
)
8527 Decls
: constant List_Id
:= New_List
;
8528 Stms
: constant List_Id
:= New_List
;
8530 Any_Parameter
: constant Entity_Id
:=
8531 Make_Defining_Identifier
(Loc
,
8532 New_Internal_Name
('A'));
8534 Use_Opaque_Representation
: Boolean;
8537 if Is_Itype
(Typ
) then
8538 Build_From_Any_Function
8546 Fnam
:= Make_Helper_Function_Name
(Loc
, Typ
, Name_From_Any
);
8549 Make_Function_Specification
(Loc
,
8550 Defining_Unit_Name
=> Fnam
,
8551 Parameter_Specifications
=> New_List
(
8552 Make_Parameter_Specification
(Loc
,
8553 Defining_Identifier
=> Any_Parameter
,
8554 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
8555 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
8557 -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any
8560 (not (Is_Remote_Access_To_Class_Wide_Type
(Typ
)));
8562 Use_Opaque_Representation
:= False;
8564 if Has_Stream_Attribute_Definition
8565 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
8567 Has_Stream_Attribute_Definition
8568 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
8570 -- If user-defined stream attributes are specified for this
8571 -- type, use them and transmit data as an opaque sequence of
8574 Use_Opaque_Representation
:= True;
8576 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
8578 Make_Simple_Return_Statement
(Loc
,
8583 New_Occurrence_Of
(Any_Parameter
, Loc
),
8586 elsif Is_Record_Type
(Typ
)
8587 and then not Is_Derived_Type
(Typ
)
8588 and then not Is_Tagged_Type
(Typ
)
8590 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
8592 Make_Simple_Return_Statement
(Loc
,
8596 New_Occurrence_Of
(Any_Parameter
, Loc
),
8601 Disc
: Entity_Id
:= Empty
;
8602 Discriminant_Associations
: List_Id
;
8603 Rdef
: constant Node_Id
:=
8605 (Declaration_Node
(Typ
));
8606 Component_Counter
: Int
:= 0;
8608 -- The returned object
8610 Res
: constant Entity_Id
:=
8611 Make_Defining_Identifier
(Loc
,
8612 New_Internal_Name
('R'));
8614 Res_Definition
: Node_Id
:= New_Occurrence_Of
(Typ
, Loc
);
8616 procedure FA_Rec_Add_Process_Element
8619 Counter
: in out Int
;
8623 procedure FA_Append_Record_Traversal
is
8624 new Append_Record_Traversal
8626 Add_Process_Element
=> FA_Rec_Add_Process_Element
);
8628 --------------------------------
8629 -- FA_Rec_Add_Process_Element --
8630 --------------------------------
8632 procedure FA_Rec_Add_Process_Element
8635 Counter
: in out Int
;
8640 if Nkind
(Field
) = N_Defining_Identifier
then
8642 -- A regular component
8645 Make_Assignment_Statement
(Loc
,
8646 Name
=> Make_Selected_Component
(Loc
,
8648 New_Occurrence_Of
(Rec
, Loc
),
8650 New_Occurrence_Of
(Field
, Loc
)),
8652 Build_From_Any_Call
(Etype
(Field
),
8653 Build_Get_Aggregate_Element
(Loc
,
8655 TC
=> Build_TypeCode_Call
(Loc
,
8656 Etype
(Field
), Decls
),
8657 Idx
=> Make_Integer_Literal
(Loc
,
8666 Struct_Counter
: Int
:= 0;
8668 Block_Decls
: constant List_Id
:= New_List
;
8669 Block_Stmts
: constant List_Id
:= New_List
;
8672 Alt_List
: constant List_Id
:= New_List
;
8673 Choice_List
: List_Id
;
8675 Struct_Any
: constant Entity_Id
:=
8676 Make_Defining_Identifier
(Loc
,
8677 New_Internal_Name
('S'));
8681 Make_Object_Declaration
(Loc
,
8682 Defining_Identifier
=> Struct_Any
,
8683 Constant_Present
=> True,
8684 Object_Definition
=>
8685 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8687 Make_Function_Call
(Loc
,
8690 (RTE
(RE_Extract_Union_Value
), Loc
),
8692 Parameter_Associations
=> New_List
(
8693 Build_Get_Aggregate_Element
(Loc
,
8696 Make_Function_Call
(Loc
,
8697 Name
=> New_Occurrence_Of
(
8698 RTE
(RE_Any_Member_Type
), Loc
),
8699 Parameter_Associations
=>
8701 New_Occurrence_Of
(Any
, Loc
),
8702 Make_Integer_Literal
(Loc
,
8703 Intval
=> Counter
))),
8705 Make_Integer_Literal
(Loc
,
8706 Intval
=> Counter
))))));
8709 Make_Block_Statement
(Loc
,
8710 Declarations
=> Block_Decls
,
8711 Handled_Statement_Sequence
=>
8712 Make_Handled_Sequence_Of_Statements
(Loc
,
8713 Statements
=> Block_Stmts
)));
8715 Append_To
(Block_Stmts
,
8716 Make_Case_Statement
(Loc
,
8718 Make_Selected_Component
(Loc
,
8720 Selector_Name
=> Chars
(Name
(Field
))),
8721 Alternatives
=> Alt_List
));
8723 Variant
:= First_Non_Pragma
(Variants
(Field
));
8724 while Present
(Variant
) loop
8727 (Discrete_Choices
(Variant
));
8729 VP_Stmts
:= New_List
;
8731 -- Struct_Counter should be reset before
8732 -- handling a variant part. Indeed only one
8733 -- of the case statement alternatives will be
8734 -- executed at run-time, so the counter must
8735 -- start at 0 for every case statement.
8737 Struct_Counter
:= 0;
8739 FA_Append_Record_Traversal
(
8741 Clist
=> Component_List
(Variant
),
8742 Container
=> Struct_Any
,
8743 Counter
=> Struct_Counter
);
8745 Append_To
(Alt_List
,
8746 Make_Case_Statement_Alternative
(Loc
,
8747 Discrete_Choices
=> Choice_List
,
8748 Statements
=> VP_Stmts
));
8749 Next_Non_Pragma
(Variant
);
8754 Counter
:= Counter
+ 1;
8755 end FA_Rec_Add_Process_Element
;
8758 -- First all discriminants
8760 if Has_Discriminants
(Typ
) then
8761 Discriminant_Associations
:= New_List
;
8763 Disc
:= First_Discriminant
(Typ
);
8764 while Present
(Disc
) loop
8766 Disc_Var_Name
: constant Entity_Id
:=
8767 Make_Defining_Identifier
(Loc
,
8768 Chars
=> Chars
(Disc
));
8769 Disc_Type
: constant Entity_Id
:=
8774 Make_Object_Declaration
(Loc
,
8775 Defining_Identifier
=> Disc_Var_Name
,
8776 Constant_Present
=> True,
8777 Object_Definition
=>
8778 New_Occurrence_Of
(Disc_Type
, Loc
),
8781 Build_From_Any_Call
(Disc_Type
,
8782 Build_Get_Aggregate_Element
(Loc
,
8783 Any
=> Any_Parameter
,
8784 TC
=> Build_TypeCode_Call
8785 (Loc
, Disc_Type
, Decls
),
8786 Idx
=> Make_Integer_Literal
(Loc
,
8787 Intval
=> Component_Counter
)),
8790 Component_Counter
:= Component_Counter
+ 1;
8792 Append_To
(Discriminant_Associations
,
8793 Make_Discriminant_Association
(Loc
,
8794 Selector_Names
=> New_List
(
8795 New_Occurrence_Of
(Disc
, Loc
)),
8797 New_Occurrence_Of
(Disc_Var_Name
, Loc
)));
8799 Next_Discriminant
(Disc
);
8803 Make_Subtype_Indication
(Loc
,
8804 Subtype_Mark
=> Res_Definition
,
8806 Make_Index_Or_Discriminant_Constraint
(Loc
,
8807 Discriminant_Associations
));
8810 -- Now we have all the discriminants in variables, we can
8811 -- declared a constrained object. Note that we are not
8812 -- initializing (non-discriminant) components directly in
8813 -- the object declarations, because which fields to
8814 -- initialize depends (at run time) on the discriminant
8818 Make_Object_Declaration
(Loc
,
8819 Defining_Identifier
=> Res
,
8820 Object_Definition
=> Res_Definition
));
8822 -- ... then all components
8824 FA_Append_Record_Traversal
(Stms
,
8825 Clist
=> Component_List
(Rdef
),
8826 Container
=> Any_Parameter
,
8827 Counter
=> Component_Counter
);
8830 Make_Simple_Return_Statement
(Loc
,
8831 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
8835 elsif Is_Array_Type
(Typ
) then
8837 Constrained
: constant Boolean := Is_Constrained
(Typ
);
8839 procedure FA_Ary_Add_Process_Element
8842 Counter
: Entity_Id
;
8844 -- Assign the current element (as identified by Counter) of
8845 -- Any to the variable denoted by name Datum, and advance
8846 -- Counter by 1. If Datum is not an Any, a call to From_Any
8847 -- for its type is inserted.
8849 --------------------------------
8850 -- FA_Ary_Add_Process_Element --
8851 --------------------------------
8853 procedure FA_Ary_Add_Process_Element
8856 Counter
: Entity_Id
;
8859 Assignment
: constant Node_Id
:=
8860 Make_Assignment_Statement
(Loc
,
8862 Expression
=> Empty
);
8864 Element_Any
: Node_Id
;
8868 Element_TC
: Node_Id
;
8871 if Etype
(Datum
) = RTE
(RE_Any
) then
8873 -- When Datum is an Any the Etype field is not
8874 -- sufficient to determine the typecode of Datum
8875 -- (which can be a TC_SEQUENCE or TC_ARRAY
8876 -- depending on the value of Constrained).
8878 -- Therefore we retrieve the typecode which has
8879 -- been constructed in Append_Array_Traversal with
8880 -- a call to Get_Any_Type.
8883 Make_Function_Call
(Loc
,
8884 Name
=> New_Occurrence_Of
(
8885 RTE
(RE_Get_Any_Type
), Loc
),
8886 Parameter_Associations
=> New_List
(
8887 New_Occurrence_Of
(Entity
(Datum
), Loc
)));
8889 -- For non Any Datum we simply construct a typecode
8890 -- matching the Etype of the Datum.
8892 Element_TC
:= Build_TypeCode_Call
8893 (Loc
, Etype
(Datum
), Decls
);
8897 Build_Get_Aggregate_Element
(Loc
,
8900 Idx
=> New_Occurrence_Of
(Counter
, Loc
));
8903 -- Note: here we *prepend* statements to Stmts, so
8904 -- we must do it in reverse order.
8907 Make_Assignment_Statement
(Loc
,
8909 New_Occurrence_Of
(Counter
, Loc
),
8912 Left_Opnd
=> New_Occurrence_Of
(Counter
, Loc
),
8913 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
8915 if Nkind
(Datum
) /= N_Attribute_Reference
then
8917 -- We ignore the value of the length of each
8918 -- dimension, since the target array has already
8919 -- been constrained anyway.
8921 if Etype
(Datum
) /= RTE
(RE_Any
) then
8922 Set_Expression
(Assignment
,
8924 (Component_Type
(Typ
), Element_Any
, Decls
));
8926 Set_Expression
(Assignment
, Element_Any
);
8929 Prepend_To
(Stmts
, Assignment
);
8931 end FA_Ary_Add_Process_Element
;
8933 ------------------------
8934 -- Local Declarations --
8935 ------------------------
8937 Counter
: constant Entity_Id
:=
8938 Make_Defining_Identifier
(Loc
, Name_J
);
8940 Initial_Counter_Value
: Int
:= 0;
8942 Component_TC
: constant Entity_Id
:=
8943 Make_Defining_Identifier
(Loc
, Name_T
);
8945 Res
: constant Entity_Id
:=
8946 Make_Defining_Identifier
(Loc
, Name_R
);
8948 procedure Append_From_Any_Array_Iterator
is
8949 new Append_Array_Traversal
(
8952 Indices
=> New_List
,
8953 Add_Process_Element
=> FA_Ary_Add_Process_Element
);
8955 Res_Subtype_Indication
: Node_Id
:=
8956 New_Occurrence_Of
(Typ
, Loc
);
8959 if not Constrained
then
8961 Ndim
: constant Int
:= Number_Dimensions
(Typ
);
8964 Indx
: Node_Id
:= First_Index
(Typ
);
8967 Ranges
: constant List_Id
:= New_List
;
8970 for J
in 1 .. Ndim
loop
8971 Lnam
:= New_External_Name
('L', J
);
8972 Hnam
:= New_External_Name
('H', J
);
8974 -- Note, for empty arrays bounds may be out of
8975 -- the range of Etype (Indx).
8977 Indt
:= Base_Type
(Etype
(Indx
));
8980 Make_Object_Declaration
(Loc
,
8981 Defining_Identifier
=>
8982 Make_Defining_Identifier
(Loc
, Lnam
),
8983 Constant_Present
=> True,
8984 Object_Definition
=>
8985 New_Occurrence_Of
(Indt
, Loc
),
8989 Build_Get_Aggregate_Element
(Loc
,
8990 Any
=> Any_Parameter
,
8991 TC
=> Build_TypeCode_Call
8994 Make_Integer_Literal
(Loc
, J
- 1)),
8998 Make_Object_Declaration
(Loc
,
8999 Defining_Identifier
=>
9000 Make_Defining_Identifier
(Loc
, Hnam
),
9002 Constant_Present
=> True,
9004 Object_Definition
=>
9005 New_Occurrence_Of
(Indt
, Loc
),
9007 Expression
=> Make_Attribute_Reference
(Loc
,
9009 New_Occurrence_Of
(Indt
, Loc
),
9011 Attribute_Name
=> Name_Val
,
9013 Expressions
=> New_List
(
9014 Make_Op_Subtract
(Loc
,
9019 Standard_Long_Integer
,
9020 Make_Identifier
(Loc
, Lnam
)),
9024 Standard_Long_Integer
,
9025 Make_Function_Call
(Loc
,
9027 New_Occurrence_Of
(RTE
(
9028 RE_Get_Nested_Sequence_Length
9030 Parameter_Associations
=>
9033 Any_Parameter
, Loc
),
9034 Make_Integer_Literal
(Loc
,
9038 Make_Integer_Literal
(Loc
, 1))))));
9042 Low_Bound
=> Make_Identifier
(Loc
, Lnam
),
9043 High_Bound
=> Make_Identifier
(Loc
, Hnam
)));
9048 -- Now we have all the necessary bound information:
9049 -- apply the set of range constraints to the
9050 -- (unconstrained) nominal subtype of Res.
9052 Initial_Counter_Value
:= Ndim
;
9053 Res_Subtype_Indication
:= Make_Subtype_Indication
(Loc
,
9054 Subtype_Mark
=> Res_Subtype_Indication
,
9056 Make_Index_Or_Discriminant_Constraint
(Loc
,
9057 Constraints
=> Ranges
));
9062 Make_Object_Declaration
(Loc
,
9063 Defining_Identifier
=> Res
,
9064 Object_Definition
=> Res_Subtype_Indication
));
9065 Set_Etype
(Res
, Typ
);
9068 Make_Object_Declaration
(Loc
,
9069 Defining_Identifier
=> Counter
,
9070 Object_Definition
=>
9071 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
9073 Make_Integer_Literal
(Loc
, Initial_Counter_Value
)));
9076 Make_Object_Declaration
(Loc
,
9077 Defining_Identifier
=> Component_TC
,
9078 Constant_Present
=> True,
9079 Object_Definition
=>
9080 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
),
9082 Build_TypeCode_Call
(Loc
,
9083 Component_Type
(Typ
), Decls
)));
9085 Append_From_Any_Array_Iterator
9086 (Stms
, Any_Parameter
, Counter
);
9089 Make_Simple_Return_Statement
(Loc
,
9090 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
9093 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9095 Make_Simple_Return_Statement
(Loc
,
9097 Unchecked_Convert_To
(Typ
,
9099 (Find_Numeric_Representation
(Typ
),
9100 New_Occurrence_Of
(Any_Parameter
, Loc
),
9104 Use_Opaque_Representation
:= True;
9107 if Use_Opaque_Representation
then
9109 -- Default: type is represented as an opaque sequence of bytes
9112 Strm
: constant Entity_Id
:=
9113 Make_Defining_Identifier
(Loc
,
9114 Chars
=> New_Internal_Name
('S'));
9115 Res
: constant Entity_Id
:=
9116 Make_Defining_Identifier
(Loc
,
9117 Chars
=> New_Internal_Name
('R'));
9120 -- Strm : Buffer_Stream_Type;
9123 Make_Object_Declaration
(Loc
,
9124 Defining_Identifier
=> Strm
,
9125 Aliased_Present
=> True,
9126 Object_Definition
=>
9127 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
9129 -- Allocate_Buffer (Strm);
9132 Make_Procedure_Call_Statement
(Loc
,
9134 New_Occurrence_Of
(RTE
(RE_Allocate_Buffer
), Loc
),
9135 Parameter_Associations
=> New_List
(
9136 New_Occurrence_Of
(Strm
, Loc
))));
9138 -- Any_To_BS (Strm, A);
9141 Make_Procedure_Call_Statement
(Loc
,
9142 Name
=> New_Occurrence_Of
(RTE
(RE_Any_To_BS
), Loc
),
9143 Parameter_Associations
=> New_List
(
9144 New_Occurrence_Of
(Any_Parameter
, Loc
),
9145 New_Occurrence_Of
(Strm
, Loc
))));
9147 if Transmit_As_Unconstrained
(Typ
) then
9150 -- Res : constant T := T'Input (Strm);
9152 -- Release_Buffer (Strm);
9156 Append_To
(Stms
, Make_Block_Statement
(Loc
,
9157 Declarations
=> New_List
(
9158 Make_Object_Declaration
(Loc
,
9159 Defining_Identifier
=> Res
,
9160 Constant_Present
=> True,
9161 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
9163 Make_Attribute_Reference
(Loc
,
9164 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
9165 Attribute_Name
=> Name_Input
,
9166 Expressions
=> New_List
(
9167 Make_Attribute_Reference
(Loc
,
9169 New_Occurrence_Of
(Strm
, Loc
),
9170 Attribute_Name
=> Name_Access
))))),
9172 Handled_Statement_Sequence
=>
9173 Make_Handled_Sequence_Of_Statements
(Loc
,
9174 Statements
=> New_List
(
9175 Make_Procedure_Call_Statement
(Loc
,
9178 (RTE
(RE_Release_Buffer
), Loc
),
9179 Parameter_Associations
=>
9180 New_List
(New_Occurrence_Of
(Strm
, Loc
))),
9182 Make_Simple_Return_Statement
(Loc
,
9183 Expression
=> New_Occurrence_Of
(Res
, Loc
))))));
9189 -- T'Read (Strm, Res);
9190 -- Release_Buffer (Strm);
9194 Append_To
(Stms
, Make_Block_Statement
(Loc
,
9195 Declarations
=> New_List
(
9196 Make_Object_Declaration
(Loc
,
9197 Defining_Identifier
=> Res
,
9198 Constant_Present
=> False,
9199 Object_Definition
=>
9200 New_Occurrence_Of
(Typ
, Loc
))),
9202 Handled_Statement_Sequence
=>
9203 Make_Handled_Sequence_Of_Statements
(Loc
,
9204 Statements
=> New_List
(
9205 Make_Attribute_Reference
(Loc
,
9206 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
9207 Attribute_Name
=> Name_Read
,
9208 Expressions
=> New_List
(
9209 Make_Attribute_Reference
(Loc
,
9211 New_Occurrence_Of
(Strm
, Loc
),
9212 Attribute_Name
=> Name_Access
),
9213 New_Occurrence_Of
(Res
, Loc
))),
9215 Make_Procedure_Call_Statement
(Loc
,
9218 (RTE
(RE_Release_Buffer
), Loc
),
9219 Parameter_Associations
=>
9220 New_List
(New_Occurrence_Of
(Strm
, Loc
))),
9222 Make_Simple_Return_Statement
(Loc
,
9223 Expression
=> New_Occurrence_Of
(Res
, Loc
))))));
9229 Make_Subprogram_Body
(Loc
,
9230 Specification
=> Spec
,
9231 Declarations
=> Decls
,
9232 Handled_Statement_Sequence
=>
9233 Make_Handled_Sequence_Of_Statements
(Loc
,
9234 Statements
=> Stms
));
9235 end Build_From_Any_Function
;
9237 ---------------------------------
9238 -- Build_Get_Aggregate_Element --
9239 ---------------------------------
9241 function Build_Get_Aggregate_Element
9245 Idx
: Node_Id
) return Node_Id
9248 return Make_Function_Call
(Loc
,
9250 New_Occurrence_Of
(RTE
(RE_Get_Aggregate_Element
), Loc
),
9251 Parameter_Associations
=> New_List
(
9252 New_Occurrence_Of
(Any
, Loc
),
9255 end Build_Get_Aggregate_Element
;
9257 -------------------------
9258 -- Build_Reposiroty_Id --
9259 -------------------------
9261 procedure Build_Name_And_Repository_Id
9263 Name_Str
: out String_Id
;
9264 Repo_Id_Str
: out String_Id
)
9268 Store_String_Chars
("DSA:");
9269 Get_Library_Unit_Name_String
(Scope
(E
));
9271 (Name_Buffer
(Name_Buffer
'First ..
9272 Name_Buffer
'First + Name_Len
- 1));
9273 Store_String_Char
('.');
9274 Get_Name_String
(Chars
(E
));
9276 (Name_Buffer
(Name_Buffer
'First ..
9277 Name_Buffer
'First + Name_Len
- 1));
9278 Store_String_Chars
(":1.0");
9279 Repo_Id_Str
:= End_String
;
9280 Name_Str
:= String_From_Name_Buffer
;
9281 end Build_Name_And_Repository_Id
;
9283 -----------------------
9284 -- Build_To_Any_Call --
9285 -----------------------
9287 function Build_To_Any_Call
9289 Decls
: List_Id
) return Node_Id
9291 Loc
: constant Source_Ptr
:= Sloc
(N
);
9293 Typ
: Entity_Id
:= Etype
(N
);
9296 Fnam
: Entity_Id
:= Empty
;
9297 Lib_RE
: RE_Id
:= RE_Null
;
9300 -- If N is a selected component, then maybe its Etype has not been
9301 -- set yet: try to use Etype of the selector_name in that case.
9303 if No
(Typ
) and then Nkind
(N
) = N_Selected_Component
then
9304 Typ
:= Etype
(Selector_Name
(N
));
9306 pragma Assert
(Present
(Typ
));
9308 -- Get full view for private type, completion for incomplete type
9310 U_Type
:= Underlying_Type
(Typ
);
9312 -- First simple case where the To_Any function is present in the
9315 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_To_Any
);
9317 -- Check first for Boolean and Character. These are enumeration
9318 -- types, but we treat them specially, since they may require
9319 -- special handling in the transfer protocol. However, this
9320 -- special handling only applies if they have standard
9321 -- representation, otherwise they are treated like any other
9322 -- enumeration type.
9324 if Sloc
(U_Type
) <= Standard_Location
then
9325 U_Type
:= Base_Type
(U_Type
);
9328 if Present
(Fnam
) then
9331 elsif U_Type
= Standard_Boolean
then
9334 elsif U_Type
= Standard_Character
then
9337 elsif U_Type
= Standard_Wide_Character
then
9340 elsif U_Type
= Standard_Wide_Wide_Character
then
9341 Lib_RE
:= RE_TA_WWC
;
9343 -- Floating point types
9345 elsif U_Type
= Standard_Short_Float
then
9348 elsif U_Type
= Standard_Float
then
9351 elsif U_Type
= Standard_Long_Float
then
9354 elsif U_Type
= Standard_Long_Long_Float
then
9355 Lib_RE
:= RE_TA_LLF
;
9359 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
9360 Lib_RE
:= RE_TA_SSI
;
9362 elsif U_Type
= Etype
(Standard_Short_Integer
) then
9365 elsif U_Type
= Etype
(Standard_Integer
) then
9368 elsif U_Type
= Etype
(Standard_Long_Integer
) then
9371 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
9372 Lib_RE
:= RE_TA_LLI
;
9374 -- Unsigned integer types
9376 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
9377 Lib_RE
:= RE_TA_SSU
;
9379 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
9382 elsif U_Type
= RTE
(RE_Unsigned
) then
9385 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
9388 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
9389 Lib_RE
:= RE_TA_LLU
;
9391 elsif Is_RTE
(U_Type
, RE_Unbounded_String
) then
9392 Lib_RE
:= RE_TA_String
;
9394 -- Special DSA types
9396 elsif Is_RTE
(U_Type
, RE_Any_Container_Ptr
) then
9400 elsif U_Type
= Underlying_Type
(RTE
(RE_TypeCode
)) then
9402 -- No corresponding FA_TC ???
9406 -- Other (non-primitive) types
9412 Build_To_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
9413 Append_To
(Decls
, Decl
);
9417 -- Call the function
9419 if Lib_RE
/= RE_Null
then
9420 pragma Assert
(No
(Fnam
));
9421 Fnam
:= RTE
(Lib_RE
);
9424 -- If Fnam is already analyzed, find the proper expected type,
9425 -- else we have a newly constructed To_Any function and we know
9426 -- that the expected type of its parameter is U_Type.
9428 if Ekind
(Fnam
) = E_Function
9429 and then Present
(First_Formal
(Fnam
))
9431 C_Type
:= Etype
(First_Formal
(Fnam
));
9437 Make_Function_Call
(Loc
,
9438 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
9439 Parameter_Associations
=>
9440 New_List
(OK_Convert_To
(C_Type
, N
)));
9441 end Build_To_Any_Call
;
9443 ---------------------------
9444 -- Build_To_Any_Function --
9445 ---------------------------
9447 procedure Build_To_Any_Function
9451 Fnam
: out Entity_Id
)
9454 Decls
: constant List_Id
:= New_List
;
9455 Stms
: constant List_Id
:= New_List
;
9457 Expr_Parameter
: constant Entity_Id
:=
9458 Make_Defining_Identifier
(Loc
, Name_E
);
9460 Any
: constant Entity_Id
:=
9461 Make_Defining_Identifier
(Loc
, Name_A
);
9464 Result_TC
: Node_Id
:= Build_TypeCode_Call
(Loc
, Typ
, Decls
);
9466 Use_Opaque_Representation
: Boolean;
9467 -- When True, use stream attributes and represent type as an
9468 -- opaque sequence of bytes.
9471 if Is_Itype
(Typ
) then
9472 Build_To_Any_Function
9480 Fnam
:= Make_Helper_Function_Name
(Loc
, Typ
, Name_To_Any
);
9483 Make_Function_Specification
(Loc
,
9484 Defining_Unit_Name
=> Fnam
,
9485 Parameter_Specifications
=> New_List
(
9486 Make_Parameter_Specification
(Loc
,
9487 Defining_Identifier
=> Expr_Parameter
,
9488 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
9489 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9490 Set_Etype
(Expr_Parameter
, Typ
);
9493 Make_Object_Declaration
(Loc
,
9494 Defining_Identifier
=> Any
,
9495 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9497 Use_Opaque_Representation
:= False;
9499 if Has_Stream_Attribute_Definition
9500 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
9502 Has_Stream_Attribute_Definition
9503 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
9505 -- If user-defined stream attributes are specified for this
9506 -- type, use them and transmit data as an opaque sequence of
9509 Use_Opaque_Representation
:= True;
9511 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9513 -- Non-tagged derived type: convert to root type
9516 Rt_Type
: constant Entity_Id
:= Root_Type
(Typ
);
9517 Expr
: constant Node_Id
:=
9520 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9522 Set_Expression
(Any_Decl
, Build_To_Any_Call
(Expr
, Decls
));
9525 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9527 -- Non-tagged record type
9529 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
9531 Rt_Type
: constant Entity_Id
:= Etype
(Typ
);
9532 Expr
: constant Node_Id
:=
9533 OK_Convert_To
(Rt_Type
,
9534 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9538 (Any_Decl
, Build_To_Any_Call
(Expr
, Decls
));
9541 -- Comment needed here (and label on declare block ???)
9545 Disc
: Entity_Id
:= Empty
;
9546 Rdef
: constant Node_Id
:=
9547 Type_Definition
(Declaration_Node
(Typ
));
9549 Elements
: constant List_Id
:= New_List
;
9551 procedure TA_Rec_Add_Process_Element
9553 Container
: Node_Or_Entity_Id
;
9554 Counter
: in out Int
;
9557 -- Processing routine for traversal below
9559 procedure TA_Append_Record_Traversal
is
9560 new Append_Record_Traversal
9561 (Rec
=> Expr_Parameter
,
9562 Add_Process_Element
=> TA_Rec_Add_Process_Element
);
9564 --------------------------------
9565 -- TA_Rec_Add_Process_Element --
9566 --------------------------------
9568 procedure TA_Rec_Add_Process_Element
9570 Container
: Node_Or_Entity_Id
;
9571 Counter
: in out Int
;
9575 Field_Ref
: Node_Id
;
9578 if Nkind
(Field
) = N_Defining_Identifier
then
9580 -- A regular component
9582 Field_Ref
:= Make_Selected_Component
(Loc
,
9583 Prefix
=> New_Occurrence_Of
(Rec
, Loc
),
9584 Selector_Name
=> New_Occurrence_Of
(Field
, Loc
));
9585 Set_Etype
(Field_Ref
, Etype
(Field
));
9588 Make_Procedure_Call_Statement
(Loc
,
9591 RTE
(RE_Add_Aggregate_Element
), Loc
),
9592 Parameter_Associations
=> New_List
(
9593 New_Occurrence_Of
(Container
, Loc
),
9594 Build_To_Any_Call
(Field_Ref
, Decls
))));
9599 Variant_Part
: declare
9601 Struct_Counter
: Int
:= 0;
9603 Block_Decls
: constant List_Id
:= New_List
;
9604 Block_Stmts
: constant List_Id
:= New_List
;
9607 Alt_List
: constant List_Id
:= New_List
;
9608 Choice_List
: List_Id
;
9610 Union_Any
: constant Entity_Id
:=
9611 Make_Defining_Identifier
(Loc
,
9612 New_Internal_Name
('V'));
9614 Struct_Any
: constant Entity_Id
:=
9615 Make_Defining_Identifier
(Loc
,
9616 New_Internal_Name
('S'));
9618 function Make_Discriminant_Reference
9620 -- Build reference to the discriminant for this
9623 ---------------------------------
9624 -- Make_Discriminant_Reference --
9625 ---------------------------------
9627 function Make_Discriminant_Reference
9630 Nod
: constant Node_Id
:=
9631 Make_Selected_Component
(Loc
,
9634 Chars
(Name
(Field
)));
9636 Set_Etype
(Nod
, Etype
(Name
(Field
)));
9638 end Make_Discriminant_Reference
;
9640 -- Start of processing for Variant_Part
9644 Make_Block_Statement
(Loc
,
9647 Handled_Statement_Sequence
=>
9648 Make_Handled_Sequence_Of_Statements
(Loc
,
9649 Statements
=> Block_Stmts
)));
9651 -- Declare variant part aggregate (Union_Any).
9652 -- Knowing the position of this VP in the
9653 -- variant record, we can fetch the VP typecode
9656 Append_To
(Block_Decls
,
9657 Make_Object_Declaration
(Loc
,
9658 Defining_Identifier
=> Union_Any
,
9659 Object_Definition
=>
9660 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9662 Make_Function_Call
(Loc
,
9663 Name
=> New_Occurrence_Of
(
9664 RTE
(RE_Create_Any
), Loc
),
9665 Parameter_Associations
=> New_List
(
9666 Make_Function_Call
(Loc
,
9669 RTE
(RE_Any_Member_Type
), Loc
),
9670 Parameter_Associations
=> New_List
(
9671 New_Occurrence_Of
(Container
, Loc
),
9672 Make_Integer_Literal
(Loc
,
9675 -- Declare inner struct aggregate (which
9676 -- contains the components of this VP).
9678 Append_To
(Block_Decls
,
9679 Make_Object_Declaration
(Loc
,
9680 Defining_Identifier
=> Struct_Any
,
9681 Object_Definition
=>
9682 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9684 Make_Function_Call
(Loc
,
9685 Name
=> New_Occurrence_Of
(
9686 RTE
(RE_Create_Any
), Loc
),
9687 Parameter_Associations
=> New_List
(
9688 Make_Function_Call
(Loc
,
9691 RTE
(RE_Any_Member_Type
), Loc
),
9692 Parameter_Associations
=> New_List
(
9693 New_Occurrence_Of
(Union_Any
, Loc
),
9694 Make_Integer_Literal
(Loc
,
9697 -- Build case statement
9699 Append_To
(Block_Stmts
,
9700 Make_Case_Statement
(Loc
,
9701 Expression
=> Make_Discriminant_Reference
,
9702 Alternatives
=> Alt_List
));
9704 Variant
:= First_Non_Pragma
(Variants
(Field
));
9705 while Present
(Variant
) loop
9706 Choice_List
:= New_Copy_List_Tree
9707 (Discrete_Choices
(Variant
));
9709 VP_Stmts
:= New_List
;
9711 -- Append discriminant val to union aggregate
9713 Append_To
(VP_Stmts
,
9714 Make_Procedure_Call_Statement
(Loc
,
9717 RTE
(RE_Add_Aggregate_Element
), Loc
),
9718 Parameter_Associations
=> New_List
(
9719 New_Occurrence_Of
(Union_Any
, Loc
),
9721 (Make_Discriminant_Reference
,
9724 -- Populate inner struct aggregate
9726 -- Struct_Counter should be reset before
9727 -- handling a variant part. Indeed only one
9728 -- of the case statement alternatives will be
9729 -- executed at run-time, so the counter must
9730 -- start at 0 for every case statement.
9732 Struct_Counter
:= 0;
9734 TA_Append_Record_Traversal
(
9736 Clist
=> Component_List
(Variant
),
9737 Container
=> Struct_Any
,
9738 Counter
=> Struct_Counter
);
9740 -- Append inner struct to union aggregate
9742 Append_To
(VP_Stmts
,
9743 Make_Procedure_Call_Statement
(Loc
,
9746 RTE
(RE_Add_Aggregate_Element
), Loc
),
9747 Parameter_Associations
=> New_List
(
9748 New_Occurrence_Of
(Union_Any
, Loc
),
9749 New_Occurrence_Of
(Struct_Any
, Loc
))));
9751 -- Append union to outer aggregate
9753 Append_To
(VP_Stmts
,
9754 Make_Procedure_Call_Statement
(Loc
,
9757 RTE
(RE_Add_Aggregate_Element
), Loc
),
9758 Parameter_Associations
=> New_List
(
9759 New_Occurrence_Of
(Container
, Loc
),
9761 (Union_Any
, Loc
))));
9763 Append_To
(Alt_List
,
9764 Make_Case_Statement_Alternative
(Loc
,
9765 Discrete_Choices
=> Choice_List
,
9766 Statements
=> VP_Stmts
));
9768 Next_Non_Pragma
(Variant
);
9773 Counter
:= Counter
+ 1;
9774 end TA_Rec_Add_Process_Element
;
9777 -- Records are encoded in a TC_STRUCT aggregate:
9779 -- -- Outer aggregate (TC_STRUCT)
9780 -- | [discriminant1]
9781 -- | [discriminant2]
9788 -- A component can be a common component or variant part
9790 -- A variant part is encoded as a TC_UNION aggregate:
9792 -- -- Variant Part Aggregate (TC_UNION)
9793 -- | [discriminant choice for this Variant Part]
9795 -- | -- Inner struct (TC_STRUCT)
9800 -- Let's start by building the outer aggregate. First we
9801 -- construct Elements array containing all discriminants.
9803 if Has_Discriminants
(Typ
) then
9804 Disc
:= First_Discriminant
(Typ
);
9805 while Present
(Disc
) loop
9807 Discriminant
: constant Entity_Id
:=
9808 Make_Selected_Component
(Loc
,
9815 Set_Etype
(Discriminant
, Etype
(Disc
));
9817 Append_To
(Elements
,
9818 Make_Component_Association
(Loc
,
9819 Choices
=> New_List
(
9820 Make_Integer_Literal
(Loc
, Counter
)),
9822 Build_To_Any_Call
(Discriminant
, Decls
)));
9825 Counter
:= Counter
+ 1;
9826 Next_Discriminant
(Disc
);
9830 -- If there are no discriminants, we declare an empty
9834 Dummy_Any
: constant Entity_Id
:=
9835 Make_Defining_Identifier
(Loc
,
9836 Chars
=> New_Internal_Name
('A'));
9840 Make_Object_Declaration
(Loc
,
9841 Defining_Identifier
=> Dummy_Any
,
9842 Object_Definition
=>
9843 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
9845 Append_To
(Elements
,
9846 Make_Component_Association
(Loc
,
9847 Choices
=> New_List
(
9850 Make_Integer_Literal
(Loc
, 1),
9852 Make_Integer_Literal
(Loc
, 0))),
9854 New_Occurrence_Of
(Dummy_Any
, Loc
)));
9858 -- We build the result aggregate with discriminants
9859 -- as the first elements.
9861 Set_Expression
(Any_Decl
,
9862 Make_Function_Call
(Loc
,
9863 Name
=> New_Occurrence_Of
(
9864 RTE
(RE_Any_Aggregate_Build
), Loc
),
9865 Parameter_Associations
=> New_List
(
9867 Make_Aggregate
(Loc
,
9868 Component_Associations
=> Elements
))));
9871 -- Then we append all the components to the result
9874 TA_Append_Record_Traversal
(Stms
,
9875 Clist
=> Component_List
(Rdef
),
9877 Counter
=> Counter
);
9881 elsif Is_Array_Type
(Typ
) then
9883 -- Constrained and unconstrained array types
9886 Constrained
: constant Boolean := Is_Constrained
(Typ
);
9888 procedure TA_Ary_Add_Process_Element
9891 Counter
: Entity_Id
;
9894 --------------------------------
9895 -- TA_Ary_Add_Process_Element --
9896 --------------------------------
9898 procedure TA_Ary_Add_Process_Element
9901 Counter
: Entity_Id
;
9904 pragma Unreferenced
(Counter
);
9906 Element_Any
: Node_Id
;
9909 if Etype
(Datum
) = RTE
(RE_Any
) then
9910 Element_Any
:= Datum
;
9912 Element_Any
:= Build_To_Any_Call
(Datum
, Decls
);
9916 Make_Procedure_Call_Statement
(Loc
,
9917 Name
=> New_Occurrence_Of
(
9918 RTE
(RE_Add_Aggregate_Element
), Loc
),
9919 Parameter_Associations
=> New_List
(
9920 New_Occurrence_Of
(Any
, Loc
),
9922 end TA_Ary_Add_Process_Element
;
9924 procedure Append_To_Any_Array_Iterator
is
9925 new Append_Array_Traversal
(
9927 Arry
=> Expr_Parameter
,
9928 Indices
=> New_List
,
9929 Add_Process_Element
=> TA_Ary_Add_Process_Element
);
9934 Set_Expression
(Any_Decl
,
9935 Make_Function_Call
(Loc
,
9937 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
9938 Parameter_Associations
=> New_List
(Result_TC
)));
9941 if not Constrained
then
9942 Index
:= First_Index
(Typ
);
9943 for J
in 1 .. Number_Dimensions
(Typ
) loop
9945 Make_Procedure_Call_Statement
(Loc
,
9948 RTE
(RE_Add_Aggregate_Element
), Loc
),
9949 Parameter_Associations
=> New_List
(
9950 New_Occurrence_Of
(Any
, Loc
),
9952 OK_Convert_To
(Etype
(Index
),
9953 Make_Attribute_Reference
(Loc
,
9955 New_Occurrence_Of
(Expr_Parameter
, Loc
),
9956 Attribute_Name
=> Name_First
,
9957 Expressions
=> New_List
(
9958 Make_Integer_Literal
(Loc
, J
)))),
9964 Append_To_Any_Array_Iterator
(Stms
, Any
);
9967 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9971 Set_Expression
(Any_Decl
,
9974 Find_Numeric_Representation
(Typ
),
9975 New_Occurrence_Of
(Expr_Parameter
, Loc
)),
9979 -- Default case, including tagged types: opaque representation
9981 Use_Opaque_Representation
:= True;
9984 if Use_Opaque_Representation
then
9986 Strm
: constant Entity_Id
:=
9987 Make_Defining_Identifier
(Loc
,
9988 Chars
=> New_Internal_Name
('S'));
9989 -- Stream used to store data representation produced by
9990 -- stream attribute.
9994 -- Strm : aliased Buffer_Stream_Type;
9997 Make_Object_Declaration
(Loc
,
9998 Defining_Identifier
=>
10002 Object_Definition
=>
10003 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
10006 -- Allocate_Buffer (Strm);
10009 Make_Procedure_Call_Statement
(Loc
,
10011 New_Occurrence_Of
(RTE
(RE_Allocate_Buffer
), Loc
),
10012 Parameter_Associations
=> New_List
(
10013 New_Occurrence_Of
(Strm
, Loc
))));
10016 -- T'Output (Strm'Access, E);
10019 Make_Attribute_Reference
(Loc
,
10020 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
10021 Attribute_Name
=> Name_Output
,
10022 Expressions
=> New_List
(
10023 Make_Attribute_Reference
(Loc
,
10024 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
10025 Attribute_Name
=> Name_Access
),
10026 New_Occurrence_Of
(Expr_Parameter
, Loc
))));
10029 -- BS_To_Any (Strm, A);
10032 Make_Procedure_Call_Statement
(Loc
,
10033 Name
=> New_Occurrence_Of
(RTE
(RE_BS_To_Any
), Loc
),
10034 Parameter_Associations
=> New_List
(
10035 New_Occurrence_Of
(Strm
, Loc
),
10036 New_Occurrence_Of
(Any
, Loc
))));
10039 -- Release_Buffer (Strm);
10042 Make_Procedure_Call_Statement
(Loc
,
10043 Name
=> New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
10044 Parameter_Associations
=> New_List
(
10045 New_Occurrence_Of
(Strm
, Loc
))));
10049 Append_To
(Decls
, Any_Decl
);
10051 if Present
(Result_TC
) then
10053 Make_Procedure_Call_Statement
(Loc
,
10054 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
10055 Parameter_Associations
=> New_List
(
10056 New_Occurrence_Of
(Any
, Loc
),
10061 Make_Simple_Return_Statement
(Loc
,
10062 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
10065 Make_Subprogram_Body
(Loc
,
10066 Specification
=> Spec
,
10067 Declarations
=> Decls
,
10068 Handled_Statement_Sequence
=>
10069 Make_Handled_Sequence_Of_Statements
(Loc
,
10070 Statements
=> Stms
));
10071 end Build_To_Any_Function
;
10073 -------------------------
10074 -- Build_TypeCode_Call --
10075 -------------------------
10077 function Build_TypeCode_Call
10080 Decls
: List_Id
) return Node_Id
10082 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
10083 -- The full view, if Typ is private; the completion,
10084 -- if Typ is incomplete.
10086 Fnam
: Entity_Id
:= Empty
;
10087 Lib_RE
: RE_Id
:= RE_Null
;
10091 -- Special case System.PolyORB.Interface.Any: its primitives have
10092 -- not been set yet, so can't call Find_Inherited_TSS.
10094 if Typ
= RTE
(RE_Any
) then
10095 Fnam
:= RTE
(RE_TC_A
);
10098 -- First simple case where the TypeCode is present
10099 -- in the type's TSS.
10101 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_TypeCode
);
10105 if Sloc
(U_Type
) <= Standard_Location
then
10107 -- Do not try to build alias typecodes for subtypes from
10110 U_Type
:= Base_Type
(U_Type
);
10113 if U_Type
= Standard_Boolean
then
10116 elsif U_Type
= Standard_Character
then
10119 elsif U_Type
= Standard_Wide_Character
then
10120 Lib_RE
:= RE_TC_WC
;
10122 elsif U_Type
= Standard_Wide_Wide_Character
then
10123 Lib_RE
:= RE_TC_WWC
;
10125 -- Floating point types
10127 elsif U_Type
= Standard_Short_Float
then
10128 Lib_RE
:= RE_TC_SF
;
10130 elsif U_Type
= Standard_Float
then
10133 elsif U_Type
= Standard_Long_Float
then
10134 Lib_RE
:= RE_TC_LF
;
10136 elsif U_Type
= Standard_Long_Long_Float
then
10137 Lib_RE
:= RE_TC_LLF
;
10139 -- Integer types (walk back to the base type)
10141 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
10142 Lib_RE
:= RE_TC_SSI
;
10144 elsif U_Type
= Etype
(Standard_Short_Integer
) then
10145 Lib_RE
:= RE_TC_SI
;
10147 elsif U_Type
= Etype
(Standard_Integer
) then
10150 elsif U_Type
= Etype
(Standard_Long_Integer
) then
10151 Lib_RE
:= RE_TC_LI
;
10153 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
10154 Lib_RE
:= RE_TC_LLI
;
10156 -- Unsigned integer types
10158 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
10159 Lib_RE
:= RE_TC_SSU
;
10161 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
10162 Lib_RE
:= RE_TC_SU
;
10164 elsif U_Type
= RTE
(RE_Unsigned
) then
10167 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
10168 Lib_RE
:= RE_TC_LU
;
10170 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
10171 Lib_RE
:= RE_TC_LLU
;
10173 elsif Is_RTE
(U_Type
, RE_Unbounded_String
) then
10174 Lib_RE
:= RE_TC_String
;
10176 -- Special DSA types
10178 elsif Is_RTE
(U_Type
, RE_Any_Container_Ptr
) then
10181 -- Other (non-primitive) types
10187 Build_TypeCode_Function
(Loc
, U_Type
, Decl
, Fnam
);
10188 Append_To
(Decls
, Decl
);
10192 if Lib_RE
/= RE_Null
then
10193 Fnam
:= RTE
(Lib_RE
);
10197 -- Call the function
10200 Make_Function_Call
(Loc
, Name
=> New_Occurrence_Of
(Fnam
, Loc
));
10202 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10204 Set_Etype
(Expr
, RTE
(RE_TypeCode
));
10207 end Build_TypeCode_Call
;
10209 -----------------------------
10210 -- Build_TypeCode_Function --
10211 -----------------------------
10213 procedure Build_TypeCode_Function
10216 Decl
: out Node_Id
;
10217 Fnam
: out Entity_Id
)
10220 Decls
: constant List_Id
:= New_List
;
10221 Stms
: constant List_Id
:= New_List
;
10223 TCNam
: constant Entity_Id
:=
10224 Make_Helper_Function_Name
(Loc
, Typ
, Name_TypeCode
);
10226 Parameters
: List_Id
;
10228 procedure Add_String_Parameter
10230 Parameter_List
: List_Id
);
10231 -- Add a literal for S to Parameters
10233 procedure Add_TypeCode_Parameter
10234 (TC_Node
: Node_Id
;
10235 Parameter_List
: List_Id
);
10236 -- Add the typecode for Typ to Parameters
10238 procedure Add_Long_Parameter
10239 (Expr_Node
: Node_Id
;
10240 Parameter_List
: List_Id
);
10241 -- Add a signed long integer expression to Parameters
10243 procedure Initialize_Parameter_List
10244 (Name_String
: String_Id
;
10245 Repo_Id_String
: String_Id
;
10246 Parameter_List
: out List_Id
);
10247 -- Return a list that contains the first two parameters
10248 -- for a parameterized typecode: name and repository id.
10250 function Make_Constructed_TypeCode
10252 Parameters
: List_Id
) return Node_Id
;
10253 -- Call TC_Build with the given kind and parameters
10255 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
);
10256 -- Make a return statement that calls TC_Build with the given
10257 -- typecode kind, and the constructed parameters list.
10259 procedure Return_Alias_TypeCode
(Base_TypeCode
: Node_Id
);
10260 -- Return a typecode that is a TC_Alias for the given typecode
10262 --------------------------
10263 -- Add_String_Parameter --
10264 --------------------------
10266 procedure Add_String_Parameter
10268 Parameter_List
: List_Id
)
10271 Append_To
(Parameter_List
,
10272 Make_Function_Call
(Loc
,
10273 Name
=> New_Occurrence_Of
(RTE
(RE_TA_Std_String
), Loc
),
10274 Parameter_Associations
=> New_List
(
10275 Make_String_Literal
(Loc
, S
))));
10276 end Add_String_Parameter
;
10278 ----------------------------
10279 -- Add_TypeCode_Parameter --
10280 ----------------------------
10282 procedure Add_TypeCode_Parameter
10283 (TC_Node
: Node_Id
;
10284 Parameter_List
: List_Id
)
10287 Append_To
(Parameter_List
,
10288 Make_Function_Call
(Loc
,
10289 Name
=> New_Occurrence_Of
(RTE
(RE_TA_TC
), Loc
),
10290 Parameter_Associations
=> New_List
(TC_Node
)));
10291 end Add_TypeCode_Parameter
;
10293 ------------------------
10294 -- Add_Long_Parameter --
10295 ------------------------
10297 procedure Add_Long_Parameter
10298 (Expr_Node
: Node_Id
;
10299 Parameter_List
: List_Id
)
10302 Append_To
(Parameter_List
,
10303 Make_Function_Call
(Loc
,
10304 Name
=> New_Occurrence_Of
(RTE
(RE_TA_LI
), Loc
),
10305 Parameter_Associations
=> New_List
(Expr_Node
)));
10306 end Add_Long_Parameter
;
10308 -------------------------------
10309 -- Initialize_Parameter_List --
10310 -------------------------------
10312 procedure Initialize_Parameter_List
10313 (Name_String
: String_Id
;
10314 Repo_Id_String
: String_Id
;
10315 Parameter_List
: out List_Id
)
10318 Parameter_List
:= New_List
;
10319 Add_String_Parameter
(Name_String
, Parameter_List
);
10320 Add_String_Parameter
(Repo_Id_String
, Parameter_List
);
10321 end Initialize_Parameter_List
;
10323 ---------------------------
10324 -- Return_Alias_TypeCode --
10325 ---------------------------
10327 procedure Return_Alias_TypeCode
10328 (Base_TypeCode
: Node_Id
)
10331 Add_TypeCode_Parameter
(Base_TypeCode
, Parameters
);
10332 Return_Constructed_TypeCode
(RTE
(RE_TC_Alias
));
10333 end Return_Alias_TypeCode
;
10335 -------------------------------
10336 -- Make_Constructed_TypeCode --
10337 -------------------------------
10339 function Make_Constructed_TypeCode
10341 Parameters
: List_Id
) return Node_Id
10343 Constructed_TC
: constant Node_Id
:=
10344 Make_Function_Call
(Loc
,
10346 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
10347 Parameter_Associations
=> New_List
(
10348 New_Occurrence_Of
(Kind
, Loc
),
10349 Make_Aggregate
(Loc
,
10350 Expressions
=> Parameters
)));
10352 Set_Etype
(Constructed_TC
, RTE
(RE_TypeCode
));
10353 return Constructed_TC
;
10354 end Make_Constructed_TypeCode
;
10356 ---------------------------------
10357 -- Return_Constructed_TypeCode --
10358 ---------------------------------
10360 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
) is
10363 Make_Simple_Return_Statement
(Loc
,
10365 Make_Constructed_TypeCode
(Kind
, Parameters
)));
10366 end Return_Constructed_TypeCode
;
10372 procedure TC_Rec_Add_Process_Element
10375 Counter
: in out Int
;
10379 procedure TC_Append_Record_Traversal
is
10380 new Append_Record_Traversal
(
10382 Add_Process_Element
=> TC_Rec_Add_Process_Element
);
10384 --------------------------------
10385 -- TC_Rec_Add_Process_Element --
10386 --------------------------------
10388 procedure TC_Rec_Add_Process_Element
10391 Counter
: in out Int
;
10395 pragma Unreferenced
(Any
, Counter
, Rec
);
10398 if Nkind
(Field
) = N_Defining_Identifier
then
10400 -- A regular component
10402 Add_TypeCode_Parameter
10403 (Build_TypeCode_Call
(Loc
, Etype
(Field
), Decls
), Params
);
10404 Get_Name_String
(Chars
(Field
));
10405 Add_String_Parameter
(String_From_Name_Buffer
, Params
);
10412 Discriminant_Type
: constant Entity_Id
:=
10413 Etype
(Name
(Field
));
10415 Is_Enum
: constant Boolean :=
10416 Is_Enumeration_Type
(Discriminant_Type
);
10418 Union_TC_Params
: List_Id
;
10420 U_Name
: constant Name_Id
:=
10421 New_External_Name
(Chars
(Typ
), 'V', -1);
10423 Name_Str
: String_Id
;
10424 Struct_TC_Params
: List_Id
;
10428 Default
: constant Node_Id
:=
10429 Make_Integer_Literal
(Loc
, -1);
10431 Dummy_Counter
: Int
:= 0;
10433 Choice_Index
: Int
:= 0;
10435 procedure Add_Params_For_Variant_Components
;
10436 -- Add a struct TypeCode and a corresponding member name
10437 -- to the union parameter list.
10439 -- Ordering of declarations is a complete mess in this
10440 -- area, it is supposed to be types/variables, then
10441 -- subprogram specs, then subprogram bodies ???
10443 ---------------------------------------
10444 -- Add_Params_For_Variant_Components --
10445 ---------------------------------------
10447 procedure Add_Params_For_Variant_Components
10449 S_Name
: constant Name_Id
:=
10450 New_External_Name
(U_Name
, 'S', -1);
10453 Get_Name_String
(S_Name
);
10454 Name_Str
:= String_From_Name_Buffer
;
10455 Initialize_Parameter_List
10456 (Name_Str
, Name_Str
, Struct_TC_Params
);
10458 -- Build struct parameters
10460 TC_Append_Record_Traversal
(Struct_TC_Params
,
10461 Component_List
(Variant
),
10465 Add_TypeCode_Parameter
10466 (Make_Constructed_TypeCode
10467 (RTE
(RE_TC_Struct
), Struct_TC_Params
),
10470 Add_String_Parameter
(Name_Str
, Union_TC_Params
);
10471 end Add_Params_For_Variant_Components
;
10474 Get_Name_String
(U_Name
);
10475 Name_Str
:= String_From_Name_Buffer
;
10477 Initialize_Parameter_List
10478 (Name_Str
, Name_Str
, Union_TC_Params
);
10480 -- Add union in enclosing parameter list
10482 Add_TypeCode_Parameter
10483 (Make_Constructed_TypeCode
10484 (RTE
(RE_TC_Union
), Union_TC_Params
),
10487 Add_String_Parameter
(Name_Str
, Params
);
10489 -- Build union parameters
10491 Add_TypeCode_Parameter
10492 (Build_TypeCode_Call
10493 (Loc
, Discriminant_Type
, Decls
),
10496 Add_Long_Parameter
(Default
, Union_TC_Params
);
10498 Variant
:= First_Non_Pragma
(Variants
(Field
));
10499 while Present
(Variant
) loop
10500 Choice
:= First
(Discrete_Choices
(Variant
));
10501 while Present
(Choice
) loop
10502 case Nkind
(Choice
) is
10505 L
: constant Uint
:=
10506 Expr_Value
(Low_Bound
(Choice
));
10507 H
: constant Uint
:=
10508 Expr_Value
(High_Bound
(Choice
));
10510 -- 3.8.1(8) guarantees that the bounds of
10511 -- this range are static.
10518 Expr
:= New_Occurrence_Of
(
10519 Get_Enum_Lit_From_Pos
(
10520 Discriminant_Type
, J
, Loc
), Loc
);
10523 Make_Integer_Literal
(Loc
, J
);
10525 Append_To
(Union_TC_Params
,
10526 Build_To_Any_Call
(Expr
, Decls
));
10528 Add_Params_For_Variant_Components
;
10533 when N_Others_Choice
=>
10535 -- This variant possess a default choice.
10536 -- We must therefore set the default
10537 -- parameter to the current choice index. The
10538 -- default parameter is by construction the
10539 -- fourth in the Union_TC_Params list.
10542 Default_Node
: constant Node_Id
:=
10543 Pick
(Union_TC_Params
, 4);
10545 New_Default_Node
: constant Node_Id
:=
10546 Make_Function_Call
(Loc
,
10549 (RTE
(RE_TA_LI
), Loc
),
10550 Parameter_Associations
=>
10552 Make_Integer_Literal
10553 (Loc
, Choice_Index
)));
10559 Remove
(Default_Node
);
10562 -- Add a placeholder member label
10563 -- for the default case.
10564 -- It must be of the discriminant type.
10567 Exp
: constant Node_Id
:=
10568 Make_Attribute_Reference
(Loc
,
10569 Prefix
=> New_Occurrence_Of
10570 (Discriminant_Type
, Loc
),
10571 Attribute_Name
=> Name_First
);
10573 Set_Etype
(Exp
, Discriminant_Type
);
10574 Append_To
(Union_TC_Params
,
10575 Build_To_Any_Call
(Exp
, Decls
));
10578 Add_Params_For_Variant_Components
;
10582 -- Case of an explicit choice
10585 Exp
: constant Node_Id
:=
10586 New_Copy_Tree
(Choice
);
10588 Append_To
(Union_TC_Params
,
10589 Build_To_Any_Call
(Exp
, Decls
));
10592 Add_Params_For_Variant_Components
;
10596 Choice_Index
:= Choice_Index
+ 1;
10599 Next_Non_Pragma
(Variant
);
10603 end TC_Rec_Add_Process_Element
;
10605 Type_Name_Str
: String_Id
;
10606 Type_Repo_Id_Str
: String_Id
;
10609 if Is_Itype
(Typ
) then
10610 Build_TypeCode_Function
10612 Typ
=> Etype
(Typ
),
10621 Make_Function_Specification
(Loc
,
10622 Defining_Unit_Name
=> Fnam
,
10623 Parameter_Specifications
=> Empty_List
,
10624 Result_Definition
=>
10625 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
10627 Build_Name_And_Repository_Id
(Typ
,
10628 Name_Str
=> Type_Name_Str
, Repo_Id_Str
=> Type_Repo_Id_Str
);
10630 Initialize_Parameter_List
10631 (Type_Name_Str
, Type_Repo_Id_Str
, Parameters
);
10633 if Has_Stream_Attribute_Definition
10634 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
10636 Has_Stream_Attribute_Definition
10637 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
10639 -- If user-defined stream attributes are specified for this
10640 -- type, use them and transmit data as an opaque sequence of
10641 -- stream elements.
10643 Return_Alias_TypeCode
10644 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10646 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
10647 Return_Alias_TypeCode
(
10648 Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10650 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
10651 Return_Alias_TypeCode
(
10652 Build_TypeCode_Call
(Loc
,
10653 Find_Numeric_Representation
(Typ
), Decls
));
10655 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
10657 -- Record typecodes are encoded as follows:
10661 -- | [Repository Id]
10663 -- Then for each discriminant:
10665 -- | [Discriminant Type Code]
10666 -- | [Discriminant Name]
10669 -- Then for each component:
10671 -- | [Component Type Code]
10672 -- | [Component Name]
10675 -- Variants components type codes are encoded as follows:
10679 -- | [Repository Id]
10680 -- | [Discriminant Type Code]
10681 -- | [Index of Default Variant Part or -1 for no default]
10683 -- Then for each Variant Part :
10688 -- | | [Variant Part Name]
10689 -- | | [Variant Part Repository Id]
10691 -- | Then for each VP component:
10692 -- | | [VP component Typecode]
10693 -- | | [VP component Name]
10699 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
10700 Return_Alias_TypeCode
10701 (Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10705 Disc
: Entity_Id
:= Empty
;
10706 Rdef
: constant Node_Id
:=
10707 Type_Definition
(Declaration_Node
(Typ
));
10708 Dummy_Counter
: Int
:= 0;
10711 -- Construct the discriminants typecodes
10713 if Has_Discriminants
(Typ
) then
10714 Disc
:= First_Discriminant
(Typ
);
10717 while Present
(Disc
) loop
10718 Add_TypeCode_Parameter
(
10719 Build_TypeCode_Call
(Loc
, Etype
(Disc
), Decls
),
10721 Get_Name_String
(Chars
(Disc
));
10722 Add_String_Parameter
(
10723 String_From_Name_Buffer
,
10725 Next_Discriminant
(Disc
);
10728 -- then the components typecodes
10730 TC_Append_Record_Traversal
10731 (Parameters
, Component_List
(Rdef
),
10732 Empty
, Dummy_Counter
);
10733 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10737 elsif Is_Array_Type
(Typ
) then
10739 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10740 Inner_TypeCode
: Node_Id
;
10741 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10742 Indx
: Node_Id
:= First_Index
(Typ
);
10746 Build_TypeCode_Call
(Loc
, Component_Type
(Typ
), Decls
);
10748 for J
in 1 .. Ndim
loop
10749 if Constrained
then
10750 Inner_TypeCode
:= Make_Constructed_TypeCode
10751 (RTE
(RE_TC_Array
), New_List
(
10752 Build_To_Any_Call
(
10753 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10754 Make_Attribute_Reference
(Loc
,
10755 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
10756 Attribute_Name
=> Name_Length
,
10757 Expressions
=> New_List
(
10758 Make_Integer_Literal
(Loc
,
10759 Intval
=> Ndim
- J
+ 1)))),
10761 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10764 -- Unconstrained case: add low bound for each
10767 Add_TypeCode_Parameter
10768 (Build_TypeCode_Call
(Loc
, Etype
(Indx
), Decls
),
10770 Get_Name_String
(New_External_Name
('L', J
));
10771 Add_String_Parameter
(
10772 String_From_Name_Buffer
,
10776 Inner_TypeCode
:= Make_Constructed_TypeCode
10777 (RTE
(RE_TC_Sequence
), New_List
(
10778 Build_To_Any_Call
(
10779 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10780 Make_Integer_Literal
(Loc
, 0)),
10782 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10786 if Constrained
then
10787 Return_Alias_TypeCode
(Inner_TypeCode
);
10789 Add_TypeCode_Parameter
(Inner_TypeCode
, Parameters
);
10791 Store_String_Char
('V');
10792 Add_String_Parameter
(End_String
, Parameters
);
10793 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10798 -- Default: type is represented as an opaque sequence of bytes
10800 Return_Alias_TypeCode
10801 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10805 Make_Subprogram_Body
(Loc
,
10806 Specification
=> Spec
,
10807 Declarations
=> Decls
,
10808 Handled_Statement_Sequence
=>
10809 Make_Handled_Sequence_Of_Statements
(Loc
,
10810 Statements
=> Stms
));
10811 end Build_TypeCode_Function
;
10813 ---------------------------------
10814 -- Find_Numeric_Representation --
10815 ---------------------------------
10817 function Find_Numeric_Representation
10818 (Typ
: Entity_Id
) return Entity_Id
10820 FST
: constant Entity_Id
:= First_Subtype
(Typ
);
10821 P_Size
: constant Uint
:= Esize
(FST
);
10824 if Is_Unsigned_Type
(Typ
) then
10825 if P_Size
<= Standard_Short_Short_Integer_Size
then
10826 return RTE
(RE_Short_Short_Unsigned
);
10828 elsif P_Size
<= Standard_Short_Integer_Size
then
10829 return RTE
(RE_Short_Unsigned
);
10831 elsif P_Size
<= Standard_Integer_Size
then
10832 return RTE
(RE_Unsigned
);
10834 elsif P_Size
<= Standard_Long_Integer_Size
then
10835 return RTE
(RE_Long_Unsigned
);
10838 return RTE
(RE_Long_Long_Unsigned
);
10841 elsif Is_Integer_Type
(Typ
) then
10842 if P_Size
<= Standard_Short_Short_Integer_Size
then
10843 return Standard_Short_Short_Integer
;
10845 elsif P_Size
<= Standard_Short_Integer_Size
then
10846 return Standard_Short_Integer
;
10848 elsif P_Size
<= Standard_Integer_Size
then
10849 return Standard_Integer
;
10851 elsif P_Size
<= Standard_Long_Integer_Size
then
10852 return Standard_Long_Integer
;
10855 return Standard_Long_Long_Integer
;
10858 elsif Is_Floating_Point_Type
(Typ
) then
10859 if P_Size
<= Standard_Short_Float_Size
then
10860 return Standard_Short_Float
;
10862 elsif P_Size
<= Standard_Float_Size
then
10863 return Standard_Float
;
10865 elsif P_Size
<= Standard_Long_Float_Size
then
10866 return Standard_Long_Float
;
10869 return Standard_Long_Long_Float
;
10873 raise Program_Error
;
10876 -- TBD: fixed point types???
10877 -- TBverified numeric types with a biased representation???
10879 end Find_Numeric_Representation
;
10881 ---------------------------
10882 -- Append_Array_Traversal --
10883 ---------------------------
10885 procedure Append_Array_Traversal
10888 Counter
: Entity_Id
:= Empty
;
10891 Loc
: constant Source_Ptr
:= Sloc
(Subprogram
);
10892 Typ
: constant Entity_Id
:= Etype
(Arry
);
10893 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10894 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10896 Inner_Any
, Inner_Counter
: Entity_Id
;
10898 Loop_Stm
: Node_Id
;
10899 Inner_Stmts
: constant List_Id
:= New_List
;
10902 if Depth
> Ndim
then
10904 -- Processing for one element of an array
10907 Element_Expr
: constant Node_Id
:=
10908 Make_Indexed_Component
(Loc
,
10909 New_Occurrence_Of
(Arry
, Loc
),
10912 Set_Etype
(Element_Expr
, Component_Type
(Typ
));
10913 Add_Process_Element
(Stmts
,
10915 Counter
=> Counter
,
10916 Datum
=> Element_Expr
);
10922 Append_To
(Indices
,
10923 Make_Identifier
(Loc
, New_External_Name
('L', Depth
)));
10925 if not Constrained
or else Depth
> 1 then
10926 Inner_Any
:= Make_Defining_Identifier
(Loc
,
10927 New_External_Name
('A', Depth
));
10928 Set_Etype
(Inner_Any
, RTE
(RE_Any
));
10930 Inner_Any
:= Empty
;
10933 if Present
(Counter
) then
10934 Inner_Counter
:= Make_Defining_Identifier
(Loc
,
10935 New_External_Name
('J', Depth
));
10937 Inner_Counter
:= Empty
;
10941 Loop_Any
: Node_Id
:= Inner_Any
;
10944 -- For the first dimension of a constrained array, we add
10945 -- elements directly in the corresponding Any; there is no
10946 -- intervening inner Any.
10948 if No
(Loop_Any
) then
10952 Append_Array_Traversal
(Inner_Stmts
,
10954 Counter
=> Inner_Counter
,
10955 Depth
=> Depth
+ 1);
10959 Make_Implicit_Loop_Statement
(Subprogram
,
10960 Iteration_Scheme
=>
10961 Make_Iteration_Scheme
(Loc
,
10962 Loop_Parameter_Specification
=>
10963 Make_Loop_Parameter_Specification
(Loc
,
10964 Defining_Identifier
=>
10965 Make_Defining_Identifier
(Loc
,
10966 Chars
=> New_External_Name
('L', Depth
)),
10968 Discrete_Subtype_Definition
=>
10969 Make_Attribute_Reference
(Loc
,
10970 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10971 Attribute_Name
=> Name_Range
,
10973 Expressions
=> New_List
(
10974 Make_Integer_Literal
(Loc
, Depth
))))),
10975 Statements
=> Inner_Stmts
);
10978 Decls
: constant List_Id
:= New_List
;
10979 Dimen_Stmts
: constant List_Id
:= New_List
;
10980 Length_Node
: Node_Id
;
10982 Inner_Any_TypeCode
: constant Entity_Id
:=
10983 Make_Defining_Identifier
(Loc
,
10984 New_External_Name
('T', Depth
));
10986 Inner_Any_TypeCode_Expr
: Node_Id
;
10990 if Constrained
then
10991 Inner_Any_TypeCode_Expr
:=
10992 Make_Function_Call
(Loc
,
10993 Name
=> New_Occurrence_Of
(RTE
(RE_Get_TC
), Loc
),
10994 Parameter_Associations
=> New_List
(
10995 New_Occurrence_Of
(Any
, Loc
)));
10997 Inner_Any_TypeCode_Expr
:=
10998 Make_Function_Call
(Loc
,
11000 New_Occurrence_Of
(RTE
(RE_Any_Member_Type
), Loc
),
11001 Parameter_Associations
=> New_List
(
11002 New_Occurrence_Of
(Any
, Loc
),
11003 Make_Integer_Literal
(Loc
, Ndim
)));
11006 Inner_Any_TypeCode_Expr
:=
11007 Make_Function_Call
(Loc
,
11008 Name
=> New_Occurrence_Of
(RTE
(RE_Content_Type
), Loc
),
11009 Parameter_Associations
=> New_List
(
11010 Make_Identifier
(Loc
,
11011 Chars
=> New_External_Name
('T', Depth
- 1))));
11015 Make_Object_Declaration
(Loc
,
11016 Defining_Identifier
=> Inner_Any_TypeCode
,
11017 Constant_Present
=> True,
11018 Object_Definition
=> New_Occurrence_Of
(
11019 RTE
(RE_TypeCode
), Loc
),
11020 Expression
=> Inner_Any_TypeCode_Expr
));
11022 if Present
(Inner_Any
) then
11024 Make_Object_Declaration
(Loc
,
11025 Defining_Identifier
=> Inner_Any
,
11026 Object_Definition
=>
11027 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
11029 Make_Function_Call
(Loc
,
11031 New_Occurrence_Of
(
11032 RTE
(RE_Create_Any
), Loc
),
11033 Parameter_Associations
=> New_List
(
11034 New_Occurrence_Of
(Inner_Any_TypeCode
, Loc
)))));
11037 if Present
(Inner_Counter
) then
11039 Make_Object_Declaration
(Loc
,
11040 Defining_Identifier
=> Inner_Counter
,
11041 Object_Definition
=>
11042 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
11044 Make_Integer_Literal
(Loc
, 0)));
11047 if not Constrained
then
11048 Length_Node
:= Make_Attribute_Reference
(Loc
,
11049 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
11050 Attribute_Name
=> Name_Length
,
11052 New_List
(Make_Integer_Literal
(Loc
, Depth
)));
11053 Set_Etype
(Length_Node
, RTE
(RE_Long_Unsigned
));
11055 Add_Process_Element
(Dimen_Stmts
,
11056 Datum
=> Length_Node
,
11058 Counter
=> Inner_Counter
);
11061 -- Loop_Stm does appropriate processing for each element
11064 Append_To
(Dimen_Stmts
, Loop_Stm
);
11066 -- Link outer and inner any
11068 if Present
(Inner_Any
) then
11069 Add_Process_Element
(Dimen_Stmts
,
11071 Counter
=> Counter
,
11072 Datum
=> New_Occurrence_Of
(Inner_Any
, Loc
));
11076 Make_Block_Statement
(Loc
,
11079 Handled_Statement_Sequence
=>
11080 Make_Handled_Sequence_Of_Statements
(Loc
,
11081 Statements
=> Dimen_Stmts
)));
11083 end Append_Array_Traversal
;
11085 -------------------------------
11086 -- Make_Helper_Function_Name --
11087 -------------------------------
11089 function Make_Helper_Function_Name
11092 Nam
: Name_Id
) return Entity_Id
11097 -- For tagged types, we use a canonical name so that it matches
11098 -- the primitive spec. For all other cases, we use a serialized
11099 -- name so that multiple generations of the same procedure do
11103 if not Is_Tagged_Type
(Typ
) then
11104 Serial
:= Increment_Serial_Number
;
11107 -- Use prefixed underscore to avoid potential clash with used
11108 -- identifier (we use attribute names for Nam).
11111 Make_Defining_Identifier
(Loc
,
11114 (Related_Id
=> Nam
,
11115 Suffix
=> ' ', Suffix_Index
=> Serial
,
11118 end Make_Helper_Function_Name
;
11121 -----------------------------------
11122 -- Reserve_NamingContext_Methods --
11123 -----------------------------------
11125 procedure Reserve_NamingContext_Methods
is
11126 Str_Resolve
: constant String := "resolve";
11128 Name_Buffer
(1 .. Str_Resolve
'Length) := Str_Resolve
;
11129 Name_Len
:= Str_Resolve
'Length;
11130 Overload_Counter_Table
.Set
(Name_Find
, 1);
11131 end Reserve_NamingContext_Methods
;
11133 end PolyORB_Support
;
11135 -------------------------------
11136 -- RACW_Type_Is_Asynchronous --
11137 -------------------------------
11139 procedure RACW_Type_Is_Asynchronous
(RACW_Type
: Entity_Id
) is
11140 Asynchronous_Flag
: constant Entity_Id
:=
11141 Asynchronous_Flags_Table
.Get
(RACW_Type
);
11143 Replace
(Expression
(Parent
(Asynchronous_Flag
)),
11144 New_Occurrence_Of
(Standard_True
, Sloc
(Asynchronous_Flag
)));
11145 end RACW_Type_Is_Asynchronous
;
11147 -------------------------
11148 -- RCI_Package_Locator --
11149 -------------------------
11151 function RCI_Package_Locator
11153 Package_Spec
: Node_Id
) return Node_Id
11156 Pkg_Name
: String_Id
;
11159 Get_Library_Unit_Name_String
(Package_Spec
);
11160 Pkg_Name
:= String_From_Name_Buffer
;
11162 Make_Package_Instantiation
(Loc
,
11163 Defining_Unit_Name
=>
11164 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
11166 New_Occurrence_Of
(RTE
(RE_RCI_Locator
), Loc
),
11167 Generic_Associations
=> New_List
(
11168 Make_Generic_Association
(Loc
,
11170 Make_Identifier
(Loc
, Name_RCI_Name
),
11171 Explicit_Generic_Actual_Parameter
=>
11172 Make_String_Literal
(Loc
,
11173 Strval
=> Pkg_Name
)),
11174 Make_Generic_Association
(Loc
,
11176 Make_Identifier
(Loc
, Name_Version
),
11177 Explicit_Generic_Actual_Parameter
=>
11178 Make_Attribute_Reference
(Loc
,
11180 New_Occurrence_Of
(Defining_Entity
(Package_Spec
), Loc
),
11184 RCI_Locator_Table
.Set
(Defining_Unit_Name
(Package_Spec
),
11185 Defining_Unit_Name
(Inst
));
11187 end RCI_Package_Locator
;
11189 -----------------------------------------------
11190 -- Remote_Types_Tagged_Full_View_Encountered --
11191 -----------------------------------------------
11193 procedure Remote_Types_Tagged_Full_View_Encountered
11194 (Full_View
: Entity_Id
)
11196 Stub_Elements
: constant Stub_Structure
:=
11197 Stubs_Table
.Get
(Full_View
);
11200 -- For an RACW encountered before the freeze point of its designated
11201 -- type, the stub type is generated at the point of the RACW declaration
11202 -- but the primitives are generated only once the designated type is
11203 -- frozen. That freeze can occur in another scope, for example when the
11204 -- RACW is declared in a nested package. In that case we need to
11205 -- reestablish the stub type's scope prior to generating its primitive
11208 if Stub_Elements
/= Empty_Stub_Structure
then
11210 Saved_Scope
: constant Entity_Id
:= Current_Scope
;
11211 Stubs_Scope
: constant Entity_Id
:=
11212 Scope
(Stub_Elements
.Stub_Type
);
11215 if Current_Scope
/= Stubs_Scope
then
11216 Push_Scope
(Stubs_Scope
);
11219 Add_RACW_Primitive_Declarations_And_Bodies
11221 Stub_Elements
.RPC_Receiver_Decl
,
11222 Stub_Elements
.Body_Decls
);
11224 if Current_Scope
/= Saved_Scope
then
11229 end Remote_Types_Tagged_Full_View_Encountered
;
11231 -------------------
11232 -- Scope_Of_Spec --
11233 -------------------
11235 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
is
11236 Unit_Name
: Node_Id
;
11239 Unit_Name
:= Defining_Unit_Name
(Spec
);
11240 while Nkind
(Unit_Name
) /= N_Defining_Identifier
loop
11241 Unit_Name
:= Defining_Identifier
(Unit_Name
);
11247 ----------------------
11248 -- Set_Renaming_TSS --
11249 ----------------------
11251 procedure Set_Renaming_TSS
11254 TSS_Nam
: TSS_Name_Type
)
11256 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
11257 Spec
: constant Node_Id
:= Parent
(Nam
);
11259 TSS_Node
: constant Node_Id
:=
11260 Make_Subprogram_Renaming_Declaration
(Loc
,
11262 Copy_Specification
(Loc
,
11264 New_Name
=> Make_TSS_Name
(Typ
, TSS_Nam
)),
11265 Name
=> New_Occurrence_Of
(Nam
, Loc
));
11267 Snam
: constant Entity_Id
:=
11268 Defining_Unit_Name
(Specification
(TSS_Node
));
11271 if Nkind
(Spec
) = N_Function_Specification
then
11272 Set_Ekind
(Snam
, E_Function
);
11273 Set_Etype
(Snam
, Entity
(Result_Definition
(Spec
)));
11275 Set_Ekind
(Snam
, E_Procedure
);
11276 Set_Etype
(Snam
, Standard_Void_Type
);
11279 Set_TSS
(Typ
, Snam
);
11280 end Set_Renaming_TSS
;
11282 ----------------------------------------------
11283 -- Specific_Add_Obj_RPC_Receiver_Completion --
11284 ----------------------------------------------
11286 procedure Specific_Add_Obj_RPC_Receiver_Completion
11289 RPC_Receiver
: Entity_Id
;
11290 Stub_Elements
: Stub_Structure
)
11293 case Get_PCS_Name
is
11294 when Name_PolyORB_DSA
=>
11295 PolyORB_Support
.Add_Obj_RPC_Receiver_Completion
(Loc
,
11296 Decls
, RPC_Receiver
, Stub_Elements
);
11298 GARLIC_Support
.Add_Obj_RPC_Receiver_Completion
(Loc
,
11299 Decls
, RPC_Receiver
, Stub_Elements
);
11301 end Specific_Add_Obj_RPC_Receiver_Completion
;
11303 --------------------------------
11304 -- Specific_Add_RACW_Features --
11305 --------------------------------
11307 procedure Specific_Add_RACW_Features
11308 (RACW_Type
: Entity_Id
;
11310 Stub_Type
: Entity_Id
;
11311 Stub_Type_Access
: Entity_Id
;
11312 RPC_Receiver_Decl
: Node_Id
;
11313 Body_Decls
: List_Id
)
11316 case Get_PCS_Name
is
11317 when Name_PolyORB_DSA
=>
11318 PolyORB_Support
.Add_RACW_Features
11327 GARLIC_Support
.Add_RACW_Features
11334 end Specific_Add_RACW_Features
;
11336 --------------------------------
11337 -- Specific_Add_RAST_Features --
11338 --------------------------------
11340 procedure Specific_Add_RAST_Features
11341 (Vis_Decl
: Node_Id
;
11342 RAS_Type
: Entity_Id
)
11345 case Get_PCS_Name
is
11346 when Name_PolyORB_DSA
=>
11347 PolyORB_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
11349 GARLIC_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
11351 end Specific_Add_RAST_Features
;
11353 --------------------------------------------------
11354 -- Specific_Add_Receiving_Stubs_To_Declarations --
11355 --------------------------------------------------
11357 procedure Specific_Add_Receiving_Stubs_To_Declarations
11358 (Pkg_Spec
: Node_Id
;
11363 case Get_PCS_Name
is
11364 when Name_PolyORB_DSA
=>
11365 PolyORB_Support
.Add_Receiving_Stubs_To_Declarations
11366 (Pkg_Spec
, Decls
, Stmts
);
11368 GARLIC_Support
.Add_Receiving_Stubs_To_Declarations
11369 (Pkg_Spec
, Decls
, Stmts
);
11371 end Specific_Add_Receiving_Stubs_To_Declarations
;
11373 ------------------------------------------
11374 -- Specific_Build_General_Calling_Stubs --
11375 ------------------------------------------
11377 procedure Specific_Build_General_Calling_Stubs
11379 Statements
: List_Id
;
11380 Target
: RPC_Target
;
11381 Subprogram_Id
: Node_Id
;
11382 Asynchronous
: Node_Id
:= Empty
;
11383 Is_Known_Asynchronous
: Boolean := False;
11384 Is_Known_Non_Asynchronous
: Boolean := False;
11385 Is_Function
: Boolean;
11387 Stub_Type
: Entity_Id
:= Empty
;
11388 RACW_Type
: Entity_Id
:= Empty
;
11392 case Get_PCS_Name
is
11393 when Name_PolyORB_DSA
=>
11394 PolyORB_Support
.Build_General_Calling_Stubs
11400 Is_Known_Asynchronous
,
11401 Is_Known_Non_Asynchronous
,
11409 GARLIC_Support
.Build_General_Calling_Stubs
11413 Target
.RPC_Receiver
,
11416 Is_Known_Asynchronous
,
11417 Is_Known_Non_Asynchronous
,
11424 end Specific_Build_General_Calling_Stubs
;
11426 --------------------------------------
11427 -- Specific_Build_RPC_Receiver_Body --
11428 --------------------------------------
11430 procedure Specific_Build_RPC_Receiver_Body
11431 (RPC_Receiver
: Entity_Id
;
11432 Request
: out Entity_Id
;
11433 Subp_Id
: out Entity_Id
;
11434 Subp_Index
: out Entity_Id
;
11435 Stmts
: out List_Id
;
11436 Decl
: out Node_Id
)
11439 case Get_PCS_Name
is
11440 when Name_PolyORB_DSA
=>
11441 PolyORB_Support
.Build_RPC_Receiver_Body
11450 GARLIC_Support
.Build_RPC_Receiver_Body
11458 end Specific_Build_RPC_Receiver_Body
;
11460 --------------------------------
11461 -- Specific_Build_Stub_Target --
11462 --------------------------------
11464 function Specific_Build_Stub_Target
11467 RCI_Locator
: Entity_Id
;
11468 Controlling_Parameter
: Entity_Id
) return RPC_Target
11471 case Get_PCS_Name
is
11472 when Name_PolyORB_DSA
=>
11473 return PolyORB_Support
.Build_Stub_Target
(Loc
,
11474 Decls
, RCI_Locator
, Controlling_Parameter
);
11477 return GARLIC_Support
.Build_Stub_Target
(Loc
,
11478 Decls
, RCI_Locator
, Controlling_Parameter
);
11480 end Specific_Build_Stub_Target
;
11482 ------------------------------
11483 -- Specific_Build_Stub_Type --
11484 ------------------------------
11486 procedure Specific_Build_Stub_Type
11487 (RACW_Type
: Entity_Id
;
11488 Stub_Type
: Entity_Id
;
11489 Stub_Type_Decl
: out Node_Id
;
11490 RPC_Receiver_Decl
: out Node_Id
)
11493 case Get_PCS_Name
is
11494 when Name_PolyORB_DSA
=>
11495 PolyORB_Support
.Build_Stub_Type
(
11496 RACW_Type
, Stub_Type
,
11497 Stub_Type_Decl
, RPC_Receiver_Decl
);
11500 GARLIC_Support
.Build_Stub_Type
(
11501 RACW_Type
, Stub_Type
,
11502 Stub_Type_Decl
, RPC_Receiver_Decl
);
11504 end Specific_Build_Stub_Type
;
11506 function Specific_Build_Subprogram_Receiving_Stubs
11507 (Vis_Decl
: Node_Id
;
11508 Asynchronous
: Boolean;
11509 Dynamically_Asynchronous
: Boolean := False;
11510 Stub_Type
: Entity_Id
:= Empty
;
11511 RACW_Type
: Entity_Id
:= Empty
;
11512 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
11515 case Get_PCS_Name
is
11516 when Name_PolyORB_DSA
=>
11517 return PolyORB_Support
.Build_Subprogram_Receiving_Stubs
11520 Dynamically_Asynchronous
,
11526 return GARLIC_Support
.Build_Subprogram_Receiving_Stubs
11529 Dynamically_Asynchronous
,
11534 end Specific_Build_Subprogram_Receiving_Stubs
;
11536 -------------------------------
11537 -- Transmit_As_Unconstrained --
11538 -------------------------------
11540 function Transmit_As_Unconstrained
(Typ
: Entity_Id
) return Boolean is
11543 not (Is_Elementary_Type
(Typ
) or else Is_Constrained
(Typ
))
11544 or else (Is_Access_Type
(Typ
) and then Can_Never_Be_Null
(Typ
));
11545 end Transmit_As_Unconstrained
;
11547 --------------------------
11548 -- Underlying_RACW_Type --
11549 --------------------------
11551 function Underlying_RACW_Type
(RAS_Typ
: Entity_Id
) return Entity_Id
is
11552 Record_Type
: Entity_Id
;
11555 if Ekind
(RAS_Typ
) = E_Record_Type
then
11556 Record_Type
:= RAS_Typ
;
11558 pragma Assert
(Present
(Equivalent_Type
(RAS_Typ
)));
11559 Record_Type
:= Equivalent_Type
(RAS_Typ
);
11563 Etype
(Subtype_Indication
11564 (Component_Definition
11565 (First
(Component_Items
11568 (Declaration_Node
(Record_Type
))))))));
11569 end Underlying_RACW_Type
;