1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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_Cat
; use Sem_Cat
;
40 with Sem_Ch3
; use Sem_Ch3
;
41 with Sem_Ch8
; use Sem_Ch8
;
42 with Sem_Dist
; use Sem_Dist
;
43 with Sem_Eval
; use Sem_Eval
;
44 with Sem_Util
; use Sem_Util
;
45 with Sinfo
; use Sinfo
;
46 with Stand
; use Stand
;
47 with Stringt
; use Stringt
;
48 with Tbuild
; use Tbuild
;
49 with Ttypes
; use Ttypes
;
50 with Uintp
; use Uintp
;
52 with GNAT
.HTable
; use GNAT
.HTable
;
54 package body Exp_Dist
is
56 -- The following model has been used to implement distributed objects:
57 -- given a designated type D and a RACW type R, then a record of the
60 -- type Stub is tagged record
61 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
64 -- is built. This type has two properties:
66 -- 1) Since it has the same structure than RACW_Stub_Type, it can be
67 -- converted to and from this type to make it suitable for
68 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
69 -- to avoid memory leaks when the same remote object arrive on the
70 -- same partition through several paths;
72 -- 2) It also has the same dispatching table as the designated type D,
73 -- and thus can be used as an object designated by a value of type
74 -- R on any partition other than the one on which the object has
75 -- been created, since only dispatching calls will be performed and
76 -- the fields themselves will not be used. We call Derive_Subprograms
77 -- to fake half a derivation to ensure that the subprograms do have
78 -- the same dispatching table.
80 First_RCI_Subprogram_Id
: constant := 2;
81 -- RCI subprograms are numbered starting at 2. The RCI receiver for
82 -- an RCI package can thus identify calls received through remote
83 -- access-to-subprogram dereferences by the fact that they have a
84 -- (primitive) subprogram id of 0, and 1 is used for the internal
85 -- RAS information lookup operation. (This is for the Garlic code
86 -- generation, where subprograms are identified by numbers; in the
87 -- PolyORB version, they are identified by name, with a numeric suffix
90 type Hash_Index
is range 0 .. 50;
92 -----------------------
93 -- Local subprograms --
94 -----------------------
96 function Hash
(F
: Entity_Id
) return Hash_Index
;
97 -- DSA expansion associates stubs to distributed object types using
98 -- a hash table on entity ids.
100 function Hash
(F
: Name_Id
) return Hash_Index
;
101 -- The generation of subprogram identifiers requires an overload counter
102 -- to be associated with each remote subprogram names. These counters
103 -- are maintained in a hash table on name ids.
105 type Subprogram_Identifiers
is record
106 Str_Identifier
: String_Id
;
107 Int_Identifier
: Int
;
110 package Subprogram_Identifier_Table
is
111 new Simple_HTable
(Header_Num
=> Hash_Index
,
112 Element
=> Subprogram_Identifiers
,
113 No_Element
=> (No_String
, 0),
117 -- Mapping between a remote subprogram and the corresponding
118 -- subprogram identifiers.
120 package Overload_Counter_Table
is
121 new Simple_HTable
(Header_Num
=> Hash_Index
,
127 -- Mapping between a subprogram name and an integer that
128 -- counts the number of defining subprogram names with that
129 -- Name_Id encountered so far in a given context (an interface).
131 function Get_Subprogram_Ids
(Def
: Entity_Id
) return Subprogram_Identifiers
;
132 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
;
133 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
;
134 -- Given a subprogram defined in a RCI package, get its distribution
135 -- subprogram identifiers (the distribution identifiers are a unique
136 -- subprogram number, and the non-qualified subprogram name, in the
137 -- casing used for the subprogram declaration; if the name is overloaded,
138 -- a double underscore and a serial number are appended.
140 -- The integer identifier is used to perform remote calls with GARLIC;
141 -- the string identifier is used in the case of PolyORB.
143 -- Although the PolyORB DSA receiving stubs will make a caseless comparison
144 -- when receiving a call, the calling stubs will create requests with the
145 -- exact casing of the defining unit name of the called subprogram, so as
146 -- to allow calls to subprograms on distributed nodes that do distinguish
149 -- NOTE: Another design would be to allow a representation clause on
150 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
152 pragma Warnings
(Off
, Get_Subprogram_Id
);
153 -- One homonym only is unreferenced (specific to the GARLIC version)
155 procedure Add_RAS_Dereference_TSS
(N
: Node_Id
);
156 -- Add a subprogram body for RAS Dereference TSS
158 procedure Add_RAS_Proxy_And_Analyze
161 All_Calls_Remote_E
: Entity_Id
;
162 Proxy_Object_Addr
: out Entity_Id
);
163 -- Add the proxy type required, on the receiving (server) side, to handle
164 -- calls to the subprogram declared by Vis_Decl through a remote access
165 -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma
166 -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type
167 -- is appended to Decls. Proxy_Object_Addr is a constant of type
168 -- System.Address that designates an instance of the proxy object.
170 function Build_Remote_Subprogram_Proxy_Type
172 ACR_Expression
: Node_Id
) return Node_Id
;
173 -- Build and return a tagged record type definition for an RCI
174 -- subprogram proxy type.
175 -- ACR_Expression is use as the initialization value for
176 -- the All_Calls_Remote component.
178 function Build_Get_Unique_RP_Call
181 Stub_Type
: Entity_Id
) return List_Id
;
182 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
183 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
184 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
186 function Build_Stub_Tag
188 RACW_Type
: Entity_Id
) return Node_Id
;
189 -- Return an expression denoting the tag of the stub type associated with
192 function Build_Subprogram_Calling_Stubs
195 Asynchronous
: Boolean;
196 Dynamically_Asynchronous
: Boolean := False;
197 Stub_Type
: Entity_Id
:= Empty
;
198 RACW_Type
: Entity_Id
:= Empty
;
199 Locator
: Entity_Id
:= Empty
;
200 New_Name
: Name_Id
:= No_Name
) return Node_Id
;
201 -- Build the calling stub for a given subprogram with the subprogram ID
202 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
203 -- parameters of this type will be marshalled instead of the object
204 -- itself. It will then be converted into Stub_Type before performing
205 -- the real call. If Dynamically_Asynchronous is True, then it will be
206 -- computed at run time whether the call is asynchronous or not.
207 -- Otherwise, the value of the formal Asynchronous will be used.
208 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
209 -- New_Name is given, then it will be used instead of the original name.
211 function Build_RPC_Receiver_Specification
212 (RPC_Receiver
: Entity_Id
;
213 Request_Parameter
: Entity_Id
) return Node_Id
;
214 -- Make a subprogram specification for an RPC receiver, with the given
215 -- defining unit name and formal parameter.
217 function Build_Ordered_Parameters_List
(Spec
: Node_Id
) return List_Id
;
218 -- Return an ordered parameter list: unconstrained parameters are put
219 -- at the beginning of the list and constrained ones are put after. If
220 -- there are no parameters, an empty list is returned. Special case:
221 -- the controlling formal of the equivalent RACW operation for a RAS
222 -- type is always left in first position.
224 function Transmit_As_Unconstrained
(Typ
: Entity_Id
) return Boolean;
225 -- True when Typ is an unconstrained type, or a null-excluding access type.
226 -- In either case, this means stubs cannot contain a default-initialized
227 -- object declaration of such type.
229 procedure Add_Calling_Stubs_To_Declarations
232 -- Add calling stubs to the declarative part
234 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean;
235 -- Return True if nothing prevents the program whose specification is
236 -- given to be asynchronous (i.e. no out parameter).
238 function Pack_Entity_Into_Stream_Access
242 Etyp
: Entity_Id
:= Empty
) return Node_Id
;
243 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
244 -- then Etype (Object) will be used if present. If the type is
245 -- constrained, then 'Write will be used to output the object,
246 -- If the type is unconstrained, 'Output will be used.
248 function Pack_Node_Into_Stream
252 Etyp
: Entity_Id
) return Node_Id
;
253 -- Similar to above, with an arbitrary node instead of an entity
255 function Pack_Node_Into_Stream_Access
259 Etyp
: Entity_Id
) return Node_Id
;
260 -- Similar to above, with Stream instead of Stream'Access
262 function Make_Selected_Component
265 Selector_Name
: Name_Id
) return Node_Id
;
266 -- Return a selected_component whose prefix denotes the given entity,
267 -- and with the given Selector_Name.
269 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
;
270 -- Return the scope represented by a given spec
272 procedure Set_Renaming_TSS
275 TSS_Nam
: TSS_Name_Type
);
276 -- Create a renaming declaration of subprogram Nam,
277 -- and register it as a TSS for Typ with name TSS_Nam.
279 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean;
280 -- Return True if the current parameter needs an extra formal to reflect
281 -- its constrained status.
283 function Is_RACW_Controlling_Formal
284 (Parameter
: Node_Id
;
285 Stub_Type
: Entity_Id
) return Boolean;
286 -- Return True if the current parameter is a controlling formal argument
287 -- of type Stub_Type or access to Stub_Type.
289 procedure Declare_Create_NVList
294 -- Append the declaration of NVList to Decls, and its
295 -- initialization to Stmts.
297 function Add_Parameter_To_NVList
300 Parameter
: Entity_Id
;
301 Constrained
: Boolean;
302 RACW_Ctrl
: Boolean := False;
303 Any
: Entity_Id
) return Node_Id
;
304 -- Return a call to Add_Item to add the Any corresponding to the designated
305 -- formal Parameter (with the indicated Constrained status) to NVList.
306 -- RACW_Ctrl must be set to True for controlling formals of distributed
307 -- object primitive operations.
313 -- This record describes various tree fragments associated with the
314 -- generation of RACW calling stubs. One such record exists for every
315 -- distributed object type, i.e. each tagged type that is the designated
316 -- type of one or more RACW type.
318 type Stub_Structure
is record
319 Stub_Type
: Entity_Id
;
320 -- Stub type: this type has the same primitive operations as the
321 -- designated types, but the provided bodies for these operations
322 -- a remote call to an actual target object potentially located on
323 -- another partition; each value of the stub type encapsulates a
324 -- reference to a remote object.
326 Stub_Type_Access
: Entity_Id
;
327 -- A local access type designating the stub type (this is not an RACW
330 RPC_Receiver_Decl
: Node_Id
;
331 -- Declaration for the RPC receiver entity associated with the
332 -- designated type. As an exception, for the case of an RACW that
333 -- implements a RAS, no object RPC receiver is generated. Instead,
334 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
335 -- would have been inserted.
337 Body_Decls
: List_Id
;
338 -- List of subprogram bodies to be included in generated code: bodies
339 -- for the RACW's stream attributes, and for the primitive operations
342 RACW_Type
: Entity_Id
;
343 -- One of the RACW types designating this distributed object type
344 -- (they are all interchangeable; we use any one of them in order to
345 -- avoid having to create various anonymous access types).
349 Empty_Stub_Structure
: constant Stub_Structure
:=
350 (Empty
, Empty
, Empty
, No_List
, Empty
);
352 package Stubs_Table
is
353 new Simple_HTable
(Header_Num
=> Hash_Index
,
354 Element
=> Stub_Structure
,
355 No_Element
=> Empty_Stub_Structure
,
359 -- Mapping between a RACW designated type and its stub type
361 package Asynchronous_Flags_Table
is
362 new Simple_HTable
(Header_Num
=> Hash_Index
,
363 Element
=> Entity_Id
,
368 -- Mapping between a RACW type and a constant having the value True
369 -- if the RACW is asynchronous and False otherwise.
371 package RCI_Locator_Table
is
372 new Simple_HTable
(Header_Num
=> Hash_Index
,
373 Element
=> Entity_Id
,
378 -- Mapping between a RCI package on which All_Calls_Remote applies and
379 -- the generic instantiation of RCI_Locator for this package.
381 package RCI_Calling_Stubs_Table
is
382 new Simple_HTable
(Header_Num
=> Hash_Index
,
383 Element
=> Entity_Id
,
388 -- Mapping between a RCI subprogram and the corresponding calling stubs
390 function Get_Stub_Elements
(RACW_Type
: Entity_Id
) return Stub_Structure
;
391 -- Return the stub information associated with the given RACW type
393 procedure Add_Stub_Type
394 (Designated_Type
: Entity_Id
;
395 RACW_Type
: Entity_Id
;
397 Stub_Type
: out Entity_Id
;
398 Stub_Type_Access
: out Entity_Id
;
399 RPC_Receiver_Decl
: out Node_Id
;
400 Body_Decls
: out List_Id
;
401 Existing
: out Boolean);
402 -- Add the declaration of the stub type, the access to stub type and the
403 -- object RPC receiver at the end of Decls. If these already exist,
404 -- then nothing is added in the tree but the right values are returned
405 -- anyhow and Existing is set to True.
407 function Get_And_Reset_RACW_Bodies
(RACW_Type
: Entity_Id
) return List_Id
;
408 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
409 -- structure table, reset it to No_List, and return the previous value.
411 procedure Add_RACW_Asynchronous_Flag
412 (Declarations
: List_Id
;
413 RACW_Type
: Entity_Id
);
414 -- Declare a boolean constant associated with RACW_Type whose value
415 -- indicates at run time whether a pragma Asynchronous applies to it.
417 procedure Assign_Subprogram_Identifier
421 -- Determine the distribution subprogram identifier to
422 -- be used for remote subprogram Def, return it in Id and
423 -- store it in a hash table for later retrieval by
424 -- Get_Subprogram_Id. Spn is the subprogram number.
426 function RCI_Package_Locator
428 Package_Spec
: Node_Id
) return Node_Id
;
429 -- Instantiate the generic package RCI_Locator in order to locate the
430 -- RCI package whose spec is given as argument.
432 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
;
433 -- Surround a node N by a tag check, as in:
437 -- when E : Ada.Tags.Tag_Error =>
438 -- Raise_Exception (Program_Error'Identity,
439 -- Exception_Message (E));
442 function Input_With_Tag_Check
444 Var_Type
: Entity_Id
;
445 Stream
: Node_Id
) return Node_Id
;
446 -- Return a function with the following form:
447 -- function R return Var_Type is
449 -- return Var_Type'Input (S);
451 -- when E : Ada.Tags.Tag_Error =>
452 -- Raise_Exception (Program_Error'Identity,
453 -- Exception_Message (E));
456 procedure Build_Actual_Object_Declaration
462 -- Build the declaration of an object with the given defining identifier,
463 -- initialized with Expr if provided, to serve as actual parameter in a
464 -- server stub. If Variable is true, the declared object will be a variable
465 -- (case of an out or in out formal), else it will be a constant. Object's
466 -- Ekind is set accordingly. The declaration, as well as any other
467 -- declarations it requires, are appended to Decls.
469 --------------------------------------------
470 -- Hooks for PCS-specific code generation --
471 --------------------------------------------
473 -- Part of the code generation circuitry for distribution needs to be
474 -- tailored for each implementation of the PCS. For each routine that
475 -- needs to be specialized, a Specific_<routine> wrapper is created,
476 -- which calls the corresponding <routine> in package
477 -- <pcs_implementation>_Support.
479 procedure Specific_Add_RACW_Features
480 (RACW_Type
: Entity_Id
;
482 Stub_Type
: Entity_Id
;
483 Stub_Type_Access
: Entity_Id
;
484 RPC_Receiver_Decl
: Node_Id
;
485 Body_Decls
: List_Id
);
486 -- Add declaration for TSSs for a given RACW type. The declarations are
487 -- added just after the declaration of the RACW type itself. If the RACW
488 -- appears in the main unit, Body_Decls is a list of declarations to which
489 -- the bodies are appended. Else Body_Decls is No_List.
490 -- PCS-specific ancillary subprogram for Add_RACW_Features.
492 procedure Specific_Add_RAST_Features
494 RAS_Type
: Entity_Id
);
495 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
496 -- subprogram for Add_RAST_Features.
498 -- An RPC_Target record is used during construction of calling stubs
499 -- to pass PCS-specific tree fragments corresponding to the information
500 -- necessary to locate the target of a remote subprogram call.
502 type RPC_Target
(PCS_Kind
: PCS_Names
) is record
504 when Name_PolyORB_DSA
=>
506 -- An expression whose value is a PolyORB reference to the target
510 Partition
: Entity_Id
;
511 -- A variable containing the Partition_ID of the target partition
513 RPC_Receiver
: Node_Id
;
514 -- An expression whose value is the address of the target RPC
519 procedure Specific_Build_General_Calling_Stubs
521 Statements
: List_Id
;
523 Subprogram_Id
: Node_Id
;
524 Asynchronous
: Node_Id
:= Empty
;
525 Is_Known_Asynchronous
: Boolean := False;
526 Is_Known_Non_Asynchronous
: Boolean := False;
527 Is_Function
: Boolean;
529 Stub_Type
: Entity_Id
:= Empty
;
530 RACW_Type
: Entity_Id
:= Empty
;
532 -- Build calling stubs for general purpose. The parameters are:
533 -- Decls : a place to put declarations
534 -- Statements : a place to put statements
535 -- Target : PCS-specific target information (see details
536 -- in RPC_Target declaration).
537 -- Subprogram_Id : a node containing the subprogram ID
538 -- Asynchronous : True if an APC must be made instead of an RPC.
539 -- The value needs not be supplied if one of the
540 -- Is_Known_... is True.
541 -- Is_Known_Async... : True if we know that this is asynchronous
542 -- Is_Known_Non_A... : True if we know that this is not asynchronous
543 -- Spec : a node with a Parameter_Specifications and
544 -- a Result_Definition if applicable
545 -- Stub_Type : in case of RACW stubs, parameters of type access
546 -- to Stub_Type will be marshalled using the
547 -- address of the object (the addr field) rather
548 -- than using the 'Write on the stub itself
549 -- Nod : used to provide sloc for generated code
551 function Specific_Build_Stub_Target
554 RCI_Locator
: Entity_Id
;
555 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
556 -- Build call target information nodes for use within calling stubs. In the
557 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
558 -- for an RACW, Controlling_Parameter is the entity for the controlling
559 -- formal parameter used to determine the location of the target of the
560 -- call. Decls provides a location where variable declarations can be
561 -- appended to construct the necessary values.
563 procedure Specific_Build_Stub_Type
564 (RACW_Type
: Entity_Id
;
565 Stub_Type
: Entity_Id
;
566 Stub_Type_Decl
: out Node_Id
;
567 RPC_Receiver_Decl
: out Node_Id
);
568 -- Build a type declaration for the stub type associated with an RACW
569 -- type, and the necessary RPC receiver, if applicable. PCS-specific
570 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
571 -- is generated, then RPC_Receiver_Decl is set to Empty.
573 procedure Specific_Build_RPC_Receiver_Body
574 (RPC_Receiver
: Entity_Id
;
575 Request
: out Entity_Id
;
576 Subp_Id
: out Entity_Id
;
577 Subp_Index
: out Entity_Id
;
580 -- Make a subprogram body for an RPC receiver, with the given
581 -- defining unit name. On return:
582 -- - Subp_Id is the subprogram identifier from the PCS.
583 -- - Subp_Index is the index in the list of subprograms
584 -- used for dispatching (a variable of type Subprogram_Id).
585 -- - Stmts is the place where the request dispatching
586 -- statements can occur,
587 -- - Decl is the subprogram body declaration.
589 function Specific_Build_Subprogram_Receiving_Stubs
591 Asynchronous
: Boolean;
592 Dynamically_Asynchronous
: Boolean := False;
593 Stub_Type
: Entity_Id
:= Empty
;
594 RACW_Type
: Entity_Id
:= Empty
;
595 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
596 -- Build the receiving stub for a given subprogram. The subprogram
597 -- declaration is also built by this procedure, and the value returned
598 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
599 -- found in the specification, then its address is read from the stream
600 -- instead of the object itself and converted into an access to
601 -- class-wide type before doing the real call using any of the RACW type
602 -- pointing on the designated type.
604 procedure Specific_Add_Obj_RPC_Receiver_Completion
607 RPC_Receiver
: Entity_Id
;
608 Stub_Elements
: Stub_Structure
);
609 -- Add the necessary code to Decls after the completion of generation
610 -- of the RACW RPC receiver described by Stub_Elements.
612 procedure Specific_Add_Receiving_Stubs_To_Declarations
616 -- Add receiving stubs to the declarative part of an RCI unit
618 package GARLIC_Support
is
620 -- Support for generating DSA code that uses the GARLIC PCS
622 -- The subprograms below provide the GARLIC versions of the
623 -- corresponding Specific_<subprogram> routine declared above.
625 procedure Add_RACW_Features
626 (RACW_Type
: Entity_Id
;
627 Stub_Type
: Entity_Id
;
628 Stub_Type_Access
: Entity_Id
;
629 RPC_Receiver_Decl
: Node_Id
;
630 Body_Decls
: List_Id
);
632 procedure Add_RAST_Features
634 RAS_Type
: Entity_Id
);
636 procedure Build_General_Calling_Stubs
638 Statements
: List_Id
;
639 Target_Partition
: Entity_Id
; -- From RPC_Target
640 Target_RPC_Receiver
: Node_Id
; -- From RPC_Target
641 Subprogram_Id
: Node_Id
;
642 Asynchronous
: Node_Id
:= Empty
;
643 Is_Known_Asynchronous
: Boolean := False;
644 Is_Known_Non_Asynchronous
: Boolean := False;
645 Is_Function
: Boolean;
647 Stub_Type
: Entity_Id
:= Empty
;
648 RACW_Type
: Entity_Id
:= Empty
;
651 function Build_Stub_Target
654 RCI_Locator
: Entity_Id
;
655 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
657 procedure Build_Stub_Type
658 (RACW_Type
: Entity_Id
;
659 Stub_Type
: Entity_Id
;
660 Stub_Type_Decl
: out Node_Id
;
661 RPC_Receiver_Decl
: out Node_Id
);
663 function Build_Subprogram_Receiving_Stubs
665 Asynchronous
: Boolean;
666 Dynamically_Asynchronous
: Boolean := False;
667 Stub_Type
: Entity_Id
:= Empty
;
668 RACW_Type
: Entity_Id
:= Empty
;
669 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
671 procedure Add_Obj_RPC_Receiver_Completion
674 RPC_Receiver
: Entity_Id
;
675 Stub_Elements
: Stub_Structure
);
677 procedure Add_Receiving_Stubs_To_Declarations
682 procedure Build_RPC_Receiver_Body
683 (RPC_Receiver
: Entity_Id
;
684 Request
: out Entity_Id
;
685 Subp_Id
: out Entity_Id
;
686 Subp_Index
: out Entity_Id
;
692 package PolyORB_Support
is
694 -- Support for generating DSA code that uses the PolyORB PCS
696 -- The subprograms below provide the PolyORB versions of the
697 -- corresponding Specific_<subprogram> routine declared above.
699 procedure Add_RACW_Features
700 (RACW_Type
: Entity_Id
;
702 Stub_Type
: Entity_Id
;
703 Stub_Type_Access
: Entity_Id
;
704 RPC_Receiver_Decl
: Node_Id
;
705 Body_Decls
: List_Id
);
707 procedure Add_RAST_Features
709 RAS_Type
: Entity_Id
);
711 procedure Build_General_Calling_Stubs
713 Statements
: List_Id
;
714 Target_Object
: Node_Id
; -- From RPC_Target
715 Subprogram_Id
: Node_Id
;
716 Asynchronous
: Node_Id
:= Empty
;
717 Is_Known_Asynchronous
: Boolean := False;
718 Is_Known_Non_Asynchronous
: Boolean := False;
719 Is_Function
: Boolean;
721 Stub_Type
: Entity_Id
:= Empty
;
722 RACW_Type
: Entity_Id
:= Empty
;
725 function Build_Stub_Target
728 RCI_Locator
: Entity_Id
;
729 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
731 procedure Build_Stub_Type
732 (RACW_Type
: Entity_Id
;
733 Stub_Type
: Entity_Id
;
734 Stub_Type_Decl
: out Node_Id
;
735 RPC_Receiver_Decl
: out Node_Id
);
737 function Build_Subprogram_Receiving_Stubs
739 Asynchronous
: Boolean;
740 Dynamically_Asynchronous
: Boolean := False;
741 Stub_Type
: Entity_Id
:= Empty
;
742 RACW_Type
: Entity_Id
:= Empty
;
743 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
745 procedure Add_Obj_RPC_Receiver_Completion
748 RPC_Receiver
: Entity_Id
;
749 Stub_Elements
: Stub_Structure
);
751 procedure Add_Receiving_Stubs_To_Declarations
756 procedure Build_RPC_Receiver_Body
757 (RPC_Receiver
: Entity_Id
;
758 Request
: out Entity_Id
;
759 Subp_Id
: out Entity_Id
;
760 Subp_Index
: out Entity_Id
;
764 procedure Reserve_NamingContext_Methods
;
765 -- Mark the method names for interface NamingContext as already used in
766 -- the overload table, so no clashes occur with user code (with the
767 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
768 -- their methods to be accessed as objects, for the implementation of
769 -- remote access-to-subprogram types).
773 -- Routines to build distribution helper subprograms for user-defined
774 -- types. For implementation of the Distributed systems annex (DSA)
775 -- over the PolyORB generic middleware components, it is necessary to
776 -- generate several supporting subprograms for each application data
777 -- type used in inter-partition communication. These subprograms are:
779 -- A Typecode function returning a high-level description of the
782 -- Two conversion functions allowing conversion of values of the
783 -- type from and to the generic data containers used by PolyORB.
784 -- These generic containers are called 'Any' type values after the
785 -- CORBA terminology, and hence the conversion subprograms are
786 -- named To_Any and From_Any.
788 function Build_From_Any_Call
791 Decls
: List_Id
) return Node_Id
;
792 -- Build call to From_Any attribute function of type Typ with
793 -- expression N as actual parameter. Decls is the declarations list
794 -- for an appropriate enclosing scope of the point where the call
795 -- will be inserted; if the From_Any attribute for Typ needs to be
796 -- generated at this point, its declaration is appended to Decls.
798 procedure Build_From_Any_Function
802 Fnam
: out Entity_Id
);
803 -- Build From_Any attribute function for Typ. Loc is the reference
804 -- location for generated nodes, Typ is the type for which the
805 -- conversion function is generated. On return, Decl and Fnam contain
806 -- the declaration and entity for the newly-created function.
808 function Build_To_Any_Call
810 Decls
: List_Id
) return Node_Id
;
811 -- Build call to To_Any attribute function with expression as actual
812 -- parameter. Decls is the declarations list for an appropriate
813 -- enclosing scope of the point where the call will be inserted; if
814 -- the To_Any attribute for Typ needs to be generated at this point,
815 -- its declaration is appended to Decls.
817 procedure Build_To_Any_Function
821 Fnam
: out Entity_Id
);
822 -- Build To_Any attribute function for Typ. Loc is the reference
823 -- location for generated nodes, Typ is the type for which the
824 -- conversion function is generated. On return, Decl and Fnam contain
825 -- the declaration and entity for the newly-created function.
827 function Build_TypeCode_Call
830 Decls
: List_Id
) return Node_Id
;
831 -- Build call to TypeCode attribute function for Typ. Decls is the
832 -- declarations list for an appropriate enclosing scope of the point
833 -- where the call will be inserted; if the To_Any attribute for Typ
834 -- needs to be generated at this point, its declaration is appended
837 procedure Build_TypeCode_Function
841 Fnam
: out Entity_Id
);
842 -- Build TypeCode attribute function for Typ. Loc is the reference
843 -- location for generated nodes, Typ is the type for which the
844 -- conversion function is generated. On return, Decl and Fnam contain
845 -- the declaration and entity for the newly-created function.
847 procedure Build_Name_And_Repository_Id
849 Name_Str
: out String_Id
;
850 Repo_Id_Str
: out String_Id
);
851 -- In the PolyORB distribution model, each distributed object type
852 -- and each distributed operation has a globally unique identifier,
853 -- its Repository Id. This subprogram builds and returns two strings
854 -- for entity E (a distributed object type or operation): one
855 -- containing the name of E, the second containing its repository id.
861 -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
863 function Build_From_Any_Call
866 Decls
: List_Id
) return Node_Id
867 renames PolyORB_Support
.Helpers
.Build_From_Any_Call
;
869 function Build_To_Any_Call
871 Decls
: List_Id
) return Node_Id
872 renames PolyORB_Support
.Helpers
.Build_To_Any_Call
;
874 function Build_TypeCode_Call
877 Decls
: List_Id
) return Node_Id
878 renames PolyORB_Support
.Helpers
.Build_TypeCode_Call
;
880 ------------------------------------
881 -- Local variables and structures --
882 ------------------------------------
885 -- Needs comments ???
887 Output_From_Constrained
: constant array (Boolean) of Name_Id
:=
888 (False => Name_Output
,
890 -- The attribute to choose depending on the fact that the parameter
891 -- is constrained or not. There is no such thing as Input_From_Constrained
892 -- since this require separate mechanisms ('Input is a function while
893 -- 'Read is a procedure).
895 ---------------------------------------
896 -- Add_Calling_Stubs_To_Declarations --
897 ---------------------------------------
899 procedure Add_Calling_Stubs_To_Declarations
903 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
904 -- Subprogram id 0 is reserved for calls received from
905 -- remote access-to-subprogram dereferences.
907 Current_Declaration
: Node_Id
;
908 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
909 RCI_Instantiation
: Node_Id
;
910 Subp_Stubs
: Node_Id
;
911 Subp_Str
: String_Id
;
913 pragma Warnings
(Off
, Subp_Str
);
916 -- The first thing added is an instantiation of the generic package
917 -- System.Partition_Interface.RCI_Locator with the name of this remote
918 -- package. This will act as an interface with the name server to
919 -- determine the Partition_ID and the RPC_Receiver for the receiver
922 RCI_Instantiation
:= RCI_Package_Locator
(Loc
, Pkg_Spec
);
923 RCI_Cache
:= Defining_Unit_Name
(RCI_Instantiation
);
925 Append_To
(Decls
, RCI_Instantiation
);
926 Analyze
(RCI_Instantiation
);
928 -- For each subprogram declaration visible in the spec, we do build a
929 -- body. We also increment a counter to assign a different Subprogram_Id
930 -- to each subprograms. The receiving stubs processing do use the same
931 -- mechanism and will thus assign the same Id and do the correct
934 Overload_Counter_Table
.Reset
;
935 PolyORB_Support
.Reserve_NamingContext_Methods
;
937 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
938 while Present
(Current_Declaration
) loop
939 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
940 and then Comes_From_Source
(Current_Declaration
)
942 Assign_Subprogram_Identifier
943 (Defining_Unit_Name
(Specification
(Current_Declaration
)),
944 Current_Subprogram_Number
,
948 Build_Subprogram_Calling_Stubs
(
949 Vis_Decl
=> Current_Declaration
,
951 Build_Subprogram_Id
(Loc
,
952 Defining_Unit_Name
(Specification
(Current_Declaration
))),
954 Nkind
(Specification
(Current_Declaration
)) =
955 N_Procedure_Specification
957 Is_Asynchronous
(Defining_Unit_Name
(Specification
958 (Current_Declaration
))));
960 Append_To
(Decls
, Subp_Stubs
);
961 Analyze
(Subp_Stubs
);
963 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
966 Next
(Current_Declaration
);
968 end Add_Calling_Stubs_To_Declarations
;
970 -----------------------------
971 -- Add_Parameter_To_NVList --
972 -----------------------------
974 function Add_Parameter_To_NVList
977 Parameter
: Entity_Id
;
978 Constrained
: Boolean;
979 RACW_Ctrl
: Boolean := False;
980 Any
: Entity_Id
) return Node_Id
982 Parameter_Name_String
: String_Id
;
983 Parameter_Mode
: Node_Id
;
985 function Parameter_Passing_Mode
987 Parameter
: Entity_Id
;
988 Constrained
: Boolean) return Node_Id
;
989 -- Return an expression that denotes the parameter passing mode to be
990 -- used for Parameter in distribution stubs, where Constrained is
991 -- Parameter's constrained status.
993 ----------------------------
994 -- Parameter_Passing_Mode --
995 ----------------------------
997 function Parameter_Passing_Mode
999 Parameter
: Entity_Id
;
1000 Constrained
: Boolean) return Node_Id
1005 if Out_Present
(Parameter
) then
1006 if In_Present
(Parameter
)
1007 or else not Constrained
1009 -- Unconstrained formals must be translated
1010 -- to 'in' or 'inout', not 'out', because
1011 -- they need to be constrained by the actual.
1013 Lib_RE
:= RE_Mode_Inout
;
1015 Lib_RE
:= RE_Mode_Out
;
1019 Lib_RE
:= RE_Mode_In
;
1022 return New_Occurrence_Of
(RTE
(Lib_RE
), Loc
);
1023 end Parameter_Passing_Mode
;
1025 -- Start of processing for Add_Parameter_To_NVList
1028 if Nkind
(Parameter
) = N_Defining_Identifier
then
1029 Get_Name_String
(Chars
(Parameter
));
1031 Get_Name_String
(Chars
(Defining_Identifier
(Parameter
)));
1034 Parameter_Name_String
:= String_From_Name_Buffer
;
1036 if RACW_Ctrl
or else Nkind
(Parameter
) = N_Defining_Identifier
then
1038 -- When the parameter passed to Add_Parameter_To_NVList is an
1039 -- Extra_Constrained parameter, Parameter is an N_Defining_
1040 -- Identifier, instead of a complete N_Parameter_Specification.
1041 -- Thus, we explicitly set 'in' mode in this case.
1043 Parameter_Mode
:= New_Occurrence_Of
(RTE
(RE_Mode_In
), Loc
);
1047 Parameter_Passing_Mode
(Loc
, Parameter
, Constrained
);
1051 Make_Procedure_Call_Statement
(Loc
,
1054 (RTE
(RE_NVList_Add_Item
), Loc
),
1055 Parameter_Associations
=> New_List
(
1056 New_Occurrence_Of
(NVList
, Loc
),
1057 Make_Function_Call
(Loc
,
1060 (RTE
(RE_To_PolyORB_String
), Loc
),
1061 Parameter_Associations
=> New_List
(
1062 Make_String_Literal
(Loc
,
1063 Strval
=> Parameter_Name_String
))),
1064 New_Occurrence_Of
(Any
, Loc
),
1066 end Add_Parameter_To_NVList
;
1068 --------------------------------
1069 -- Add_RACW_Asynchronous_Flag --
1070 --------------------------------
1072 procedure Add_RACW_Asynchronous_Flag
1073 (Declarations
: List_Id
;
1074 RACW_Type
: Entity_Id
)
1076 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1078 Asynchronous_Flag
: constant Entity_Id
:=
1079 Make_Defining_Identifier
(Loc
,
1080 New_External_Name
(Chars
(RACW_Type
), 'A'));
1083 -- Declare the asynchronous flag. This flag will be changed to True
1084 -- whenever it is known that the RACW type is asynchronous.
1086 Append_To
(Declarations
,
1087 Make_Object_Declaration
(Loc
,
1088 Defining_Identifier
=> Asynchronous_Flag
,
1089 Constant_Present
=> True,
1090 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
1091 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
1093 Asynchronous_Flags_Table
.Set
(RACW_Type
, Asynchronous_Flag
);
1094 end Add_RACW_Asynchronous_Flag
;
1096 -----------------------
1097 -- Add_RACW_Features --
1098 -----------------------
1100 procedure Add_RACW_Features
(RACW_Type
: Entity_Id
) is
1101 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
1102 Same_Scope
: constant Boolean := Scope
(Desig
) = Scope
(RACW_Type
);
1106 Body_Decls
: List_Id
;
1108 Stub_Type
: Entity_Id
;
1109 Stub_Type_Access
: Entity_Id
;
1110 RPC_Receiver_Decl
: Node_Id
;
1113 -- True when appropriate stubs have already been generated (this is the
1114 -- case when another RACW with the same designated type has already been
1115 -- encountered), in which case we reuse the previous stubs rather than
1116 -- generating new ones.
1119 if not Expander_Active
then
1123 -- Mark the current package declaration as containing an RACW, so that
1124 -- the bodies for the calling stubs and the RACW stream subprograms
1125 -- are attached to the tree when the corresponding body is encountered.
1127 Set_Has_RACW
(Current_Scope
);
1129 -- Look for place to declare the RACW stub type and RACW operations
1135 -- Case of declaring the RACW in the same package as its designated
1136 -- type: we know that the designated type is a private type, so we
1137 -- use the private declarations list.
1139 Pkg_Spec
:= Package_Specification_Of_Scope
(Current_Scope
);
1141 if Present
(Private_Declarations
(Pkg_Spec
)) then
1142 Decls
:= Private_Declarations
(Pkg_Spec
);
1144 Decls
:= Visible_Declarations
(Pkg_Spec
);
1149 -- Case of declaring the RACW in another package than its designated
1150 -- type: use the private declarations list if present; otherwise
1151 -- use the visible declarations.
1153 Decls
:= List_Containing
(Declaration_Node
(RACW_Type
));
1157 -- If we were unable to find the declarations, that means that the
1158 -- completion of the type was missing. We can safely return and let the
1159 -- error be caught by the semantic analysis.
1166 (Designated_Type
=> Desig
,
1167 RACW_Type
=> RACW_Type
,
1169 Stub_Type
=> Stub_Type
,
1170 Stub_Type_Access
=> Stub_Type_Access
,
1171 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1172 Body_Decls
=> Body_Decls
,
1173 Existing
=> Existing
);
1175 -- If this RACW is not in the main unit, do not generate primitive or
1178 if not Entity_Is_In_Main_Unit
(RACW_Type
) then
1179 Body_Decls
:= No_List
;
1182 Add_RACW_Asynchronous_Flag
1183 (Declarations
=> Decls
,
1184 RACW_Type
=> RACW_Type
);
1186 Specific_Add_RACW_Features
1187 (RACW_Type
=> RACW_Type
,
1189 Stub_Type
=> Stub_Type
,
1190 Stub_Type_Access
=> Stub_Type_Access
,
1191 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1192 Body_Decls
=> Body_Decls
);
1194 -- If we already have stubs for this designated type, nothing to do
1200 if Is_Frozen
(Desig
) then
1201 Validate_RACW_Primitives
(RACW_Type
);
1202 Add_RACW_Primitive_Declarations_And_Bodies
1203 (Designated_Type
=> Desig
,
1204 Insertion_Node
=> RPC_Receiver_Decl
,
1205 Body_Decls
=> Body_Decls
);
1208 -- Validate_RACW_Primitives requires the list of all primitives of
1209 -- the designated type, so defer processing until Desig is frozen.
1210 -- See Exp_Ch3.Freeze_Type.
1212 Add_Access_Type_To_Process
(E
=> Desig
, A
=> RACW_Type
);
1214 end Add_RACW_Features
;
1216 ------------------------------------------------
1217 -- Add_RACW_Primitive_Declarations_And_Bodies --
1218 ------------------------------------------------
1220 procedure Add_RACW_Primitive_Declarations_And_Bodies
1221 (Designated_Type
: Entity_Id
;
1222 Insertion_Node
: Node_Id
;
1223 Body_Decls
: List_Id
)
1225 Loc
: constant Source_Ptr
:= Sloc
(Insertion_Node
);
1226 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1227 -- the declarations are recognized as belonging to the current package.
1229 Stub_Elements
: constant Stub_Structure
:=
1230 Stubs_Table
.Get
(Designated_Type
);
1232 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
1234 Is_RAS
: constant Boolean :=
1235 not Comes_From_Source
(Stub_Elements
.RACW_Type
);
1236 -- Case of the RACW generated to implement a remote access-to-
1239 Build_Bodies
: constant Boolean :=
1240 In_Extended_Main_Code_Unit
(Stub_Elements
.Stub_Type
);
1241 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1242 -- only when the main unit is the unit that contains the stub type.
1244 Current_Insertion_Node
: Node_Id
:= Insertion_Node
;
1246 RPC_Receiver
: Entity_Id
;
1247 RPC_Receiver_Statements
: List_Id
;
1248 RPC_Receiver_Case_Alternatives
: constant List_Id
:= New_List
;
1249 RPC_Receiver_Elsif_Parts
: List_Id
;
1250 RPC_Receiver_Request
: Entity_Id
;
1251 RPC_Receiver_Subp_Id
: Entity_Id
;
1252 RPC_Receiver_Subp_Index
: Entity_Id
;
1254 Subp_Str
: String_Id
;
1256 Current_Primitive_Elmt
: Elmt_Id
;
1257 Current_Primitive
: Entity_Id
;
1258 Current_Primitive_Body
: Node_Id
;
1259 Current_Primitive_Spec
: Node_Id
;
1260 Current_Primitive_Decl
: Node_Id
;
1261 Current_Primitive_Number
: Int
:= 0;
1262 Current_Primitive_Alias
: Node_Id
;
1263 Current_Receiver
: Entity_Id
;
1264 Current_Receiver_Body
: Node_Id
;
1265 RPC_Receiver_Decl
: Node_Id
;
1266 Possibly_Asynchronous
: Boolean;
1269 if not Expander_Active
then
1275 Make_Defining_Identifier
(Loc
,
1276 Chars
=> New_Internal_Name
('P'));
1278 Specific_Build_RPC_Receiver_Body
1279 (RPC_Receiver
=> RPC_Receiver
,
1280 Request
=> RPC_Receiver_Request
,
1281 Subp_Id
=> RPC_Receiver_Subp_Id
,
1282 Subp_Index
=> RPC_Receiver_Subp_Index
,
1283 Stmts
=> RPC_Receiver_Statements
,
1284 Decl
=> RPC_Receiver_Decl
);
1286 if Get_PCS_Name
= Name_PolyORB_DSA
then
1288 -- For the case of PolyORB, we need to map a textual operation
1289 -- name into a primitive index. Currently we do so using a simple
1290 -- sequence of string comparisons.
1292 RPC_Receiver_Elsif_Parts
:= New_List
;
1296 -- Build callers, receivers for every primitive operations and a RPC
1297 -- receiver for this type.
1299 if Present
(Primitive_Operations
(Designated_Type
)) then
1300 Overload_Counter_Table
.Reset
;
1302 Current_Primitive_Elmt
:=
1303 First_Elmt
(Primitive_Operations
(Designated_Type
));
1304 while Current_Primitive_Elmt
/= No_Elmt
loop
1305 Current_Primitive
:= Node
(Current_Primitive_Elmt
);
1307 -- Copy the primitive of all the parents, except predefined ones
1308 -- that are not remotely dispatching. Also omit hidden primitives
1309 -- (occurs in the case of primitives of interface progenitors
1310 -- other than immediate ancestors of the Designated_Type).
1312 if Chars
(Current_Primitive
) /= Name_uSize
1313 and then Chars
(Current_Primitive
) /= Name_uAlignment
1315 (Is_TSS
(Current_Primitive
, TSS_Deep_Finalize
) or else
1316 Is_TSS
(Current_Primitive
, TSS_Stream_Input
) or else
1317 Is_TSS
(Current_Primitive
, TSS_Stream_Output
) or else
1318 Is_TSS
(Current_Primitive
, TSS_Stream_Read
) or else
1319 Is_TSS
(Current_Primitive
, TSS_Stream_Write
))
1320 and then not Is_Hidden
(Current_Primitive
)
1322 -- The first thing to do is build an up-to-date copy of the
1323 -- spec with all the formals referencing Designated_Type
1324 -- transformed into formals referencing Stub_Type. Since this
1325 -- primitive may have been inherited, go back the alias chain
1326 -- until the real primitive has been found.
1328 Current_Primitive_Alias
:= Current_Primitive
;
1329 while Present
(Alias
(Current_Primitive_Alias
)) loop
1331 (Current_Primitive_Alias
1332 /= Alias
(Current_Primitive_Alias
));
1333 Current_Primitive_Alias
:= Alias
(Current_Primitive_Alias
);
1336 -- Copy the spec from the original declaration for the purpose
1337 -- of declaring an overriding subprogram: we need to replace
1338 -- the type of each controlling formal with Stub_Type. The
1339 -- primitive may have been declared for Designated_Type or
1340 -- inherited from some ancestor type for which we do not have
1341 -- an easily determined Entity_Id. We have no systematic way
1342 -- of knowing which type to substitute Stub_Type for. Instead,
1343 -- Copy_Specification relies on the flag Is_Controlling_Formal
1344 -- to determine which formals to change.
1346 Current_Primitive_Spec
:=
1347 Copy_Specification
(Loc
,
1348 Spec
=> Parent
(Current_Primitive_Alias
),
1349 Ctrl_Type
=> Stub_Elements
.Stub_Type
);
1351 Current_Primitive_Decl
:=
1352 Make_Subprogram_Declaration
(Loc
,
1353 Specification
=> Current_Primitive_Spec
);
1355 Insert_After_And_Analyze
(Current_Insertion_Node
,
1356 Current_Primitive_Decl
);
1357 Current_Insertion_Node
:= Current_Primitive_Decl
;
1359 Possibly_Asynchronous
:=
1360 Nkind
(Current_Primitive_Spec
) = N_Procedure_Specification
1361 and then Could_Be_Asynchronous
(Current_Primitive_Spec
);
1363 Assign_Subprogram_Identifier
(
1364 Defining_Unit_Name
(Current_Primitive_Spec
),
1365 Current_Primitive_Number
,
1368 if Build_Bodies
then
1369 Current_Primitive_Body
:=
1370 Build_Subprogram_Calling_Stubs
1371 (Vis_Decl
=> Current_Primitive_Decl
,
1373 Build_Subprogram_Id
(Loc
,
1374 Defining_Unit_Name
(Current_Primitive_Spec
)),
1375 Asynchronous
=> Possibly_Asynchronous
,
1376 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1377 Stub_Type
=> Stub_Elements
.Stub_Type
,
1378 RACW_Type
=> Stub_Elements
.RACW_Type
);
1379 Append_To
(Body_Decls
, Current_Primitive_Body
);
1381 -- Analyzing the body here would cause the Stub type to
1382 -- be frozen, thus preventing subsequent primitive
1383 -- declarations. For this reason, it will be analyzed
1384 -- later in the regular flow (and in the context of the
1385 -- appropriate unit body, see Append_RACW_Bodies).
1389 -- Build the receiver stubs
1391 if Build_Bodies
and then not Is_RAS
then
1392 Current_Receiver_Body
:=
1393 Specific_Build_Subprogram_Receiving_Stubs
1394 (Vis_Decl
=> Current_Primitive_Decl
,
1395 Asynchronous
=> Possibly_Asynchronous
,
1396 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1397 Stub_Type
=> Stub_Elements
.Stub_Type
,
1398 RACW_Type
=> Stub_Elements
.RACW_Type
,
1399 Parent_Primitive
=> Current_Primitive
);
1401 Current_Receiver
:= Defining_Unit_Name
(
1402 Specification
(Current_Receiver_Body
));
1404 Append_To
(Body_Decls
, Current_Receiver_Body
);
1406 -- Add a case alternative to the receiver
1408 if Get_PCS_Name
= Name_PolyORB_DSA
then
1409 Append_To
(RPC_Receiver_Elsif_Parts
,
1410 Make_Elsif_Part
(Loc
,
1412 Make_Function_Call
(Loc
,
1415 RTE
(RE_Caseless_String_Eq
), Loc
),
1416 Parameter_Associations
=> New_List
(
1417 New_Occurrence_Of
(RPC_Receiver_Subp_Id
, Loc
),
1418 Make_String_Literal
(Loc
, Subp_Str
))),
1420 Then_Statements
=> New_List
(
1421 Make_Assignment_Statement
(Loc
,
1422 Name
=> New_Occurrence_Of
(
1423 RPC_Receiver_Subp_Index
, Loc
),
1425 Make_Integer_Literal
(Loc
,
1426 Intval
=> Current_Primitive_Number
)))));
1429 Append_To
(RPC_Receiver_Case_Alternatives
,
1430 Make_Case_Statement_Alternative
(Loc
,
1431 Discrete_Choices
=> New_List
(
1432 Make_Integer_Literal
(Loc
, Current_Primitive_Number
)),
1434 Statements
=> New_List
(
1435 Make_Procedure_Call_Statement
(Loc
,
1437 New_Occurrence_Of
(Current_Receiver
, Loc
),
1438 Parameter_Associations
=> New_List
(
1439 New_Occurrence_Of
(RPC_Receiver_Request
, Loc
))))));
1442 -- Increment the index of current primitive
1444 Current_Primitive_Number
:= Current_Primitive_Number
+ 1;
1447 Next_Elmt
(Current_Primitive_Elmt
);
1451 -- Build the case statement and the heart of the subprogram
1453 if Build_Bodies
and then not Is_RAS
then
1454 if Get_PCS_Name
= Name_PolyORB_DSA
1455 and then Present
(First
(RPC_Receiver_Elsif_Parts
))
1457 Append_To
(RPC_Receiver_Statements
,
1458 Make_Implicit_If_Statement
(Designated_Type
,
1459 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
1460 Then_Statements
=> New_List
,
1461 Elsif_Parts
=> RPC_Receiver_Elsif_Parts
));
1464 Append_To
(RPC_Receiver_Case_Alternatives
,
1465 Make_Case_Statement_Alternative
(Loc
,
1466 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1467 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
1469 Append_To
(RPC_Receiver_Statements
,
1470 Make_Case_Statement
(Loc
,
1472 New_Occurrence_Of
(RPC_Receiver_Subp_Index
, Loc
),
1473 Alternatives
=> RPC_Receiver_Case_Alternatives
));
1475 Append_To
(Body_Decls
, RPC_Receiver_Decl
);
1476 Specific_Add_Obj_RPC_Receiver_Completion
(Loc
,
1477 Body_Decls
, RPC_Receiver
, Stub_Elements
);
1479 -- Do not analyze RPC receiver body at this stage since it references
1480 -- subprograms that have not been analyzed yet. It will be analyzed in
1481 -- the regular flow (see Append_RACW_Bodies).
1484 end Add_RACW_Primitive_Declarations_And_Bodies
;
1486 -----------------------------
1487 -- Add_RAS_Dereference_TSS --
1488 -----------------------------
1490 procedure Add_RAS_Dereference_TSS
(N
: Node_Id
) is
1491 Loc
: constant Source_Ptr
:= Sloc
(N
);
1493 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
1494 RAS_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
1495 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(RAS_Type
);
1496 RACW_Type
: constant Entity_Id
:= Underlying_RACW_Type
(RAS_Type
);
1498 RACW_Primitive_Name
: Node_Id
;
1500 Proc
: constant Entity_Id
:=
1501 Make_Defining_Identifier
(Loc
,
1502 Chars
=> Make_TSS_Name
(RAS_Type
, TSS_RAS_Dereference
));
1504 Proc_Spec
: Node_Id
;
1505 Param_Specs
: List_Id
;
1506 Param_Assoc
: constant List_Id
:= New_List
;
1507 Stmts
: constant List_Id
:= New_List
;
1509 RAS_Parameter
: constant Entity_Id
:=
1510 Make_Defining_Identifier
(Loc
,
1511 Chars
=> New_Internal_Name
('P'));
1513 Is_Function
: constant Boolean :=
1514 Nkind
(Type_Def
) = N_Access_Function_Definition
;
1516 Is_Degenerate
: Boolean;
1517 -- Set to True if the subprogram_specification for this RAS has an
1518 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1520 Spec
: constant Node_Id
:= Type_Def
;
1522 Current_Parameter
: Node_Id
;
1524 -- Start of processing for Add_RAS_Dereference_TSS
1527 -- The Dereference TSS for a remote access-to-subprogram type has the
1530 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1533 -- This is called whenever a value of a RAS type is dereferenced
1535 -- First construct a list of parameter specifications:
1537 -- The first formal is the RAS values
1539 Param_Specs
:= New_List
(
1540 Make_Parameter_Specification
(Loc
,
1541 Defining_Identifier
=> RAS_Parameter
,
1544 New_Occurrence_Of
(Fat_Type
, Loc
)));
1546 -- The following formals are copied from the type declaration
1548 Is_Degenerate
:= False;
1549 Current_Parameter
:= First
(Parameter_Specifications
(Type_Def
));
1550 Parameters
: while Present
(Current_Parameter
) loop
1551 if Nkind
(Parameter_Type
(Current_Parameter
)) =
1554 Is_Degenerate
:= True;
1557 Append_To
(Param_Specs
,
1558 Make_Parameter_Specification
(Loc
,
1559 Defining_Identifier
=>
1560 Make_Defining_Identifier
(Loc
,
1561 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))),
1562 In_Present
=> In_Present
(Current_Parameter
),
1563 Out_Present
=> Out_Present
(Current_Parameter
),
1565 New_Copy_Tree
(Parameter_Type
(Current_Parameter
)),
1567 New_Copy_Tree
(Expression
(Current_Parameter
))));
1569 Append_To
(Param_Assoc
,
1570 Make_Identifier
(Loc
,
1571 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))));
1573 Next
(Current_Parameter
);
1574 end loop Parameters
;
1576 if Is_Degenerate
then
1577 Prepend_To
(Param_Assoc
, New_Occurrence_Of
(RAS_Parameter
, Loc
));
1579 -- Generate a dummy body. This code will never actually be executed,
1580 -- because null is the only legal value for a degenerate RAS type.
1581 -- For legality's sake (in order to avoid generating a function that
1582 -- does not contain a return statement), we include a dummy recursive
1583 -- call on the TSS itself.
1586 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Explicit_Raise
));
1587 RACW_Primitive_Name
:= New_Occurrence_Of
(Proc
, Loc
);
1590 -- For a normal RAS type, we cast the RAS formal to the corresponding
1591 -- tagged type, and perform a dispatching call to its Call primitive
1594 Prepend_To
(Param_Assoc
,
1595 Unchecked_Convert_To
(RACW_Type
,
1596 New_Occurrence_Of
(RAS_Parameter
, Loc
)));
1598 RACW_Primitive_Name
:=
1599 Make_Selected_Component
(Loc
,
1600 Prefix
=> Scope
(RACW_Type
),
1601 Selector_Name
=> Name_uCall
);
1606 Make_Simple_Return_Statement
(Loc
,
1608 Make_Function_Call
(Loc
,
1609 Name
=> RACW_Primitive_Name
,
1610 Parameter_Associations
=> Param_Assoc
)));
1614 Make_Procedure_Call_Statement
(Loc
,
1615 Name
=> RACW_Primitive_Name
,
1616 Parameter_Associations
=> Param_Assoc
));
1619 -- Build the complete subprogram
1623 Make_Function_Specification
(Loc
,
1624 Defining_Unit_Name
=> Proc
,
1625 Parameter_Specifications
=> Param_Specs
,
1626 Result_Definition
=>
1628 Entity
(Result_Definition
(Spec
)), Loc
));
1630 Set_Ekind
(Proc
, E_Function
);
1632 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
1636 Make_Procedure_Specification
(Loc
,
1637 Defining_Unit_Name
=> Proc
,
1638 Parameter_Specifications
=> Param_Specs
);
1640 Set_Ekind
(Proc
, E_Procedure
);
1641 Set_Etype
(Proc
, Standard_Void_Type
);
1645 Make_Subprogram_Body
(Loc
,
1646 Specification
=> Proc_Spec
,
1647 Declarations
=> New_List
,
1648 Handled_Statement_Sequence
=>
1649 Make_Handled_Sequence_Of_Statements
(Loc
,
1650 Statements
=> Stmts
)));
1652 Set_TSS
(Fat_Type
, Proc
);
1653 end Add_RAS_Dereference_TSS
;
1655 -------------------------------
1656 -- Add_RAS_Proxy_And_Analyze --
1657 -------------------------------
1659 procedure Add_RAS_Proxy_And_Analyze
1662 All_Calls_Remote_E
: Entity_Id
;
1663 Proxy_Object_Addr
: out Entity_Id
)
1665 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
1667 Subp_Name
: constant Entity_Id
:=
1668 Defining_Unit_Name
(Specification
(Vis_Decl
));
1670 Pkg_Name
: constant Entity_Id
:=
1671 Make_Defining_Identifier
(Loc
,
1672 Chars
=> New_External_Name
(Chars
(Subp_Name
), 'P', -1));
1674 Proxy_Type
: constant Entity_Id
:=
1675 Make_Defining_Identifier
(Loc
,
1678 (Related_Id
=> Chars
(Subp_Name
),
1681 Proxy_Type_Full_View
: constant Entity_Id
:=
1682 Make_Defining_Identifier
(Loc
,
1683 Chars
(Proxy_Type
));
1685 Subp_Decl_Spec
: constant Node_Id
:=
1686 Build_RAS_Primitive_Specification
1687 (Subp_Spec
=> Specification
(Vis_Decl
),
1688 Remote_Object_Type
=> Proxy_Type
);
1690 Subp_Body_Spec
: constant Node_Id
:=
1691 Build_RAS_Primitive_Specification
1692 (Subp_Spec
=> Specification
(Vis_Decl
),
1693 Remote_Object_Type
=> Proxy_Type
);
1695 Vis_Decls
: constant List_Id
:= New_List
;
1696 Pvt_Decls
: constant List_Id
:= New_List
;
1697 Actuals
: constant List_Id
:= New_List
;
1699 Perform_Call
: Node_Id
;
1702 -- type subpP is tagged limited private;
1704 Append_To
(Vis_Decls
,
1705 Make_Private_Type_Declaration
(Loc
,
1706 Defining_Identifier
=> Proxy_Type
,
1707 Tagged_Present
=> True,
1708 Limited_Present
=> True));
1710 -- [subprogram] Call
1711 -- (Self : access subpP;
1712 -- ...other-formals...)
1715 Append_To
(Vis_Decls
,
1716 Make_Subprogram_Declaration
(Loc
,
1717 Specification
=> Subp_Decl_Spec
));
1719 -- A : constant System.Address;
1721 Proxy_Object_Addr
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1723 Append_To
(Vis_Decls
,
1724 Make_Object_Declaration
(Loc
,
1725 Defining_Identifier
=> Proxy_Object_Addr
,
1726 Constant_Present
=> True,
1727 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
1731 -- type subpP is tagged limited record
1732 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1736 Append_To
(Pvt_Decls
,
1737 Make_Full_Type_Declaration
(Loc
,
1738 Defining_Identifier
=> Proxy_Type_Full_View
,
1740 Build_Remote_Subprogram_Proxy_Type
(Loc
,
1741 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
))));
1743 -- Trick semantic analysis into swapping the public and full view when
1744 -- freezing the public view.
1746 Set_Comes_From_Source
(Proxy_Type_Full_View
, True);
1749 -- (Self : access O;
1750 -- ...other-formals...) is
1752 -- P (...other-formals...);
1756 -- (Self : access O;
1757 -- ...other-formals...)
1760 -- return F (...other-formals...);
1763 if Nkind
(Subp_Decl_Spec
) = N_Procedure_Specification
then
1765 Make_Procedure_Call_Statement
(Loc
,
1766 Name
=> New_Occurrence_Of
(Subp_Name
, Loc
),
1767 Parameter_Associations
=> Actuals
);
1770 Make_Simple_Return_Statement
(Loc
,
1772 Make_Function_Call
(Loc
,
1773 Name
=> New_Occurrence_Of
(Subp_Name
, Loc
),
1774 Parameter_Associations
=> Actuals
));
1777 Formal
:= First
(Parameter_Specifications
(Subp_Decl_Spec
));
1778 pragma Assert
(Present
(Formal
));
1781 exit when No
(Formal
);
1783 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1786 -- O : aliased subpP;
1788 Append_To
(Pvt_Decls
,
1789 Make_Object_Declaration
(Loc
,
1790 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uO
),
1791 Aliased_Present
=> True,
1792 Object_Definition
=> New_Occurrence_Of
(Proxy_Type
, Loc
)));
1794 -- A : constant System.Address := O'Address;
1796 Append_To
(Pvt_Decls
,
1797 Make_Object_Declaration
(Loc
,
1798 Defining_Identifier
=>
1799 Make_Defining_Identifier
(Loc
, Chars
(Proxy_Object_Addr
)),
1800 Constant_Present
=> True,
1801 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
1803 Make_Attribute_Reference
(Loc
,
1804 Prefix
=> New_Occurrence_Of
(
1805 Defining_Identifier
(Last
(Pvt_Decls
)), Loc
),
1806 Attribute_Name
=> Name_Address
)));
1809 Make_Package_Declaration
(Loc
,
1810 Specification
=> Make_Package_Specification
(Loc
,
1811 Defining_Unit_Name
=> Pkg_Name
,
1812 Visible_Declarations
=> Vis_Decls
,
1813 Private_Declarations
=> Pvt_Decls
,
1814 End_Label
=> Empty
)));
1815 Analyze
(Last
(Decls
));
1818 Make_Package_Body
(Loc
,
1819 Defining_Unit_Name
=>
1820 Make_Defining_Identifier
(Loc
, Chars
(Pkg_Name
)),
1821 Declarations
=> New_List
(
1822 Make_Subprogram_Body
(Loc
,
1823 Specification
=> Subp_Body_Spec
,
1824 Declarations
=> New_List
,
1825 Handled_Statement_Sequence
=>
1826 Make_Handled_Sequence_Of_Statements
(Loc
,
1827 Statements
=> New_List
(Perform_Call
))))));
1828 Analyze
(Last
(Decls
));
1829 end Add_RAS_Proxy_And_Analyze
;
1831 -----------------------
1832 -- Add_RAST_Features --
1833 -----------------------
1835 procedure Add_RAST_Features
(Vis_Decl
: Node_Id
) is
1836 RAS_Type
: constant Entity_Id
:=
1837 Equivalent_Type
(Defining_Identifier
(Vis_Decl
));
1839 pragma Assert
(No
(TSS
(RAS_Type
, TSS_RAS_Access
)));
1840 Add_RAS_Dereference_TSS
(Vis_Decl
);
1841 Specific_Add_RAST_Features
(Vis_Decl
, RAS_Type
);
1842 end Add_RAST_Features
;
1848 procedure Add_Stub_Type
1849 (Designated_Type
: Entity_Id
;
1850 RACW_Type
: Entity_Id
;
1852 Stub_Type
: out Entity_Id
;
1853 Stub_Type_Access
: out Entity_Id
;
1854 RPC_Receiver_Decl
: out Node_Id
;
1855 Body_Decls
: out List_Id
;
1856 Existing
: out Boolean)
1858 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1860 Stub_Elements
: constant Stub_Structure
:=
1861 Stubs_Table
.Get
(Designated_Type
);
1862 Stub_Type_Decl
: Node_Id
;
1863 Stub_Type_Access_Decl
: Node_Id
;
1866 if Stub_Elements
/= Empty_Stub_Structure
then
1867 Stub_Type
:= Stub_Elements
.Stub_Type
;
1868 Stub_Type_Access
:= Stub_Elements
.Stub_Type_Access
;
1869 RPC_Receiver_Decl
:= Stub_Elements
.RPC_Receiver_Decl
;
1870 Body_Decls
:= Stub_Elements
.Body_Decls
;
1877 Make_Defining_Identifier
(Loc
,
1878 Chars
=> New_Internal_Name
('S'));
1879 Set_Ekind
(Stub_Type
, E_Record_Type
);
1880 Set_Is_RACW_Stub_Type
(Stub_Type
);
1882 Make_Defining_Identifier
(Loc
,
1883 Chars
=> New_External_Name
1884 (Related_Id
=> Chars
(Stub_Type
), Suffix
=> 'A'));
1886 Specific_Build_Stub_Type
1887 (RACW_Type
, Stub_Type
,
1888 Stub_Type_Decl
, RPC_Receiver_Decl
);
1890 Stub_Type_Access_Decl
:=
1891 Make_Full_Type_Declaration
(Loc
,
1892 Defining_Identifier
=> Stub_Type_Access
,
1894 Make_Access_To_Object_Definition
(Loc
,
1895 All_Present
=> True,
1896 Subtype_Indication
=> New_Occurrence_Of
(Stub_Type
, Loc
)));
1898 Append_To
(Decls
, Stub_Type_Decl
);
1899 Analyze
(Last
(Decls
));
1900 Append_To
(Decls
, Stub_Type_Access_Decl
);
1901 Analyze
(Last
(Decls
));
1903 -- This is in no way a type derivation, but we fake it to make sure that
1904 -- the dispatching table gets built with the corresponding primitive
1905 -- operations at the right place.
1907 Derive_Subprograms
(Parent_Type
=> Designated_Type
,
1908 Derived_Type
=> Stub_Type
);
1910 if Present
(RPC_Receiver_Decl
) then
1911 Append_To
(Decls
, RPC_Receiver_Decl
);
1913 RPC_Receiver_Decl
:= Last
(Decls
);
1916 Body_Decls
:= New_List
;
1918 Stubs_Table
.Set
(Designated_Type
,
1919 (Stub_Type
=> Stub_Type
,
1920 Stub_Type_Access
=> Stub_Type_Access
,
1921 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1922 Body_Decls
=> Body_Decls
,
1923 RACW_Type
=> RACW_Type
));
1926 ------------------------
1927 -- Append_RACW_Bodies --
1928 ------------------------
1930 procedure Append_RACW_Bodies
(Decls
: List_Id
; Spec_Id
: Entity_Id
) is
1933 E
:= First_Entity
(Spec_Id
);
1934 while Present
(E
) loop
1935 if Is_Remote_Access_To_Class_Wide_Type
(E
) then
1936 Append_List_To
(Decls
, Get_And_Reset_RACW_Bodies
(E
));
1941 end Append_RACW_Bodies
;
1943 ----------------------------------
1944 -- Assign_Subprogram_Identifier --
1945 ----------------------------------
1947 procedure Assign_Subprogram_Identifier
1952 N
: constant Name_Id
:= Chars
(Def
);
1954 Overload_Order
: constant Int
:=
1955 Overload_Counter_Table
.Get
(N
) + 1;
1958 Overload_Counter_Table
.Set
(N
, Overload_Order
);
1960 Get_Name_String
(N
);
1962 -- Homonym handling: as in Exp_Dbug, but much simpler,
1963 -- because the only entities for which we have to generate
1964 -- names here need only to be disambiguated within their
1967 if Overload_Order
> 1 then
1968 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 2) := "__";
1969 Name_Len
:= Name_Len
+ 2;
1970 Add_Nat_To_Name_Buffer
(Overload_Order
);
1973 Id
:= String_From_Name_Buffer
;
1974 Subprogram_Identifier_Table
.Set
(Def
,
1975 Subprogram_Identifiers
'(Str_Identifier => Id, Int_Identifier => Spn));
1976 end Assign_Subprogram_Identifier;
1978 -------------------------------------
1979 -- Build_Actual_Object_Declaration --
1980 -------------------------------------
1982 procedure Build_Actual_Object_Declaration
1983 (Object : Entity_Id;
1989 Loc : constant Source_Ptr := Sloc (Object);
1991 -- Declare a temporary object for the actual, possibly initialized with
1992 -- a 'Input
/From_Any call
.
1994 -- Complication arises in the case of limited types, for which such a
1995 -- declaration is illegal in Ada 95. In that case, we first generate a
1996 -- renaming declaration of the 'Input call, and then if needed we
1997 -- generate an overlaid non-constant view.
1999 if Ada_Version
<= Ada_95
2000 and then Is_Limited_Type
(Etyp
)
2001 and then Present
(Expr
)
2004 -- Object : Etyp renames <func-call>
2007 Make_Object_Renaming_Declaration
(Loc
,
2008 Defining_Identifier
=> Object
,
2009 Subtype_Mark
=> New_Occurrence_Of
(Etyp
, Loc
),
2014 -- The name defined by the renaming declaration denotes a
2015 -- constant view; create a non-constant object at the same address
2016 -- to be used as the actual.
2019 Constant_Object
: constant Entity_Id
:=
2020 Make_Defining_Identifier
(Loc
,
2021 New_Internal_Name
('P'));
2023 Set_Defining_Identifier
2024 (Last
(Decls
), Constant_Object
);
2026 -- We have an unconstrained Etyp: build the actual constrained
2027 -- subtype for the value we just read from the stream.
2029 -- subtype S is <actual subtype of Constant_Object>;
2032 Build_Actual_Subtype
(Etyp
,
2033 New_Occurrence_Of
(Constant_Object
, Loc
)));
2038 Make_Object_Declaration
(Loc
,
2039 Defining_Identifier
=> Object
,
2040 Object_Definition
=>
2042 (Defining_Identifier
(Last
(Decls
)), Loc
)));
2043 Set_Ekind
(Object
, E_Variable
);
2045 -- Suppress default initialization:
2046 -- pragma Import (Ada, Object);
2050 Chars
=> Name_Import
,
2051 Pragma_Argument_Associations
=> New_List
(
2052 Make_Pragma_Argument_Association
(Loc
,
2053 Chars
=> Name_Convention
,
2054 Expression
=> Make_Identifier
(Loc
, Name_Ada
)),
2055 Make_Pragma_Argument_Association
(Loc
,
2056 Chars
=> Name_Entity
,
2057 Expression
=> New_Occurrence_Of
(Object
, Loc
)))));
2059 -- for Object'Address use Constant_Object'Address;
2062 Make_Attribute_Definition_Clause
(Loc
,
2063 Name
=> New_Occurrence_Of
(Object
, Loc
),
2064 Chars
=> Name_Address
,
2066 Make_Attribute_Reference
(Loc
,
2067 Prefix
=> New_Occurrence_Of
(Constant_Object
, Loc
),
2068 Attribute_Name
=> Name_Address
)));
2074 -- General case of a regular object declaration. Object is flagged
2075 -- constant unless it has mode out or in out, to allow the backend
2076 -- to optimize where possible.
2078 -- Object : [constant] Etyp [:= <expr>];
2081 Make_Object_Declaration
(Loc
,
2082 Defining_Identifier
=> Object
,
2083 Constant_Present
=> Present
(Expr
) and then not Variable
,
2084 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
2085 Expression
=> Expr
));
2087 if Constant_Present
(Last
(Decls
)) then
2088 Set_Ekind
(Object
, E_Constant
);
2090 Set_Ekind
(Object
, E_Variable
);
2093 end Build_Actual_Object_Declaration
;
2095 ------------------------------
2096 -- Build_Get_Unique_RP_Call --
2097 ------------------------------
2099 function Build_Get_Unique_RP_Call
2101 Pointer
: Entity_Id
;
2102 Stub_Type
: Entity_Id
) return List_Id
2106 Make_Procedure_Call_Statement
(Loc
,
2108 New_Occurrence_Of
(RTE
(RE_Get_Unique_Remote_Pointer
), Loc
),
2109 Parameter_Associations
=> New_List
(
2110 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2111 New_Occurrence_Of
(Pointer
, Loc
)))),
2113 Make_Assignment_Statement
(Loc
,
2115 Make_Selected_Component
(Loc
,
2116 Prefix
=> New_Occurrence_Of
(Pointer
, Loc
),
2118 New_Occurrence_Of
(First_Tag_Component
2119 (Designated_Type
(Etype
(Pointer
))), Loc
)),
2121 Make_Attribute_Reference
(Loc
,
2122 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
2123 Attribute_Name
=> Name_Tag
)));
2125 -- Note: The assignment to Pointer._Tag is safe here because
2126 -- we carefully ensured that Stub_Type has exactly the same layout
2127 -- as System.Partition_Interface.RACW_Stub_Type.
2129 end Build_Get_Unique_RP_Call
;
2131 -----------------------------------
2132 -- Build_Ordered_Parameters_List --
2133 -----------------------------------
2135 function Build_Ordered_Parameters_List
(Spec
: Node_Id
) return List_Id
is
2136 Constrained_List
: List_Id
;
2137 Unconstrained_List
: List_Id
;
2138 Current_Parameter
: Node_Id
;
2141 First_Parameter
: Node_Id
;
2142 For_RAS
: Boolean := False;
2145 if No
(Parameter_Specifications
(Spec
)) then
2149 Constrained_List
:= New_List
;
2150 Unconstrained_List
:= New_List
;
2151 First_Parameter
:= First
(Parameter_Specifications
(Spec
));
2153 if Nkind
(Parameter_Type
(First_Parameter
)) = N_Access_Definition
2154 and then Chars
(Defining_Identifier
(First_Parameter
)) = Name_uS
2159 -- Loop through the parameters and add them to the right list. Note that
2160 -- we treat a parameter of a null-excluding access type as unconstrained
2161 -- because we can't declare an object of such a type with default
2164 Current_Parameter
:= First_Parameter
;
2165 while Present
(Current_Parameter
) loop
2166 Ptyp
:= Parameter_Type
(Current_Parameter
);
2168 if (Nkind
(Ptyp
) = N_Access_Definition
2169 or else not Transmit_As_Unconstrained
(Etype
(Ptyp
)))
2170 and then not (For_RAS
and then Current_Parameter
= First_Parameter
)
2172 Append_To
(Constrained_List
, New_Copy
(Current_Parameter
));
2174 Append_To
(Unconstrained_List
, New_Copy
(Current_Parameter
));
2177 Next
(Current_Parameter
);
2180 -- Unconstrained parameters are returned first
2182 Append_List_To
(Unconstrained_List
, Constrained_List
);
2184 return Unconstrained_List
;
2185 end Build_Ordered_Parameters_List
;
2187 ----------------------------------
2188 -- Build_Passive_Partition_Stub --
2189 ----------------------------------
2191 procedure Build_Passive_Partition_Stub
(U
: Node_Id
) is
2193 Pkg_Name
: String_Id
;
2196 Loc
: constant Source_Ptr
:= Sloc
(U
);
2199 -- Verify that the implementation supports distribution, by accessing
2200 -- a type defined in the proper version of system.rpc
2203 Dist_OK
: Entity_Id
;
2204 pragma Warnings
(Off
, Dist_OK
);
2206 Dist_OK
:= RTE
(RE_Params_Stream_Type
);
2209 -- Use body if present, spec otherwise
2211 if Nkind
(U
) = N_Package_Declaration
then
2212 Pkg_Spec
:= Specification
(U
);
2213 L
:= Visible_Declarations
(Pkg_Spec
);
2215 Pkg_Spec
:= Parent
(Corresponding_Spec
(U
));
2216 L
:= Declarations
(U
);
2219 Get_Library_Unit_Name_String
(Pkg_Spec
);
2220 Pkg_Name
:= String_From_Name_Buffer
;
2222 Make_Procedure_Call_Statement
(Loc
,
2224 New_Occurrence_Of
(RTE
(RE_Register_Passive_Package
), Loc
),
2225 Parameter_Associations
=> New_List
(
2226 Make_String_Literal
(Loc
, Pkg_Name
),
2227 Make_Attribute_Reference
(Loc
,
2229 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
2230 Attribute_Name
=> Name_Version
)));
2233 end Build_Passive_Partition_Stub
;
2235 --------------------------------------
2236 -- Build_RPC_Receiver_Specification --
2237 --------------------------------------
2239 function Build_RPC_Receiver_Specification
2240 (RPC_Receiver
: Entity_Id
;
2241 Request_Parameter
: Entity_Id
) return Node_Id
2243 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
2246 Make_Procedure_Specification
(Loc
,
2247 Defining_Unit_Name
=> RPC_Receiver
,
2248 Parameter_Specifications
=> New_List
(
2249 Make_Parameter_Specification
(Loc
,
2250 Defining_Identifier
=> Request_Parameter
,
2252 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
2253 end Build_RPC_Receiver_Specification
;
2255 ----------------------------------------
2256 -- Build_Remote_Subprogram_Proxy_Type --
2257 ----------------------------------------
2259 function Build_Remote_Subprogram_Proxy_Type
2261 ACR_Expression
: Node_Id
) return Node_Id
2265 Make_Record_Definition
(Loc
,
2266 Tagged_Present
=> True,
2267 Limited_Present
=> True,
2269 Make_Component_List
(Loc
,
2271 Component_Items
=> New_List
(
2272 Make_Component_Declaration
(Loc
,
2273 Defining_Identifier
=>
2274 Make_Defining_Identifier
(Loc
,
2275 Name_All_Calls_Remote
),
2276 Component_Definition
=>
2277 Make_Component_Definition
(Loc
,
2278 Subtype_Indication
=>
2279 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
2283 Make_Component_Declaration
(Loc
,
2284 Defining_Identifier
=>
2285 Make_Defining_Identifier
(Loc
,
2287 Component_Definition
=>
2288 Make_Component_Definition
(Loc
,
2289 Subtype_Indication
=>
2290 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2292 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)),
2294 Make_Component_Declaration
(Loc
,
2295 Defining_Identifier
=>
2296 Make_Defining_Identifier
(Loc
,
2298 Component_Definition
=>
2299 Make_Component_Definition
(Loc
,
2300 Subtype_Indication
=>
2301 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))))));
2302 end Build_Remote_Subprogram_Proxy_Type
;
2304 --------------------
2305 -- Build_Stub_Tag --
2306 --------------------
2308 function Build_Stub_Tag
2310 RACW_Type
: Entity_Id
) return Node_Id
2312 Stub_Type
: constant Entity_Id
:= Corresponding_Stub_Type
(RACW_Type
);
2315 Make_Attribute_Reference
(Loc
,
2316 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
2317 Attribute_Name
=> Name_Tag
);
2320 ------------------------------------
2321 -- Build_Subprogram_Calling_Stubs --
2322 ------------------------------------
2324 function Build_Subprogram_Calling_Stubs
2325 (Vis_Decl
: Node_Id
;
2327 Asynchronous
: Boolean;
2328 Dynamically_Asynchronous
: Boolean := False;
2329 Stub_Type
: Entity_Id
:= Empty
;
2330 RACW_Type
: Entity_Id
:= Empty
;
2331 Locator
: Entity_Id
:= Empty
;
2332 New_Name
: Name_Id
:= No_Name
) return Node_Id
2334 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
2336 Decls
: constant List_Id
:= New_List
;
2337 Statements
: constant List_Id
:= New_List
;
2339 Subp_Spec
: Node_Id
;
2340 -- The specification of the body
2342 Controlling_Parameter
: Entity_Id
:= Empty
;
2344 Asynchronous_Expr
: Node_Id
:= Empty
;
2346 RCI_Locator
: Entity_Id
;
2348 Spec_To_Use
: Node_Id
;
2350 procedure Insert_Partition_Check
(Parameter
: Node_Id
);
2351 -- Check that the parameter has been elaborated on the same partition
2352 -- than the controlling parameter (E.4(19)).
2354 ----------------------------
2355 -- Insert_Partition_Check --
2356 ----------------------------
2358 procedure Insert_Partition_Check
(Parameter
: Node_Id
) is
2359 Parameter_Entity
: constant Entity_Id
:=
2360 Defining_Identifier
(Parameter
);
2362 -- The expression that will be built is of the form:
2364 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2365 -- raise Constraint_Error;
2368 -- We do not check that Parameter is in Stub_Type since such a check
2369 -- has been inserted at the point of call already (a tag check since
2370 -- we have multiple controlling operands).
2373 Make_Raise_Constraint_Error
(Loc
,
2377 Make_Function_Call
(Loc
,
2379 New_Occurrence_Of
(RTE
(RE_Same_Partition
), Loc
),
2380 Parameter_Associations
=>
2382 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2383 New_Occurrence_Of
(Parameter_Entity
, Loc
)),
2384 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2385 New_Occurrence_Of
(Controlling_Parameter
, Loc
))))),
2386 Reason
=> CE_Partition_Check_Failed
));
2387 end Insert_Partition_Check
;
2389 -- Start of processing for Build_Subprogram_Calling_Stubs
2392 Subp_Spec
:= Copy_Specification
(Loc
,
2393 Spec
=> Specification
(Vis_Decl
),
2394 New_Name
=> New_Name
);
2396 if Locator
= Empty
then
2397 RCI_Locator
:= RCI_Cache
;
2398 Spec_To_Use
:= Specification
(Vis_Decl
);
2400 RCI_Locator
:= Locator
;
2401 Spec_To_Use
:= Subp_Spec
;
2404 -- Find a controlling argument if we have a stub type. Also check
2405 -- if this subprogram can be made asynchronous.
2407 if Present
(Stub_Type
)
2408 and then Present
(Parameter_Specifications
(Spec_To_Use
))
2411 Current_Parameter
: Node_Id
:=
2412 First
(Parameter_Specifications
2415 while Present
(Current_Parameter
) loop
2417 Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
)
2419 if Controlling_Parameter
= Empty
then
2420 Controlling_Parameter
:=
2421 Defining_Identifier
(Current_Parameter
);
2423 Insert_Partition_Check
(Current_Parameter
);
2427 Next
(Current_Parameter
);
2432 pragma Assert
(No
(Stub_Type
) or else Present
(Controlling_Parameter
));
2434 if Dynamically_Asynchronous
then
2435 Asynchronous_Expr
:= Make_Selected_Component
(Loc
,
2436 Prefix
=> Controlling_Parameter
,
2437 Selector_Name
=> Name_Asynchronous
);
2440 Specific_Build_General_Calling_Stubs
2442 Statements
=> Statements
,
2443 Target
=> Specific_Build_Stub_Target
(Loc
,
2444 Decls
, RCI_Locator
, Controlling_Parameter
),
2445 Subprogram_Id
=> Subp_Id
,
2446 Asynchronous
=> Asynchronous_Expr
,
2447 Is_Known_Asynchronous
=> Asynchronous
2448 and then not Dynamically_Asynchronous
,
2449 Is_Known_Non_Asynchronous
2451 and then not Dynamically_Asynchronous
,
2452 Is_Function
=> Nkind
(Spec_To_Use
) =
2453 N_Function_Specification
,
2454 Spec
=> Spec_To_Use
,
2455 Stub_Type
=> Stub_Type
,
2456 RACW_Type
=> RACW_Type
,
2459 RCI_Calling_Stubs_Table
.Set
2460 (Defining_Unit_Name
(Specification
(Vis_Decl
)),
2461 Defining_Unit_Name
(Spec_To_Use
));
2464 Make_Subprogram_Body
(Loc
,
2465 Specification
=> Subp_Spec
,
2466 Declarations
=> Decls
,
2467 Handled_Statement_Sequence
=>
2468 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
));
2469 end Build_Subprogram_Calling_Stubs
;
2471 -------------------------
2472 -- Build_Subprogram_Id --
2473 -------------------------
2475 function Build_Subprogram_Id
2477 E
: Entity_Id
) return Node_Id
2480 if Get_Subprogram_Ids
(E
).Str_Identifier
= No_String
then
2482 Current_Declaration
: Node_Id
;
2483 Current_Subp
: Entity_Id
;
2484 Current_Subp_Str
: String_Id
;
2485 Current_Subp_Number
: Int
:= First_RCI_Subprogram_Id
;
2487 pragma Warnings
(Off
, Current_Subp_Str
);
2490 -- Build_Subprogram_Id is called outside of the context of
2491 -- generating calling or receiving stubs. Hence we are processing
2492 -- an 'Access attribute_reference for an RCI subprogram, for the
2493 -- purpose of obtaining a RAS value.
2496 (Is_Remote_Call_Interface
(Scope
(E
))
2498 (Nkind
(Parent
(E
)) = N_Procedure_Specification
2500 Nkind
(Parent
(E
)) = N_Function_Specification
));
2502 Current_Declaration
:=
2503 First
(Visible_Declarations
2504 (Package_Specification_Of_Scope
(Scope
(E
))));
2505 while Present
(Current_Declaration
) loop
2506 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
2507 and then Comes_From_Source
(Current_Declaration
)
2509 Current_Subp
:= Defining_Unit_Name
(Specification
(
2510 Current_Declaration
));
2512 Assign_Subprogram_Identifier
2513 (Current_Subp
, Current_Subp_Number
, Current_Subp_Str
);
2515 Current_Subp_Number
:= Current_Subp_Number
+ 1;
2518 Next
(Current_Declaration
);
2523 case Get_PCS_Name
is
2524 when Name_PolyORB_DSA
=>
2525 return Make_String_Literal
(Loc
, Get_Subprogram_Id
(E
));
2527 return Make_Integer_Literal
(Loc
, Get_Subprogram_Id
(E
));
2529 end Build_Subprogram_Id
;
2531 ------------------------
2532 -- Copy_Specification --
2533 ------------------------
2535 function Copy_Specification
2538 Ctrl_Type
: Entity_Id
:= Empty
;
2539 New_Name
: Name_Id
:= No_Name
) return Node_Id
2541 Parameters
: List_Id
:= No_List
;
2543 Current_Parameter
: Node_Id
;
2544 Current_Identifier
: Entity_Id
;
2545 Current_Type
: Node_Id
;
2547 Name_For_New_Spec
: Name_Id
;
2549 New_Identifier
: Entity_Id
;
2551 -- Comments needed in body below ???
2554 if New_Name
= No_Name
then
2555 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
2556 or else Nkind
(Spec
) = N_Procedure_Specification
);
2558 Name_For_New_Spec
:= Chars
(Defining_Unit_Name
(Spec
));
2560 Name_For_New_Spec
:= New_Name
;
2563 if Present
(Parameter_Specifications
(Spec
)) then
2564 Parameters
:= New_List
;
2565 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2566 while Present
(Current_Parameter
) loop
2567 Current_Identifier
:= Defining_Identifier
(Current_Parameter
);
2568 Current_Type
:= Parameter_Type
(Current_Parameter
);
2570 if Nkind
(Current_Type
) = N_Access_Definition
then
2571 if Present
(Ctrl_Type
) then
2572 pragma Assert
(Is_Controlling_Formal
(Current_Identifier
));
2574 Make_Access_Definition
(Loc
,
2575 Subtype_Mark
=> New_Occurrence_Of
(Ctrl_Type
, Loc
),
2576 Null_Exclusion_Present
=>
2577 Null_Exclusion_Present
(Current_Type
));
2581 Make_Access_Definition
(Loc
,
2583 New_Copy_Tree
(Subtype_Mark
(Current_Type
)),
2584 Null_Exclusion_Present
=>
2585 Null_Exclusion_Present
(Current_Type
));
2589 if Present
(Ctrl_Type
)
2590 and then Is_Controlling_Formal
(Current_Identifier
)
2592 Current_Type
:= New_Occurrence_Of
(Ctrl_Type
, Loc
);
2594 Current_Type
:= New_Copy_Tree
(Current_Type
);
2598 New_Identifier
:= Make_Defining_Identifier
(Loc
,
2599 Chars
(Current_Identifier
));
2601 Append_To
(Parameters
,
2602 Make_Parameter_Specification
(Loc
,
2603 Defining_Identifier
=> New_Identifier
,
2604 Parameter_Type
=> Current_Type
,
2605 In_Present
=> In_Present
(Current_Parameter
),
2606 Out_Present
=> Out_Present
(Current_Parameter
),
2608 New_Copy_Tree
(Expression
(Current_Parameter
))));
2610 -- For a regular formal parameter (that needs to be marshalled
2611 -- in the context of remote calls), set the Etype now, because
2612 -- marshalling processing might need it.
2614 if Is_Entity_Name
(Current_Type
) then
2615 Set_Etype
(New_Identifier
, Entity
(Current_Type
));
2617 -- Current_Type is an access definition, special processing
2618 -- (not requiring etype) will occur for marshalling.
2624 Next
(Current_Parameter
);
2628 case Nkind
(Spec
) is
2630 when N_Function_Specification | N_Access_Function_Definition
=>
2632 Make_Function_Specification
(Loc
,
2633 Defining_Unit_Name
=>
2634 Make_Defining_Identifier
(Loc
,
2635 Chars
=> Name_For_New_Spec
),
2636 Parameter_Specifications
=> Parameters
,
2637 Result_Definition
=>
2638 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
2640 when N_Procedure_Specification | N_Access_Procedure_Definition
=>
2642 Make_Procedure_Specification
(Loc
,
2643 Defining_Unit_Name
=>
2644 Make_Defining_Identifier
(Loc
,
2645 Chars
=> Name_For_New_Spec
),
2646 Parameter_Specifications
=> Parameters
);
2649 raise Program_Error
;
2651 end Copy_Specification
;
2653 -----------------------------
2654 -- Corresponding_Stub_Type --
2655 -----------------------------
2657 function Corresponding_Stub_Type
(RACW_Type
: Entity_Id
) return Entity_Id
is
2658 Desig
: constant Entity_Id
:=
2659 Etype
(Designated_Type
(RACW_Type
));
2660 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
2662 return Stub_Elements
.Stub_Type
;
2663 end Corresponding_Stub_Type
;
2665 ---------------------------
2666 -- Could_Be_Asynchronous --
2667 ---------------------------
2669 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean is
2670 Current_Parameter
: Node_Id
;
2673 if Present
(Parameter_Specifications
(Spec
)) then
2674 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2675 while Present
(Current_Parameter
) loop
2676 if Out_Present
(Current_Parameter
) then
2680 Next
(Current_Parameter
);
2685 end Could_Be_Asynchronous
;
2687 ---------------------------
2688 -- Declare_Create_NVList --
2689 ---------------------------
2691 procedure Declare_Create_NVList
2699 Make_Object_Declaration
(Loc
,
2700 Defining_Identifier
=> NVList
,
2701 Aliased_Present
=> False,
2702 Object_Definition
=>
2703 New_Occurrence_Of
(RTE
(RE_NVList_Ref
), Loc
)));
2706 Make_Procedure_Call_Statement
(Loc
,
2707 Name
=> New_Occurrence_Of
(RTE
(RE_NVList_Create
), Loc
),
2708 Parameter_Associations
=> New_List
(
2709 New_Occurrence_Of
(NVList
, Loc
))));
2710 end Declare_Create_NVList
;
2712 ---------------------------------------------
2713 -- Expand_All_Calls_Remote_Subprogram_Call --
2714 ---------------------------------------------
2716 procedure Expand_All_Calls_Remote_Subprogram_Call
(N
: Node_Id
) is
2717 Called_Subprogram
: constant Entity_Id
:= Entity
(Name
(N
));
2718 RCI_Package
: constant Entity_Id
:= Scope
(Called_Subprogram
);
2719 Loc
: constant Source_Ptr
:= Sloc
(N
);
2720 RCI_Locator
: Node_Id
;
2721 RCI_Cache
: Entity_Id
;
2722 Calling_Stubs
: Node_Id
;
2723 E_Calling_Stubs
: Entity_Id
;
2726 E_Calling_Stubs
:= RCI_Calling_Stubs_Table
.Get
(Called_Subprogram
);
2728 if E_Calling_Stubs
= Empty
then
2729 RCI_Cache
:= RCI_Locator_Table
.Get
(RCI_Package
);
2731 if RCI_Cache
= Empty
then
2734 (Loc
, Specification
(Unit_Declaration_Node
(RCI_Package
)));
2735 Prepend_To
(Current_Sem_Unit_Declarations
, RCI_Locator
);
2737 -- The RCI_Locator package is inserted at the top level in the
2738 -- current unit, and must appear in the proper scope, so that it
2739 -- is not prematurely removed by the GCC back-end.
2742 Scop
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
2745 if Ekind
(Scop
) = E_Package_Body
then
2746 Push_Scope
(Spec_Entity
(Scop
));
2748 elsif Ekind
(Scop
) = E_Subprogram_Body
then
2750 (Corresponding_Spec
(Unit_Declaration_Node
(Scop
)));
2756 Analyze
(RCI_Locator
);
2760 RCI_Cache
:= Defining_Unit_Name
(RCI_Locator
);
2763 RCI_Locator
:= Parent
(RCI_Cache
);
2766 Calling_Stubs
:= Build_Subprogram_Calling_Stubs
2767 (Vis_Decl
=> Parent
(Parent
(Called_Subprogram
)),
2769 Build_Subprogram_Id
(Loc
, Called_Subprogram
),
2770 Asynchronous
=> Nkind
(N
) = N_Procedure_Call_Statement
2772 Is_Asynchronous
(Called_Subprogram
),
2773 Locator
=> RCI_Cache
,
2774 New_Name
=> New_Internal_Name
('S'));
2775 Insert_After
(RCI_Locator
, Calling_Stubs
);
2776 Analyze
(Calling_Stubs
);
2777 E_Calling_Stubs
:= Defining_Unit_Name
(Specification
(Calling_Stubs
));
2780 Rewrite
(Name
(N
), New_Occurrence_Of
(E_Calling_Stubs
, Loc
));
2781 end Expand_All_Calls_Remote_Subprogram_Call
;
2783 ---------------------------------
2784 -- Expand_Calling_Stubs_Bodies --
2785 ---------------------------------
2787 procedure Expand_Calling_Stubs_Bodies
(Unit_Node
: Node_Id
) is
2788 Spec
: constant Node_Id
:= Specification
(Unit_Node
);
2789 Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
2791 Push_Scope
(Scope_Of_Spec
(Spec
));
2792 Add_Calling_Stubs_To_Declarations
2793 (Specification
(Unit_Node
), Decls
);
2795 end Expand_Calling_Stubs_Bodies
;
2797 -----------------------------------
2798 -- Expand_Receiving_Stubs_Bodies --
2799 -----------------------------------
2801 procedure Expand_Receiving_Stubs_Bodies
(Unit_Node
: Node_Id
) is
2804 Stubs_Decls
: List_Id
;
2805 Stubs_Stmts
: List_Id
;
2808 if Nkind
(Unit_Node
) = N_Package_Declaration
then
2809 Spec
:= Specification
(Unit_Node
);
2810 Decls
:= Private_Declarations
(Spec
);
2813 Decls
:= Visible_Declarations
(Spec
);
2816 Push_Scope
(Scope_Of_Spec
(Spec
));
2817 Specific_Add_Receiving_Stubs_To_Declarations
(Spec
, Decls
, Decls
);
2821 Package_Specification_Of_Scope
(Corresponding_Spec
(Unit_Node
));
2822 Decls
:= Declarations
(Unit_Node
);
2824 Push_Scope
(Scope_Of_Spec
(Unit_Node
));
2825 Stubs_Decls
:= New_List
;
2826 Stubs_Stmts
:= New_List
;
2827 Specific_Add_Receiving_Stubs_To_Declarations
2828 (Spec
, Stubs_Decls
, Stubs_Stmts
);
2830 Insert_List_Before
(First
(Decls
), Stubs_Decls
);
2833 HSS_Stmts
: constant List_Id
:=
2834 Statements
(Handled_Statement_Sequence
(Unit_Node
));
2836 First_HSS_Stmt
: constant Node_Id
:= First
(HSS_Stmts
);
2839 if No
(First_HSS_Stmt
) then
2840 Append_List_To
(HSS_Stmts
, Stubs_Stmts
);
2842 Insert_List_Before
(First_HSS_Stmt
, Stubs_Stmts
);
2848 end Expand_Receiving_Stubs_Bodies
;
2850 --------------------
2851 -- GARLIC_Support --
2852 --------------------
2854 package body GARLIC_Support
is
2856 -- Local subprograms
2858 procedure Add_RACW_Read_Attribute
2859 (RACW_Type
: Entity_Id
;
2860 Stub_Type
: Entity_Id
;
2861 Stub_Type_Access
: Entity_Id
;
2862 Body_Decls
: List_Id
);
2863 -- Add Read attribute for the RACW type. The declaration and attribute
2864 -- definition clauses are inserted right after the declaration of
2865 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2866 -- appended to it (case where the RACW declaration is in the main unit).
2868 procedure Add_RACW_Write_Attribute
2869 (RACW_Type
: Entity_Id
;
2870 Stub_Type
: Entity_Id
;
2871 Stub_Type_Access
: Entity_Id
;
2872 RPC_Receiver
: Node_Id
;
2873 Body_Decls
: List_Id
);
2874 -- Same as above for the Write attribute
2876 function Stream_Parameter
return Node_Id
;
2877 function Result
return Node_Id
;
2878 function Object
return Node_Id
renames Result
;
2879 -- Functions to create occurrences of the formal parameter names of the
2880 -- 'Read and 'Write attributes.
2883 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2884 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2886 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
2887 -- Add a subprogram body for RAS Access TSS
2889 -------------------------------------
2890 -- Add_Obj_RPC_Receiver_Completion --
2891 -------------------------------------
2893 procedure Add_Obj_RPC_Receiver_Completion
2896 RPC_Receiver
: Entity_Id
;
2897 Stub_Elements
: Stub_Structure
)
2900 -- The RPC receiver body should not be the completion of the
2901 -- declaration recorded in the stub structure, because then the
2902 -- occurrences of the formal parameters within the body should refer
2903 -- to the entities from the declaration, not from the completion, to
2904 -- which we do not have easy access. Instead, the RPC receiver body
2905 -- acts as its own declaration, and the RPC receiver declaration is
2906 -- completed by a renaming-as-body.
2909 Make_Subprogram_Renaming_Declaration
(Loc
,
2911 Copy_Specification
(Loc
,
2912 Specification
(Stub_Elements
.RPC_Receiver_Decl
)),
2913 Name
=> New_Occurrence_Of
(RPC_Receiver
, Loc
)));
2914 end Add_Obj_RPC_Receiver_Completion
;
2916 -----------------------
2917 -- Add_RACW_Features --
2918 -----------------------
2920 procedure Add_RACW_Features
2921 (RACW_Type
: Entity_Id
;
2922 Stub_Type
: Entity_Id
;
2923 Stub_Type_Access
: Entity_Id
;
2924 RPC_Receiver_Decl
: Node_Id
;
2925 Body_Decls
: List_Id
)
2927 RPC_Receiver
: Node_Id
;
2928 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
2931 Loc
:= Sloc
(RACW_Type
);
2935 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2936 -- of the corresponding distributed object type. We retrieve its
2937 -- address from the local proxy object.
2939 RPC_Receiver
:= Make_Selected_Component
(Loc
,
2941 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
), Object
),
2942 Selector_Name
=> Make_Identifier
(Loc
, Name_Receiver
));
2945 RPC_Receiver
:= Make_Attribute_Reference
(Loc
,
2946 Prefix
=> New_Occurrence_Of
(
2947 Defining_Unit_Name
(Specification
(RPC_Receiver_Decl
)), Loc
),
2948 Attribute_Name
=> Name_Address
);
2951 Add_RACW_Write_Attribute
2958 Add_RACW_Read_Attribute
2963 end Add_RACW_Features
;
2965 -----------------------------
2966 -- Add_RACW_Read_Attribute --
2967 -----------------------------
2969 procedure Add_RACW_Read_Attribute
2970 (RACW_Type
: Entity_Id
;
2971 Stub_Type
: Entity_Id
;
2972 Stub_Type_Access
: Entity_Id
;
2973 Body_Decls
: List_Id
)
2975 Proc_Decl
: Node_Id
;
2976 Attr_Decl
: Node_Id
;
2978 Body_Node
: Node_Id
;
2980 Statements
: constant List_Id
:= New_List
;
2982 Local_Statements
: List_Id
;
2983 Remote_Statements
: List_Id
;
2984 -- Various parts of the procedure
2986 Pnam
: constant Entity_Id
:=
2987 Make_Defining_Identifier
2988 (Loc
, New_Internal_Name
('R'));
2989 Asynchronous_Flag
: constant Entity_Id
:=
2990 Asynchronous_Flags_Table
.Get
(RACW_Type
);
2991 pragma Assert
(Present
(Asynchronous_Flag
));
2993 -- Prepare local identifiers
2995 Source_Partition
: Entity_Id
;
2996 Source_Receiver
: Entity_Id
;
2997 Source_Address
: Entity_Id
;
2998 Local_Stub
: Entity_Id
;
2999 Stubbed_Result
: Entity_Id
;
3001 -- Start of processing for Add_RACW_Read_Attribute
3004 Build_Stream_Procedure
(Loc
,
3005 RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> True);
3006 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
3007 Copy_Specification
(Loc
, Specification
(Body_Node
)));
3010 Make_Attribute_Definition_Clause
(Loc
,
3011 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
3015 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
3017 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
3018 Insert_After
(Proc_Decl
, Attr_Decl
);
3020 if No
(Body_Decls
) then
3022 -- Case of processing an RACW type from another unit than the
3023 -- main one: do not generate a body.
3028 -- Prepare local identifiers
3031 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
3033 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
3035 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
3037 Make_Defining_Identifier
(Loc
, New_Internal_Name
('L'));
3039 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
3041 -- Generate object declarations
3044 Make_Object_Declaration
(Loc
,
3045 Defining_Identifier
=> Source_Partition
,
3046 Object_Definition
=>
3047 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
)),
3049 Make_Object_Declaration
(Loc
,
3050 Defining_Identifier
=> Source_Receiver
,
3051 Object_Definition
=>
3052 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3054 Make_Object_Declaration
(Loc
,
3055 Defining_Identifier
=> Source_Address
,
3056 Object_Definition
=>
3057 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3059 Make_Object_Declaration
(Loc
,
3060 Defining_Identifier
=> Local_Stub
,
3061 Aliased_Present
=> True,
3062 Object_Definition
=> New_Occurrence_Of
(Stub_Type
, Loc
)),
3064 Make_Object_Declaration
(Loc
,
3065 Defining_Identifier
=> Stubbed_Result
,
3066 Object_Definition
=>
3067 New_Occurrence_Of
(Stub_Type_Access
, Loc
),
3069 Make_Attribute_Reference
(Loc
,
3071 New_Occurrence_Of
(Local_Stub
, Loc
),
3073 Name_Unchecked_Access
)));
3075 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3077 Append_List_To
(Statements
, New_List
(
3078 Make_Attribute_Reference
(Loc
,
3080 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3081 Attribute_Name
=> Name_Read
,
3082 Expressions
=> New_List
(
3084 New_Occurrence_Of
(Source_Partition
, Loc
))),
3086 Make_Attribute_Reference
(Loc
,
3088 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3091 Expressions
=> New_List
(
3093 New_Occurrence_Of
(Source_Receiver
, Loc
))),
3095 Make_Attribute_Reference
(Loc
,
3097 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3100 Expressions
=> New_List
(
3102 New_Occurrence_Of
(Source_Address
, Loc
)))));
3104 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3106 Set_Etype
(Stubbed_Result
, Stub_Type_Access
);
3108 -- If the Address is Null_Address, then return a null object, unless
3109 -- RACW_Type is null-excluding, in which case unconditionally raise
3110 -- CONSTRAINT_ERROR instead.
3113 Zero_Statements
: List_Id
;
3114 -- Statements executed when a zero value is received
3117 if Can_Never_Be_Null
(RACW_Type
) then
3118 Zero_Statements
:= New_List
(
3119 Make_Raise_Constraint_Error
(Loc
,
3120 Reason
=> CE_Null_Not_Allowed
));
3122 Zero_Statements
:= New_List
(
3123 Make_Assignment_Statement
(Loc
,
3125 Expression
=> Make_Null
(Loc
)),
3126 Make_Simple_Return_Statement
(Loc
));
3129 Append_To
(Statements
,
3130 Make_Implicit_If_Statement
(RACW_Type
,
3133 Left_Opnd
=> New_Occurrence_Of
(Source_Address
, Loc
),
3134 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
3135 Then_Statements
=> Zero_Statements
));
3138 -- If the RACW denotes an object created on the current partition,
3139 -- Local_Statements will be executed. The real object will be used.
3141 Local_Statements
:= New_List
(
3142 Make_Assignment_Statement
(Loc
,
3145 Unchecked_Convert_To
(RACW_Type
,
3146 OK_Convert_To
(RTE
(RE_Address
),
3147 New_Occurrence_Of
(Source_Address
, Loc
)))));
3149 -- If the object is located on another partition, then a stub object
3150 -- will be created with all the information needed to rebuild the
3151 -- real object at the other end.
3153 Remote_Statements
:= New_List
(
3155 Make_Assignment_Statement
(Loc
,
3156 Name
=> Make_Selected_Component
(Loc
,
3157 Prefix
=> Stubbed_Result
,
3158 Selector_Name
=> Name_Origin
),
3160 New_Occurrence_Of
(Source_Partition
, Loc
)),
3162 Make_Assignment_Statement
(Loc
,
3163 Name
=> Make_Selected_Component
(Loc
,
3164 Prefix
=> Stubbed_Result
,
3165 Selector_Name
=> Name_Receiver
),
3167 New_Occurrence_Of
(Source_Receiver
, Loc
)),
3169 Make_Assignment_Statement
(Loc
,
3170 Name
=> Make_Selected_Component
(Loc
,
3171 Prefix
=> Stubbed_Result
,
3172 Selector_Name
=> Name_Addr
),
3174 New_Occurrence_Of
(Source_Address
, Loc
)));
3176 Append_To
(Remote_Statements
,
3177 Make_Assignment_Statement
(Loc
,
3178 Name
=> Make_Selected_Component
(Loc
,
3179 Prefix
=> Stubbed_Result
,
3180 Selector_Name
=> Name_Asynchronous
),
3182 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)));
3184 Append_List_To
(Remote_Statements
,
3185 Build_Get_Unique_RP_Call
(Loc
, Stubbed_Result
, Stub_Type
));
3186 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3187 -- set on the stub type if, and only if, the RACW type has a pragma
3188 -- Asynchronous. This is incorrect for RACWs that implement RAS
3189 -- types, because in that case the /designated subprogram/ (not the
3190 -- type) might be asynchronous, and that causes the stub to need to
3191 -- be asynchronous too. A solution is to transport a RAS as a struct
3192 -- containing a RACW and an asynchronous flag, and to properly alter
3193 -- the Asynchronous component in the stub type in the RAS's Input
3196 Append_To
(Remote_Statements
,
3197 Make_Assignment_Statement
(Loc
,
3199 Expression
=> Unchecked_Convert_To
(RACW_Type
,
3200 New_Occurrence_Of
(Stubbed_Result
, Loc
))));
3202 -- Distinguish between the local and remote cases, and execute the
3203 -- appropriate piece of code.
3205 Append_To
(Statements
,
3206 Make_Implicit_If_Statement
(RACW_Type
,
3210 Make_Function_Call
(Loc
,
3211 Name
=> New_Occurrence_Of
(
3212 RTE
(RE_Get_Local_Partition_Id
), Loc
)),
3213 Right_Opnd
=> New_Occurrence_Of
(Source_Partition
, Loc
)),
3214 Then_Statements
=> Local_Statements
,
3215 Else_Statements
=> Remote_Statements
));
3217 Set_Declarations
(Body_Node
, Decls
);
3218 Append_To
(Body_Decls
, Body_Node
);
3219 end Add_RACW_Read_Attribute
;
3221 ------------------------------
3222 -- Add_RACW_Write_Attribute --
3223 ------------------------------
3225 procedure Add_RACW_Write_Attribute
3226 (RACW_Type
: Entity_Id
;
3227 Stub_Type
: Entity_Id
;
3228 Stub_Type_Access
: Entity_Id
;
3229 RPC_Receiver
: Node_Id
;
3230 Body_Decls
: List_Id
)
3232 Body_Node
: Node_Id
;
3233 Proc_Decl
: Node_Id
;
3234 Attr_Decl
: Node_Id
;
3236 Statements
: constant List_Id
:= New_List
;
3237 Local_Statements
: List_Id
;
3238 Remote_Statements
: List_Id
;
3239 Null_Statements
: List_Id
;
3241 Pnam
: constant Entity_Id
:=
3242 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
3245 Build_Stream_Procedure
3246 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> False);
3248 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
3249 Copy_Specification
(Loc
, Specification
(Body_Node
)));
3252 Make_Attribute_Definition_Clause
(Loc
,
3253 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
3254 Chars
=> Name_Write
,
3257 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
3259 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
3260 Insert_After
(Proc_Decl
, Attr_Decl
);
3262 if No
(Body_Decls
) then
3266 -- Build the code fragment corresponding to the marshalling of a
3269 Local_Statements
:= New_List
(
3271 Pack_Entity_Into_Stream_Access
(Loc
,
3272 Stream
=> Stream_Parameter
,
3273 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
3275 Pack_Node_Into_Stream_Access
(Loc
,
3276 Stream
=> Stream_Parameter
,
3277 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
), RPC_Receiver
),
3278 Etyp
=> RTE
(RE_Unsigned_64
)),
3280 Pack_Node_Into_Stream_Access
(Loc
,
3281 Stream
=> Stream_Parameter
,
3282 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
),
3283 Make_Attribute_Reference
(Loc
,
3285 Make_Explicit_Dereference
(Loc
,
3287 Attribute_Name
=> Name_Address
)),
3288 Etyp
=> RTE
(RE_Unsigned_64
)));
3290 -- Build the code fragment corresponding to the marshalling of
3293 Remote_Statements
:= New_List
(
3294 Pack_Node_Into_Stream_Access
(Loc
,
3295 Stream
=> Stream_Parameter
,
3297 Make_Selected_Component
(Loc
,
3299 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3300 Selector_Name
=> Make_Identifier
(Loc
, Name_Origin
)),
3301 Etyp
=> RTE
(RE_Partition_ID
)),
3303 Pack_Node_Into_Stream_Access
(Loc
,
3304 Stream
=> Stream_Parameter
,
3306 Make_Selected_Component
(Loc
,
3308 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3309 Selector_Name
=> Make_Identifier
(Loc
, Name_Receiver
)),
3310 Etyp
=> RTE
(RE_Unsigned_64
)),
3312 Pack_Node_Into_Stream_Access
(Loc
,
3313 Stream
=> Stream_Parameter
,
3315 Make_Selected_Component
(Loc
,
3317 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3318 Selector_Name
=> Make_Identifier
(Loc
, Name_Addr
)),
3319 Etyp
=> RTE
(RE_Unsigned_64
)));
3321 -- Build code fragment corresponding to marshalling of a null object
3323 Null_Statements
:= New_List
(
3325 Pack_Entity_Into_Stream_Access
(Loc
,
3326 Stream
=> Stream_Parameter
,
3327 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
3329 Pack_Node_Into_Stream_Access
(Loc
,
3330 Stream
=> Stream_Parameter
,
3331 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
), RPC_Receiver
),
3332 Etyp
=> RTE
(RE_Unsigned_64
)),
3334 Pack_Node_Into_Stream_Access
(Loc
,
3335 Stream
=> Stream_Parameter
,
3336 Object
=> Make_Integer_Literal
(Loc
, Uint_0
),
3337 Etyp
=> RTE
(RE_Unsigned_64
)));
3339 Append_To
(Statements
,
3340 Make_Implicit_If_Statement
(RACW_Type
,
3343 Left_Opnd
=> Object
,
3344 Right_Opnd
=> Make_Null
(Loc
)),
3346 Then_Statements
=> Null_Statements
,
3348 Elsif_Parts
=> New_List
(
3349 Make_Elsif_Part
(Loc
,
3353 Make_Attribute_Reference
(Loc
,
3355 Attribute_Name
=> Name_Tag
),
3358 Make_Attribute_Reference
(Loc
,
3359 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
3360 Attribute_Name
=> Name_Tag
)),
3361 Then_Statements
=> Remote_Statements
)),
3362 Else_Statements
=> Local_Statements
));
3364 Append_To
(Body_Decls
, Body_Node
);
3365 end Add_RACW_Write_Attribute
;
3367 ------------------------
3368 -- Add_RAS_Access_TSS --
3369 ------------------------
3371 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
3372 Loc
: constant Source_Ptr
:= Sloc
(N
);
3374 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
3375 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
3376 -- Ras_Type is the access to subprogram type while Fat_Type is the
3377 -- corresponding record type.
3379 RACW_Type
: constant Entity_Id
:=
3380 Underlying_RACW_Type
(Ras_Type
);
3381 Desig
: constant Entity_Id
:=
3382 Etype
(Designated_Type
(RACW_Type
));
3384 Stub_Elements
: constant Stub_Structure
:=
3385 Stubs_Table
.Get
(Desig
);
3386 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
3388 Proc
: constant Entity_Id
:=
3389 Make_Defining_Identifier
(Loc
,
3390 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
3392 Proc_Spec
: Node_Id
;
3394 -- Formal parameters
3396 Package_Name
: constant Entity_Id
:=
3397 Make_Defining_Identifier
(Loc
,
3401 Subp_Id
: constant Entity_Id
:=
3402 Make_Defining_Identifier
(Loc
,
3404 -- Target subprogram
3406 Asynch_P
: constant Entity_Id
:=
3407 Make_Defining_Identifier
(Loc
,
3408 Chars
=> Name_Asynchronous
);
3409 -- Is the procedure to which the 'Access applies asynchronous?
3411 All_Calls_Remote
: constant Entity_Id
:=
3412 Make_Defining_Identifier
(Loc
,
3413 Chars
=> Name_All_Calls_Remote
);
3414 -- True if an All_Calls_Remote pragma applies to the RCI unit
3415 -- that contains the subprogram.
3417 -- Common local variables
3419 Proc_Decls
: List_Id
;
3420 Proc_Statements
: List_Id
;
3422 Origin
: constant Entity_Id
:=
3423 Make_Defining_Identifier
(Loc
,
3424 Chars
=> New_Internal_Name
('P'));
3426 -- Additional local variables for the local case
3428 Proxy_Addr
: constant Entity_Id
:=
3429 Make_Defining_Identifier
(Loc
,
3430 Chars
=> New_Internal_Name
('P'));
3432 -- Additional local variables for the remote case
3434 Local_Stub
: constant Entity_Id
:=
3435 Make_Defining_Identifier
(Loc
,
3436 Chars
=> New_Internal_Name
('L'));
3438 Stub_Ptr
: constant Entity_Id
:=
3439 Make_Defining_Identifier
(Loc
,
3440 Chars
=> New_Internal_Name
('S'));
3443 (Field_Name
: Name_Id
;
3444 Value
: Node_Id
) return Node_Id
;
3445 -- Construct an assignment that sets the named component in the
3453 (Field_Name
: Name_Id
;
3454 Value
: Node_Id
) return Node_Id
3458 Make_Assignment_Statement
(Loc
,
3460 Make_Selected_Component
(Loc
,
3462 Selector_Name
=> Field_Name
),
3463 Expression
=> Value
);
3466 -- Start of processing for Add_RAS_Access_TSS
3469 Proc_Decls
:= New_List
(
3471 -- Common declarations
3473 Make_Object_Declaration
(Loc
,
3474 Defining_Identifier
=> Origin
,
3475 Constant_Present
=> True,
3476 Object_Definition
=>
3477 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3479 Make_Function_Call
(Loc
,
3481 New_Occurrence_Of
(RTE
(RE_Get_Active_Partition_Id
), Loc
),
3482 Parameter_Associations
=> New_List
(
3483 New_Occurrence_Of
(Package_Name
, Loc
)))),
3485 -- Declaration use only in the local case: proxy address
3487 Make_Object_Declaration
(Loc
,
3488 Defining_Identifier
=> Proxy_Addr
,
3489 Object_Definition
=>
3490 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3492 -- Declarations used only in the remote case: stub object and
3495 Make_Object_Declaration
(Loc
,
3496 Defining_Identifier
=> Local_Stub
,
3497 Aliased_Present
=> True,
3498 Object_Definition
=>
3499 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
3501 Make_Object_Declaration
(Loc
,
3502 Defining_Identifier
=>
3504 Object_Definition
=>
3505 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
3507 Make_Attribute_Reference
(Loc
,
3508 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
3509 Attribute_Name
=> Name_Unchecked_Access
)));
3511 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
3513 -- Build_Get_Unique_RP_Call needs above information
3515 -- Note: Here we assume that the Fat_Type is a record
3516 -- containing just a pointer to a proxy or stub object.
3518 Proc_Statements
:= New_List
(
3522 -- Get_RAS_Info (Pkg, Subp, PA);
3523 -- if Origin = Local_Partition_Id
3524 -- and then not All_Calls_Remote
3526 -- return Fat_Type!(PA);
3529 Make_Procedure_Call_Statement
(Loc
,
3530 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
3531 Parameter_Associations
=> New_List
(
3532 New_Occurrence_Of
(Package_Name
, Loc
),
3533 New_Occurrence_Of
(Subp_Id
, Loc
),
3534 New_Occurrence_Of
(Proxy_Addr
, Loc
))),
3536 Make_Implicit_If_Statement
(N
,
3542 New_Occurrence_Of
(Origin
, Loc
),
3544 Make_Function_Call
(Loc
,
3546 RTE
(RE_Get_Local_Partition_Id
), Loc
))),
3550 New_Occurrence_Of
(All_Calls_Remote
, Loc
))),
3552 Then_Statements
=> New_List
(
3553 Make_Simple_Return_Statement
(Loc
,
3554 Unchecked_Convert_To
(Fat_Type
,
3555 OK_Convert_To
(RTE
(RE_Address
),
3556 New_Occurrence_Of
(Proxy_Addr
, Loc
)))))),
3558 Set_Field
(Name_Origin
,
3559 New_Occurrence_Of
(Origin
, Loc
)),
3561 Set_Field
(Name_Receiver
,
3562 Make_Function_Call
(Loc
,
3564 New_Occurrence_Of
(RTE
(RE_Get_RCI_Package_Receiver
), Loc
),
3565 Parameter_Associations
=> New_List
(
3566 New_Occurrence_Of
(Package_Name
, Loc
)))),
3568 Set_Field
(Name_Addr
, New_Occurrence_Of
(Proxy_Addr
, Loc
)),
3570 -- E.4.1(9) A remote call is asynchronous if it is a call to
3571 -- a procedure or a call through a value of an access-to-procedure
3572 -- type to which a pragma Asynchronous applies.
3574 -- Asynch_P is true when the procedure is asynchronous;
3575 -- Asynch_T is true when the type is asynchronous.
3577 Set_Field
(Name_Asynchronous
,
3579 New_Occurrence_Of
(Asynch_P
, Loc
),
3580 New_Occurrence_Of
(Boolean_Literals
(
3581 Is_Asynchronous
(Ras_Type
)), Loc
))));
3583 Append_List_To
(Proc_Statements
,
3584 Build_Get_Unique_RP_Call
3585 (Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
3587 -- Return the newly created value
3589 Append_To
(Proc_Statements
,
3590 Make_Simple_Return_Statement
(Loc
,
3592 Unchecked_Convert_To
(Fat_Type
,
3593 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
3596 Make_Function_Specification
(Loc
,
3597 Defining_Unit_Name
=> Proc
,
3598 Parameter_Specifications
=> New_List
(
3599 Make_Parameter_Specification
(Loc
,
3600 Defining_Identifier
=> Package_Name
,
3602 New_Occurrence_Of
(Standard_String
, Loc
)),
3604 Make_Parameter_Specification
(Loc
,
3605 Defining_Identifier
=> Subp_Id
,
3607 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
)),
3609 Make_Parameter_Specification
(Loc
,
3610 Defining_Identifier
=> Asynch_P
,
3612 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3614 Make_Parameter_Specification
(Loc
,
3615 Defining_Identifier
=> All_Calls_Remote
,
3617 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
3619 Result_Definition
=>
3620 New_Occurrence_Of
(Fat_Type
, Loc
));
3622 -- Set the kind and return type of the function to prevent
3623 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3625 Set_Ekind
(Proc
, E_Function
);
3626 Set_Etype
(Proc
, Fat_Type
);
3629 Make_Subprogram_Body
(Loc
,
3630 Specification
=> Proc_Spec
,
3631 Declarations
=> Proc_Decls
,
3632 Handled_Statement_Sequence
=>
3633 Make_Handled_Sequence_Of_Statements
(Loc
,
3634 Statements
=> Proc_Statements
)));
3636 Set_TSS
(Fat_Type
, Proc
);
3637 end Add_RAS_Access_TSS
;
3639 -----------------------
3640 -- Add_RAST_Features --
3641 -----------------------
3643 procedure Add_RAST_Features
3644 (Vis_Decl
: Node_Id
;
3645 RAS_Type
: Entity_Id
)
3647 pragma Warnings
(Off
);
3648 pragma Unreferenced
(RAS_Type
);
3649 pragma Warnings
(On
);
3651 Add_RAS_Access_TSS
(Vis_Decl
);
3652 end Add_RAST_Features
;
3654 -----------------------------------------
3655 -- Add_Receiving_Stubs_To_Declarations --
3656 -----------------------------------------
3658 procedure Add_Receiving_Stubs_To_Declarations
3659 (Pkg_Spec
: Node_Id
;
3663 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
3665 Request_Parameter
: Node_Id
;
3667 Pkg_RPC_Receiver
: constant Entity_Id
:=
3668 Make_Defining_Identifier
(Loc
,
3669 New_Internal_Name
('H'));
3670 Pkg_RPC_Receiver_Statements
: List_Id
;
3671 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
3672 Pkg_RPC_Receiver_Body
: Node_Id
;
3673 -- A Pkg_RPC_Receiver is built to decode the request
3675 Lookup_RAS_Info
: constant Entity_Id
:=
3676 Make_Defining_Identifier
(Loc
,
3677 Chars
=> New_Internal_Name
('R'));
3678 -- A remote subprogram is created to allow peers to look up
3679 -- RAS information using subprogram ids.
3681 Subp_Id
: Entity_Id
;
3682 Subp_Index
: Entity_Id
;
3683 -- Subprogram_Id as read from the incoming stream
3685 Current_Declaration
: Node_Id
;
3686 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
3687 Current_Stubs
: Node_Id
;
3689 Subp_Info_Array
: constant Entity_Id
:=
3690 Make_Defining_Identifier
(Loc
,
3691 Chars
=> New_Internal_Name
('I'));
3693 Subp_Info_List
: constant List_Id
:= New_List
;
3695 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
3697 All_Calls_Remote_E
: Entity_Id
;
3698 Proxy_Object_Addr
: Entity_Id
;
3700 procedure Append_Stubs_To
3701 (RPC_Receiver_Cases
: List_Id
;
3703 Subprogram_Number
: Int
);
3704 -- Add one case to the specified RPC receiver case list
3705 -- associating Subprogram_Number with the subprogram declared
3706 -- by Declaration, for which we have receiving stubs in Stubs.
3708 ---------------------
3709 -- Append_Stubs_To --
3710 ---------------------
3712 procedure Append_Stubs_To
3713 (RPC_Receiver_Cases
: List_Id
;
3715 Subprogram_Number
: Int
)
3718 Append_To
(RPC_Receiver_Cases
,
3719 Make_Case_Statement_Alternative
(Loc
,
3721 New_List
(Make_Integer_Literal
(Loc
, Subprogram_Number
)),
3724 Make_Procedure_Call_Statement
(Loc
,
3726 New_Occurrence_Of
(Defining_Entity
(Stubs
), Loc
),
3727 Parameter_Associations
=> New_List
(
3728 New_Occurrence_Of
(Request_Parameter
, Loc
))))));
3729 end Append_Stubs_To
;
3731 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3734 -- Building receiving stubs consist in several operations:
3736 -- - a package RPC receiver must be built. This subprogram
3737 -- will get a Subprogram_Id from the incoming stream
3738 -- and will dispatch the call to the right subprogram;
3740 -- - a receiving stub for each subprogram visible in the package
3741 -- spec. This stub will read all the parameters from the stream,
3742 -- and put the result as well as the exception occurrence in the
3745 -- - a dummy package with an empty spec and a body made of an
3746 -- elaboration part, whose job is to register the receiving
3747 -- part of this RCI package on the name server. This is done
3748 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3750 Build_RPC_Receiver_Body
(
3751 RPC_Receiver
=> Pkg_RPC_Receiver
,
3752 Request
=> Request_Parameter
,
3754 Subp_Index
=> Subp_Index
,
3755 Stmts
=> Pkg_RPC_Receiver_Statements
,
3756 Decl
=> Pkg_RPC_Receiver_Body
);
3757 pragma Assert
(Subp_Id
= Subp_Index
);
3759 -- A null subp_id denotes a call through a RAS, in which case the
3760 -- next Uint_64 element in the stream is the address of the local
3761 -- proxy object, from which we can retrieve the actual subprogram id.
3763 Append_To
(Pkg_RPC_Receiver_Statements
,
3764 Make_Implicit_If_Statement
(Pkg_Spec
,
3767 New_Occurrence_Of
(Subp_Id
, Loc
),
3768 Make_Integer_Literal
(Loc
, 0)),
3770 Then_Statements
=> New_List
(
3771 Make_Assignment_Statement
(Loc
,
3773 New_Occurrence_Of
(Subp_Id
, Loc
),
3776 Make_Selected_Component
(Loc
,
3778 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
3779 OK_Convert_To
(RTE
(RE_Address
),
3780 Make_Attribute_Reference
(Loc
,
3782 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3785 Expressions
=> New_List
(
3786 Make_Selected_Component
(Loc
,
3787 Prefix
=> Request_Parameter
,
3788 Selector_Name
=> Name_Params
))))),
3791 Make_Identifier
(Loc
, Name_Subp_Id
))))));
3793 -- Build a subprogram for RAS information lookups
3795 Current_Declaration
:=
3796 Make_Subprogram_Declaration
(Loc
,
3798 Make_Function_Specification
(Loc
,
3799 Defining_Unit_Name
=>
3801 Parameter_Specifications
=> New_List
(
3802 Make_Parameter_Specification
(Loc
,
3803 Defining_Identifier
=>
3804 Make_Defining_Identifier
(Loc
, Name_Subp_Id
),
3808 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))),
3809 Result_Definition
=>
3810 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)));
3812 Append_To
(Decls
, Current_Declaration
);
3813 Analyze
(Current_Declaration
);
3815 Current_Stubs
:= Build_Subprogram_Receiving_Stubs
3816 (Vis_Decl
=> Current_Declaration
,
3817 Asynchronous
=> False);
3818 Append_To
(Decls
, Current_Stubs
);
3819 Analyze
(Current_Stubs
);
3821 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3824 Subprogram_Number
=> 1);
3826 -- For each subprogram, the receiving stub will be built and a
3827 -- case statement will be made on the Subprogram_Id to dispatch
3828 -- to the right subprogram.
3830 All_Calls_Remote_E
:=
3832 (Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
3834 Overload_Counter_Table
.Reset
;
3836 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
3837 while Present
(Current_Declaration
) loop
3838 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
3839 and then Comes_From_Source
(Current_Declaration
)
3842 Loc
: constant Source_Ptr
:= Sloc
(Current_Declaration
);
3843 -- While specifically processing Current_Declaration, use
3844 -- its Sloc as the location of all generated nodes.
3846 Subp_Def
: constant Entity_Id
:=
3848 (Specification
(Current_Declaration
));
3850 Subp_Val
: String_Id
;
3851 pragma Warnings
(Off
, Subp_Val
);
3854 -- Build receiving stub
3857 Build_Subprogram_Receiving_Stubs
3858 (Vis_Decl
=> Current_Declaration
,
3860 Nkind
(Specification
(Current_Declaration
)) =
3861 N_Procedure_Specification
3862 and then Is_Asynchronous
(Subp_Def
));
3864 Append_To
(Decls
, Current_Stubs
);
3865 Analyze
(Current_Stubs
);
3869 Add_RAS_Proxy_And_Analyze
(Decls
,
3870 Vis_Decl
=> Current_Declaration
,
3871 All_Calls_Remote_E
=> All_Calls_Remote_E
,
3872 Proxy_Object_Addr
=> Proxy_Object_Addr
);
3874 -- Compute distribution identifier
3876 Assign_Subprogram_Identifier
3878 Current_Subprogram_Number
,
3882 (Current_Subprogram_Number
= Get_Subprogram_Id
(Subp_Def
));
3884 -- Add subprogram descriptor (RCI_Subp_Info) to the
3885 -- subprograms table for this receiver. The aggregate
3886 -- below must be kept consistent with the declaration
3887 -- of type RCI_Subp_Info in System.Partition_Interface.
3889 Append_To
(Subp_Info_List
,
3890 Make_Component_Association
(Loc
,
3891 Choices
=> New_List
(
3892 Make_Integer_Literal
(Loc
,
3893 Current_Subprogram_Number
)),
3896 Make_Aggregate
(Loc
,
3897 Component_Associations
=> New_List
(
3898 Make_Component_Association
(Loc
,
3899 Choices
=> New_List
(
3900 Make_Identifier
(Loc
, Name_Addr
)),
3903 Proxy_Object_Addr
, Loc
))))));
3905 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3906 Stubs
=> Current_Stubs
,
3907 Subprogram_Number
=> Current_Subprogram_Number
);
3910 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
3913 Next
(Current_Declaration
);
3916 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3917 -- rather than raising an exception since we do not want someone
3918 -- to crash a remote partition by sending invalid subprogram ids.
3919 -- This is consistent with the other parts of the case statement
3920 -- since even in presence of incorrect parameters in the stream,
3921 -- every exception will be caught and (if the subprogram is not an
3922 -- APC) put into the result stream and sent away.
3924 Append_To
(Pkg_RPC_Receiver_Cases
,
3925 Make_Case_Statement_Alternative
(Loc
,
3926 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
3927 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
3929 Append_To
(Pkg_RPC_Receiver_Statements
,
3930 Make_Case_Statement
(Loc
,
3931 Expression
=> New_Occurrence_Of
(Subp_Id
, Loc
),
3932 Alternatives
=> Pkg_RPC_Receiver_Cases
));
3935 Make_Object_Declaration
(Loc
,
3936 Defining_Identifier
=> Subp_Info_Array
,
3937 Constant_Present
=> True,
3938 Aliased_Present
=> True,
3939 Object_Definition
=>
3940 Make_Subtype_Indication
(Loc
,
3942 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
3944 Make_Index_Or_Discriminant_Constraint
(Loc
,
3947 Low_Bound
=> Make_Integer_Literal
(Loc
,
3948 First_RCI_Subprogram_Id
),
3950 Make_Integer_Literal
(Loc
,
3952 First_RCI_Subprogram_Id
3953 + List_Length
(Subp_Info_List
) - 1)))))));
3955 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
3956 -- has zero length, and the declaration is for an empty array, in
3957 -- which case no initialization aggregate must be generated.
3959 if Present
(First
(Subp_Info_List
)) then
3960 Set_Expression
(Last
(Decls
),
3961 Make_Aggregate
(Loc
,
3962 Component_Associations
=> Subp_Info_List
));
3964 -- No initialization provided: remove CONSTANT so that the
3965 -- declaration is not an incomplete deferred constant.
3968 Set_Constant_Present
(Last
(Decls
), False);
3971 Analyze
(Last
(Decls
));
3974 Subp_Info_Addr
: Node_Id
;
3975 -- Return statement for Lookup_RAS_Info: address of the subprogram
3976 -- information record for the requested subprogram id.
3979 if Present
(First
(Subp_Info_List
)) then
3981 Make_Selected_Component
(Loc
,
3983 Make_Indexed_Component
(Loc
,
3984 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3985 Expressions
=> New_List
(
3986 Convert_To
(Standard_Integer
,
3987 Make_Identifier
(Loc
, Name_Subp_Id
)))),
3988 Selector_Name
=> Make_Identifier
(Loc
, Name_Addr
));
3990 -- Case of no visible subprogram: just raise Constraint_Error, we
3991 -- know for sure we got junk from a remote partition.
3995 Make_Raise_Constraint_Error
(Loc
,
3996 Reason
=> CE_Range_Check_Failed
);
3997 Set_Etype
(Subp_Info_Addr
, RTE
(RE_Unsigned_64
));
4001 Make_Subprogram_Body
(Loc
,
4003 Copy_Specification
(Loc
, Parent
(Lookup_RAS_Info
)),
4004 Declarations
=> No_List
,
4005 Handled_Statement_Sequence
=>
4006 Make_Handled_Sequence_Of_Statements
(Loc
,
4007 Statements
=> New_List
(
4008 Make_Simple_Return_Statement
(Loc
,
4011 (RTE
(RE_Unsigned_64
), Subp_Info_Addr
))))));
4014 Analyze
(Last
(Decls
));
4016 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
4017 Analyze
(Last
(Decls
));
4019 Get_Library_Unit_Name_String
(Pkg_Spec
);
4023 Append_To
(Register_Pkg_Actuals
,
4024 Make_String_Literal
(Loc
,
4025 Strval
=> String_From_Name_Buffer
));
4029 Append_To
(Register_Pkg_Actuals
,
4030 Make_Attribute_Reference
(Loc
,
4031 Prefix
=> New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
4032 Attribute_Name
=> Name_Unrestricted_Access
));
4036 Append_To
(Register_Pkg_Actuals
,
4037 Make_Attribute_Reference
(Loc
,
4039 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
4040 Attribute_Name
=> Name_Version
));
4044 Append_To
(Register_Pkg_Actuals
,
4045 Make_Attribute_Reference
(Loc
,
4046 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
4047 Attribute_Name
=> Name_Address
));
4051 Append_To
(Register_Pkg_Actuals
,
4052 Make_Attribute_Reference
(Loc
,
4053 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
4054 Attribute_Name
=> Name_Length
));
4056 -- Generate the call
4059 Make_Procedure_Call_Statement
(Loc
,
4061 New_Occurrence_Of
(RTE
(RE_Register_Receiving_Stub
), Loc
),
4062 Parameter_Associations
=> Register_Pkg_Actuals
));
4063 Analyze
(Last
(Stmts
));
4064 end Add_Receiving_Stubs_To_Declarations
;
4066 ---------------------------------
4067 -- Build_General_Calling_Stubs --
4068 ---------------------------------
4070 procedure Build_General_Calling_Stubs
4072 Statements
: List_Id
;
4073 Target_Partition
: Entity_Id
;
4074 Target_RPC_Receiver
: Node_Id
;
4075 Subprogram_Id
: Node_Id
;
4076 Asynchronous
: Node_Id
:= Empty
;
4077 Is_Known_Asynchronous
: Boolean := False;
4078 Is_Known_Non_Asynchronous
: Boolean := False;
4079 Is_Function
: Boolean;
4081 Stub_Type
: Entity_Id
:= Empty
;
4082 RACW_Type
: Entity_Id
:= Empty
;
4085 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
4087 Stream_Parameter
: Node_Id
;
4088 -- Name of the stream used to transmit parameters to the
4091 Result_Parameter
: Node_Id
;
4092 -- Name of the result parameter (in non-APC cases) which get the
4093 -- result of the remote subprogram.
4095 Exception_Return_Parameter
: Node_Id
;
4096 -- Name of the parameter which will hold the exception sent by the
4097 -- remote subprogram.
4099 Current_Parameter
: Node_Id
;
4100 -- Current parameter being handled
4102 Ordered_Parameters_List
: constant List_Id
:=
4103 Build_Ordered_Parameters_List
(Spec
);
4105 Asynchronous_Statements
: List_Id
:= No_List
;
4106 Non_Asynchronous_Statements
: List_Id
:= No_List
;
4107 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4109 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4110 -- List of statements for extra formal parameters. It will appear
4111 -- after the regular statements for writing out parameters.
4113 pragma Warnings
(Off
);
4114 pragma Unreferenced
(RACW_Type
);
4115 -- Used only for the PolyORB case
4116 pragma Warnings
(On
);
4119 -- The general form of a calling stub for a given subprogram is:
4121 -- procedure X (...) is P : constant Partition_ID :=
4122 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4123 -- System.RPC.Params_Stream_Type (0); begin
4124 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4125 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4126 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4127 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4129 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4131 -- There are some variations: Do_APC is called for an asynchronous
4132 -- procedure and the part after the call is completely ommitted as
4133 -- well as the declaration of Result. For a function call, 'Input is
4134 -- always used to read the result even if it is constrained.
4137 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
4140 Make_Object_Declaration
(Loc
,
4141 Defining_Identifier
=> Stream_Parameter
,
4142 Aliased_Present
=> True,
4143 Object_Definition
=>
4144 Make_Subtype_Indication
(Loc
,
4146 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
4148 Make_Index_Or_Discriminant_Constraint
(Loc
,
4150 New_List
(Make_Integer_Literal
(Loc
, 0))))));
4152 if not Is_Known_Asynchronous
then
4154 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4157 Make_Object_Declaration
(Loc
,
4158 Defining_Identifier
=> Result_Parameter
,
4159 Aliased_Present
=> True,
4160 Object_Definition
=>
4161 Make_Subtype_Indication
(Loc
,
4163 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
4165 Make_Index_Or_Discriminant_Constraint
(Loc
,
4167 New_List
(Make_Integer_Literal
(Loc
, 0))))));
4169 Exception_Return_Parameter
:=
4170 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
4173 Make_Object_Declaration
(Loc
,
4174 Defining_Identifier
=> Exception_Return_Parameter
,
4175 Object_Definition
=>
4176 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
4179 Result_Parameter
:= Empty
;
4180 Exception_Return_Parameter
:= Empty
;
4183 -- Put first the RPC receiver corresponding to the remote package
4185 Append_To
(Statements
,
4186 Make_Attribute_Reference
(Loc
,
4188 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
4189 Attribute_Name
=> Name_Write
,
4190 Expressions
=> New_List
(
4191 Make_Attribute_Reference
(Loc
,
4192 Prefix
=> New_Occurrence_Of
(Stream_Parameter
, Loc
),
4193 Attribute_Name
=> Name_Access
),
4194 Target_RPC_Receiver
)));
4196 -- Then put the Subprogram_Id of the subprogram we want to call in
4199 Append_To
(Statements
,
4200 Make_Attribute_Reference
(Loc
,
4201 Prefix
=> New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4202 Attribute_Name
=> Name_Write
,
4203 Expressions
=> New_List
(
4204 Make_Attribute_Reference
(Loc
,
4205 Prefix
=> New_Occurrence_Of
(Stream_Parameter
, Loc
),
4206 Attribute_Name
=> Name_Access
),
4209 Current_Parameter
:= First
(Ordered_Parameters_List
);
4210 while Present
(Current_Parameter
) loop
4212 Typ
: constant Node_Id
:=
4213 Parameter_Type
(Current_Parameter
);
4215 Constrained
: Boolean;
4217 Extra_Parameter
: Entity_Id
;
4220 if Is_RACW_Controlling_Formal
4221 (Current_Parameter
, Stub_Type
)
4223 -- In the case of a controlling formal argument, we marshall
4224 -- its addr field rather than the local stub.
4226 Append_To
(Statements
,
4227 Pack_Node_Into_Stream
(Loc
,
4228 Stream
=> Stream_Parameter
,
4230 Make_Selected_Component
(Loc
,
4232 Defining_Identifier
(Current_Parameter
),
4233 Selector_Name
=> Name_Addr
),
4234 Etyp
=> RTE
(RE_Unsigned_64
)));
4239 (Defining_Identifier
(Current_Parameter
), Loc
);
4241 -- Access type parameters are transmitted as in out
4242 -- parameters. However, a dereference is needed so that
4243 -- we marshall the designated object.
4245 if Nkind
(Typ
) = N_Access_Definition
then
4246 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4247 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4249 Etyp
:= Etype
(Typ
);
4252 Constrained
:= not Transmit_As_Unconstrained
(Etyp
);
4254 -- Any parameter but unconstrained out parameters are
4255 -- transmitted to the peer.
4257 if In_Present
(Current_Parameter
)
4258 or else not Out_Present
(Current_Parameter
)
4259 or else not Constrained
4261 Append_To
(Statements
,
4262 Make_Attribute_Reference
(Loc
,
4263 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4265 Output_From_Constrained
(Constrained
),
4266 Expressions
=> New_List
(
4267 Make_Attribute_Reference
(Loc
,
4269 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4270 Attribute_Name
=> Name_Access
),
4275 -- If the current parameter has a dynamic constrained status,
4276 -- then this status is transmitted as well.
4277 -- This should be done for accessibility as well ???
4279 if Nkind
(Typ
) /= N_Access_Definition
4280 and then Need_Extra_Constrained
(Current_Parameter
)
4282 -- In this block, we do not use the extra formal that has
4283 -- been created because it does not exist at the time of
4284 -- expansion when building calling stubs for remote access
4285 -- to subprogram types. We create an extra variable of this
4286 -- type and push it in the stream after the regular
4289 Extra_Parameter
:= Make_Defining_Identifier
4290 (Loc
, New_Internal_Name
('P'));
4293 Make_Object_Declaration
(Loc
,
4294 Defining_Identifier
=> Extra_Parameter
,
4295 Constant_Present
=> True,
4296 Object_Definition
=>
4297 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4299 Make_Attribute_Reference
(Loc
,
4302 Defining_Identifier
(Current_Parameter
), Loc
),
4303 Attribute_Name
=> Name_Constrained
)));
4305 Append_To
(Extra_Formal_Statements
,
4306 Make_Attribute_Reference
(Loc
,
4308 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4309 Attribute_Name
=> Name_Write
,
4310 Expressions
=> New_List
(
4311 Make_Attribute_Reference
(Loc
,
4314 (Stream_Parameter
, Loc
), Attribute_Name
=>
4316 New_Occurrence_Of
(Extra_Parameter
, Loc
))));
4319 Next
(Current_Parameter
);
4323 -- Append the formal statements list to the statements
4325 Append_List_To
(Statements
, Extra_Formal_Statements
);
4327 if not Is_Known_Non_Asynchronous
then
4329 -- Build the call to System.RPC.Do_APC
4331 Asynchronous_Statements
:= New_List
(
4332 Make_Procedure_Call_Statement
(Loc
,
4334 New_Occurrence_Of
(RTE
(RE_Do_Apc
), Loc
),
4335 Parameter_Associations
=> New_List
(
4336 New_Occurrence_Of
(Target_Partition
, Loc
),
4337 Make_Attribute_Reference
(Loc
,
4339 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4340 Attribute_Name
=> Name_Access
))));
4342 Asynchronous_Statements
:= No_List
;
4345 if not Is_Known_Asynchronous
then
4347 -- Build the call to System.RPC.Do_RPC
4349 Non_Asynchronous_Statements
:= New_List
(
4350 Make_Procedure_Call_Statement
(Loc
,
4352 New_Occurrence_Of
(RTE
(RE_Do_Rpc
), Loc
),
4353 Parameter_Associations
=> New_List
(
4354 New_Occurrence_Of
(Target_Partition
, Loc
),
4356 Make_Attribute_Reference
(Loc
,
4358 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4359 Attribute_Name
=> Name_Access
),
4361 Make_Attribute_Reference
(Loc
,
4363 New_Occurrence_Of
(Result_Parameter
, Loc
),
4364 Attribute_Name
=> Name_Access
))));
4366 -- Read the exception occurrence from the result stream and
4367 -- reraise it. It does no harm if this is a Null_Occurrence since
4368 -- this does nothing.
4370 Append_To
(Non_Asynchronous_Statements
,
4371 Make_Attribute_Reference
(Loc
,
4373 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4375 Attribute_Name
=> Name_Read
,
4377 Expressions
=> New_List
(
4378 Make_Attribute_Reference
(Loc
,
4380 New_Occurrence_Of
(Result_Parameter
, Loc
),
4381 Attribute_Name
=> Name_Access
),
4382 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
4384 Append_To
(Non_Asynchronous_Statements
,
4385 Make_Procedure_Call_Statement
(Loc
,
4387 New_Occurrence_Of
(RTE
(RE_Reraise_Occurrence
), Loc
),
4388 Parameter_Associations
=> New_List
(
4389 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
4393 -- If this is a function call, then read the value and return
4394 -- it. The return value is written/read using 'Output/'Input.
4396 Append_To
(Non_Asynchronous_Statements
,
4397 Make_Tag_Check
(Loc
,
4398 Make_Simple_Return_Statement
(Loc
,
4400 Make_Attribute_Reference
(Loc
,
4403 Etype
(Result_Definition
(Spec
)), Loc
),
4405 Attribute_Name
=> Name_Input
,
4407 Expressions
=> New_List
(
4408 Make_Attribute_Reference
(Loc
,
4410 New_Occurrence_Of
(Result_Parameter
, Loc
),
4411 Attribute_Name
=> Name_Access
))))));
4414 -- Loop around parameters and assign out (or in out)
4415 -- parameters. In the case of RACW, controlling arguments
4416 -- cannot possibly have changed since they are remote, so we do
4417 -- not read them from the stream.
4419 Current_Parameter
:= First
(Ordered_Parameters_List
);
4420 while Present
(Current_Parameter
) loop
4422 Typ
: constant Node_Id
:=
4423 Parameter_Type
(Current_Parameter
);
4430 (Defining_Identifier
(Current_Parameter
), Loc
);
4432 if Nkind
(Typ
) = N_Access_Definition
then
4433 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4434 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4436 Etyp
:= Etype
(Typ
);
4439 if (Out_Present
(Current_Parameter
)
4440 or else Nkind
(Typ
) = N_Access_Definition
)
4441 and then Etyp
/= Stub_Type
4443 Append_To
(Non_Asynchronous_Statements
,
4444 Make_Attribute_Reference
(Loc
,
4446 New_Occurrence_Of
(Etyp
, Loc
),
4448 Attribute_Name
=> Name_Read
,
4450 Expressions
=> New_List
(
4451 Make_Attribute_Reference
(Loc
,
4453 New_Occurrence_Of
(Result_Parameter
, Loc
),
4454 Attribute_Name
=> Name_Access
),
4459 Next
(Current_Parameter
);
4464 if Is_Known_Asynchronous
then
4465 Append_List_To
(Statements
, Asynchronous_Statements
);
4467 elsif Is_Known_Non_Asynchronous
then
4468 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
4471 pragma Assert
(Present
(Asynchronous
));
4472 Prepend_To
(Asynchronous_Statements
,
4473 Make_Attribute_Reference
(Loc
,
4474 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4475 Attribute_Name
=> Name_Write
,
4476 Expressions
=> New_List
(
4477 Make_Attribute_Reference
(Loc
,
4479 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4480 Attribute_Name
=> Name_Access
),
4481 New_Occurrence_Of
(Standard_True
, Loc
))));
4483 Prepend_To
(Non_Asynchronous_Statements
,
4484 Make_Attribute_Reference
(Loc
,
4485 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4486 Attribute_Name
=> Name_Write
,
4487 Expressions
=> New_List
(
4488 Make_Attribute_Reference
(Loc
,
4490 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4491 Attribute_Name
=> Name_Access
),
4492 New_Occurrence_Of
(Standard_False
, Loc
))));
4494 Append_To
(Statements
,
4495 Make_Implicit_If_Statement
(Nod
,
4496 Condition
=> Asynchronous
,
4497 Then_Statements
=> Asynchronous_Statements
,
4498 Else_Statements
=> Non_Asynchronous_Statements
));
4500 end Build_General_Calling_Stubs
;
4502 -----------------------------
4503 -- Build_RPC_Receiver_Body --
4504 -----------------------------
4506 procedure Build_RPC_Receiver_Body
4507 (RPC_Receiver
: Entity_Id
;
4508 Request
: out Entity_Id
;
4509 Subp_Id
: out Entity_Id
;
4510 Subp_Index
: out Entity_Id
;
4511 Stmts
: out List_Id
;
4514 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
4516 RPC_Receiver_Spec
: Node_Id
;
4517 RPC_Receiver_Decls
: List_Id
;
4520 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
4522 RPC_Receiver_Spec
:=
4523 Build_RPC_Receiver_Specification
4524 (RPC_Receiver
=> RPC_Receiver
,
4525 Request_Parameter
=> Request
);
4527 Subp_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4528 Subp_Index
:= Subp_Id
;
4530 -- Subp_Id may not be a constant, because in the case of the RPC
4531 -- receiver for an RCI package, when a call is received from a RAS
4532 -- dereference, it will be assigned during subsequent processing.
4534 RPC_Receiver_Decls
:= New_List
(
4535 Make_Object_Declaration
(Loc
,
4536 Defining_Identifier
=> Subp_Id
,
4537 Object_Definition
=>
4538 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4540 Make_Attribute_Reference
(Loc
,
4542 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4543 Attribute_Name
=> Name_Input
,
4544 Expressions
=> New_List
(
4545 Make_Selected_Component
(Loc
,
4547 Selector_Name
=> Name_Params
)))));
4552 Make_Subprogram_Body
(Loc
,
4553 Specification
=> RPC_Receiver_Spec
,
4554 Declarations
=> RPC_Receiver_Decls
,
4555 Handled_Statement_Sequence
=>
4556 Make_Handled_Sequence_Of_Statements
(Loc
,
4557 Statements
=> Stmts
));
4558 end Build_RPC_Receiver_Body
;
4560 -----------------------
4561 -- Build_Stub_Target --
4562 -----------------------
4564 function Build_Stub_Target
4567 RCI_Locator
: Entity_Id
;
4568 Controlling_Parameter
: Entity_Id
) return RPC_Target
4570 Target_Info
: RPC_Target
(PCS_Kind
=> Name_GARLIC_DSA
);
4572 Target_Info
.Partition
:=
4573 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4574 if Present
(Controlling_Parameter
) then
4576 Make_Object_Declaration
(Loc
,
4577 Defining_Identifier
=> Target_Info
.Partition
,
4578 Constant_Present
=> True,
4579 Object_Definition
=>
4580 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4583 Make_Selected_Component
(Loc
,
4584 Prefix
=> Controlling_Parameter
,
4585 Selector_Name
=> Name_Origin
)));
4587 Target_Info
.RPC_Receiver
:=
4588 Make_Selected_Component
(Loc
,
4589 Prefix
=> Controlling_Parameter
,
4590 Selector_Name
=> Name_Receiver
);
4594 Make_Object_Declaration
(Loc
,
4595 Defining_Identifier
=> Target_Info
.Partition
,
4596 Constant_Present
=> True,
4597 Object_Definition
=>
4598 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4601 Make_Function_Call
(Loc
,
4602 Name
=> Make_Selected_Component
(Loc
,
4604 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4606 Make_Identifier
(Loc
,
4607 Name_Get_Active_Partition_ID
)))));
4609 Target_Info
.RPC_Receiver
:=
4610 Make_Selected_Component
(Loc
,
4612 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4614 Make_Identifier
(Loc
, Name_Get_RCI_Package_Receiver
));
4617 end Build_Stub_Target
;
4619 ---------------------
4620 -- Build_Stub_Type --
4621 ---------------------
4623 procedure Build_Stub_Type
4624 (RACW_Type
: Entity_Id
;
4625 Stub_Type
: Entity_Id
;
4626 Stub_Type_Decl
: out Node_Id
;
4627 RPC_Receiver_Decl
: out Node_Id
)
4629 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
4630 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
4634 Make_Full_Type_Declaration
(Loc
,
4635 Defining_Identifier
=> Stub_Type
,
4637 Make_Record_Definition
(Loc
,
4638 Tagged_Present
=> True,
4639 Limited_Present
=> True,
4641 Make_Component_List
(Loc
,
4642 Component_Items
=> New_List
(
4644 Make_Component_Declaration
(Loc
,
4645 Defining_Identifier
=>
4646 Make_Defining_Identifier
(Loc
, Name_Origin
),
4647 Component_Definition
=>
4648 Make_Component_Definition
(Loc
,
4649 Aliased_Present
=> False,
4650 Subtype_Indication
=>
4652 RTE
(RE_Partition_ID
), Loc
))),
4654 Make_Component_Declaration
(Loc
,
4655 Defining_Identifier
=>
4656 Make_Defining_Identifier
(Loc
, Name_Receiver
),
4657 Component_Definition
=>
4658 Make_Component_Definition
(Loc
,
4659 Aliased_Present
=> False,
4660 Subtype_Indication
=>
4661 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4663 Make_Component_Declaration
(Loc
,
4664 Defining_Identifier
=>
4665 Make_Defining_Identifier
(Loc
, Name_Addr
),
4666 Component_Definition
=>
4667 Make_Component_Definition
(Loc
,
4668 Aliased_Present
=> False,
4669 Subtype_Indication
=>
4670 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4672 Make_Component_Declaration
(Loc
,
4673 Defining_Identifier
=>
4674 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
4675 Component_Definition
=>
4676 Make_Component_Definition
(Loc
,
4677 Aliased_Present
=> False,
4678 Subtype_Indication
=>
4680 Standard_Boolean
, Loc
)))))));
4683 RPC_Receiver_Decl
:= Empty
;
4686 RPC_Receiver_Request
: constant Entity_Id
:=
4687 Make_Defining_Identifier
(Loc
, Name_R
);
4689 RPC_Receiver_Decl
:=
4690 Make_Subprogram_Declaration
(Loc
,
4691 Build_RPC_Receiver_Specification
(
4692 RPC_Receiver
=> Make_Defining_Identifier
(Loc
,
4693 New_Internal_Name
('R')),
4694 Request_Parameter
=> RPC_Receiver_Request
));
4697 end Build_Stub_Type
;
4699 --------------------------------------
4700 -- Build_Subprogram_Receiving_Stubs --
4701 --------------------------------------
4703 function Build_Subprogram_Receiving_Stubs
4704 (Vis_Decl
: Node_Id
;
4705 Asynchronous
: Boolean;
4706 Dynamically_Asynchronous
: Boolean := False;
4707 Stub_Type
: Entity_Id
:= Empty
;
4708 RACW_Type
: Entity_Id
:= Empty
;
4709 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
4711 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
4713 Request_Parameter
: constant Entity_Id
:=
4714 Make_Defining_Identifier
(Loc
,
4715 New_Internal_Name
('R'));
4716 -- Formal parameter for receiving stubs: a descriptor for an incoming
4719 Decls
: constant List_Id
:= New_List
;
4720 -- All the parameters will get declared before calling the real
4721 -- subprograms. Also the out parameters will be declared.
4723 Statements
: constant List_Id
:= New_List
;
4725 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4726 -- Statements concerning extra formal parameters
4728 After_Statements
: constant List_Id
:= New_List
;
4729 -- Statements to be executed after the subprogram call
4731 Inner_Decls
: List_Id
:= No_List
;
4732 -- In case of a function, the inner declarations are needed since
4733 -- the result may be unconstrained.
4735 Excep_Handlers
: List_Id
:= No_List
;
4736 Excep_Choice
: Entity_Id
;
4737 Excep_Code
: List_Id
;
4739 Parameter_List
: constant List_Id
:= New_List
;
4740 -- List of parameters to be passed to the subprogram
4742 Current_Parameter
: Node_Id
;
4744 Ordered_Parameters_List
: constant List_Id
:=
4745 Build_Ordered_Parameters_List
4746 (Specification
(Vis_Decl
));
4748 Subp_Spec
: Node_Id
;
4749 -- Subprogram specification
4751 Called_Subprogram
: Node_Id
;
4752 -- The subprogram to call
4754 Null_Raise_Statement
: Node_Id
;
4756 Dynamic_Async
: Entity_Id
;
4759 if Present
(RACW_Type
) then
4760 Called_Subprogram
:= New_Occurrence_Of
(Parent_Primitive
, Loc
);
4762 Called_Subprogram
:=
4764 (Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
4767 if Dynamically_Asynchronous
then
4769 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
4771 Dynamic_Async
:= Empty
;
4774 if not Asynchronous
or Dynamically_Asynchronous
then
4776 -- The first statement after the subprogram call is a statement to
4777 -- write a Null_Occurrence into the result stream.
4779 Null_Raise_Statement
:=
4780 Make_Attribute_Reference
(Loc
,
4782 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4783 Attribute_Name
=> Name_Write
,
4784 Expressions
=> New_List
(
4785 Make_Selected_Component
(Loc
,
4786 Prefix
=> Request_Parameter
,
4787 Selector_Name
=> Name_Result
),
4788 New_Occurrence_Of
(RTE
(RE_Null_Occurrence
), Loc
)));
4790 if Dynamically_Asynchronous
then
4791 Null_Raise_Statement
:=
4792 Make_Implicit_If_Statement
(Vis_Decl
,
4794 Make_Op_Not
(Loc
, New_Occurrence_Of
(Dynamic_Async
, Loc
)),
4795 Then_Statements
=> New_List
(Null_Raise_Statement
));
4798 Append_To
(After_Statements
, Null_Raise_Statement
);
4801 -- Loop through every parameter and get its value from the stream. If
4802 -- the parameter is unconstrained, then the parameter is read using
4803 -- 'Input at the point of declaration.
4805 Current_Parameter
:= First
(Ordered_Parameters_List
);
4806 while Present
(Current_Parameter
) loop
4809 Constrained
: Boolean;
4811 Need_Extra_Constrained
: Boolean;
4812 -- True when an Extra_Constrained actual is required
4814 Object
: constant Entity_Id
:=
4815 Make_Defining_Identifier
(Loc
,
4816 New_Internal_Name
('P'));
4818 Expr
: Node_Id
:= Empty
;
4820 Is_Controlling_Formal
: constant Boolean :=
4821 Is_RACW_Controlling_Formal
4822 (Current_Parameter
, Stub_Type
);
4825 if Is_Controlling_Formal
then
4827 -- We have a controlling formal parameter. Read its address
4828 -- rather than a real object. The address is in Unsigned_64
4831 Etyp
:= RTE
(RE_Unsigned_64
);
4833 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
4836 Constrained
:= not Transmit_As_Unconstrained
(Etyp
);
4838 if In_Present
(Current_Parameter
)
4839 or else not Out_Present
(Current_Parameter
)
4840 or else not Constrained
4841 or else Is_Controlling_Formal
4843 -- If an input parameter is constrained, then the read of
4844 -- the parameter is deferred until the beginning of the
4845 -- subprogram body. If it is unconstrained, then an
4846 -- expression is built for the object declaration and the
4847 -- variable is set using 'Input instead of 'Read. Note that
4848 -- this deferral does not change the order in which the
4849 -- actuals are read because Build_Ordered_Parameter_List
4850 -- puts them unconstrained first.
4853 Append_To
(Statements
,
4854 Make_Attribute_Reference
(Loc
,
4855 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4856 Attribute_Name
=> Name_Read
,
4857 Expressions
=> New_List
(
4858 Make_Selected_Component
(Loc
,
4859 Prefix
=> Request_Parameter
,
4860 Selector_Name
=> Name_Params
),
4861 New_Occurrence_Of
(Object
, Loc
))));
4865 -- Build and append Input_With_Tag_Check function
4868 Input_With_Tag_Check
(Loc
,
4871 Make_Selected_Component
(Loc
,
4872 Prefix
=> Request_Parameter
,
4873 Selector_Name
=> Name_Params
)));
4875 -- Prepare function call expression
4878 Make_Function_Call
(Loc
,
4882 (Specification
(Last
(Decls
))), Loc
));
4886 Need_Extra_Constrained
:=
4887 Nkind
(Parameter_Type
(Current_Parameter
)) /=
4890 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
4892 Present
(Extra_Constrained
4893 (Defining_Identifier
(Current_Parameter
)));
4895 -- We may not associate an extra constrained actual to a
4896 -- constant object, so if one is needed, declare the actual
4897 -- as a variable even if it won't be modified.
4899 Build_Actual_Object_Declaration
4902 Variable
=> Need_Extra_Constrained
4903 or else Out_Present
(Current_Parameter
),
4907 -- An out parameter may be written back using a 'Write
4908 -- attribute instead of a 'Output because it has been
4909 -- constrained by the parameter given to the caller. Note that
4910 -- out controlling arguments in the case of a RACW are not put
4911 -- back in the stream because the pointer on them has not
4914 if Out_Present
(Current_Parameter
)
4916 Etype
(Parameter_Type
(Current_Parameter
)) /= Stub_Type
4918 Append_To
(After_Statements
,
4919 Make_Attribute_Reference
(Loc
,
4920 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4921 Attribute_Name
=> Name_Write
,
4922 Expressions
=> New_List
(
4923 Make_Selected_Component
(Loc
,
4924 Prefix
=> Request_Parameter
,
4925 Selector_Name
=> Name_Result
),
4926 New_Occurrence_Of
(Object
, Loc
))));
4929 -- For RACW controlling formals, the Etyp of Object is always
4930 -- an RACW, even if the parameter is not of an anonymous access
4931 -- type. In such case, we need to dereference it at call time.
4933 if Is_Controlling_Formal
then
4934 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
4937 Append_To
(Parameter_List
,
4938 Make_Parameter_Association
(Loc
,
4941 Defining_Identifier
(Current_Parameter
), Loc
),
4942 Explicit_Actual_Parameter
=>
4943 Make_Explicit_Dereference
(Loc
,
4944 Unchecked_Convert_To
(RACW_Type
,
4945 OK_Convert_To
(RTE
(RE_Address
),
4946 New_Occurrence_Of
(Object
, Loc
))))));
4949 Append_To
(Parameter_List
,
4950 Make_Parameter_Association
(Loc
,
4953 Defining_Identifier
(Current_Parameter
), Loc
),
4954 Explicit_Actual_Parameter
=>
4955 Unchecked_Convert_To
(RACW_Type
,
4956 OK_Convert_To
(RTE
(RE_Address
),
4957 New_Occurrence_Of
(Object
, Loc
)))));
4961 Append_To
(Parameter_List
,
4962 Make_Parameter_Association
(Loc
,
4965 Defining_Identifier
(Current_Parameter
), Loc
),
4966 Explicit_Actual_Parameter
=>
4967 New_Occurrence_Of
(Object
, Loc
)));
4970 -- If the current parameter needs an extra formal, then read it
4971 -- from the stream and set the corresponding semantic field in
4972 -- the variable. If the kind of the parameter identifier is
4973 -- E_Void, then this is a compiler generated parameter that
4974 -- doesn't need an extra constrained status.
4976 -- The case of Extra_Accessibility should also be handled ???
4978 if Need_Extra_Constrained
then
4980 Extra_Parameter
: constant Entity_Id
:=
4982 (Defining_Identifier
4983 (Current_Parameter
));
4985 Formal_Entity
: constant Entity_Id
:=
4986 Make_Defining_Identifier
4987 (Loc
, Chars
(Extra_Parameter
));
4989 Formal_Type
: constant Entity_Id
:=
4990 Etype
(Extra_Parameter
);
4994 Make_Object_Declaration
(Loc
,
4995 Defining_Identifier
=> Formal_Entity
,
4996 Object_Definition
=>
4997 New_Occurrence_Of
(Formal_Type
, Loc
)));
4999 Append_To
(Extra_Formal_Statements
,
5000 Make_Attribute_Reference
(Loc
,
5001 Prefix
=> New_Occurrence_Of
(
5003 Attribute_Name
=> Name_Read
,
5004 Expressions
=> New_List
(
5005 Make_Selected_Component
(Loc
,
5006 Prefix
=> Request_Parameter
,
5007 Selector_Name
=> Name_Params
),
5008 New_Occurrence_Of
(Formal_Entity
, Loc
))));
5010 -- Note: the call to Set_Extra_Constrained below relies
5011 -- on the fact that Object's Ekind has been set by
5012 -- Build_Actual_Object_Declaration.
5014 Set_Extra_Constrained
(Object
, Formal_Entity
);
5019 Next
(Current_Parameter
);
5022 -- Append the formal statements list at the end of regular statements
5024 Append_List_To
(Statements
, Extra_Formal_Statements
);
5026 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
5028 -- The remote subprogram is a function. We build an inner block to
5029 -- be able to hold a potentially unconstrained result in a
5033 Etyp
: constant Entity_Id
:=
5034 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
5035 Result
: constant Node_Id
:=
5036 Make_Defining_Identifier
(Loc
,
5037 New_Internal_Name
('R'));
5039 Inner_Decls
:= New_List
(
5040 Make_Object_Declaration
(Loc
,
5041 Defining_Identifier
=> Result
,
5042 Constant_Present
=> True,
5043 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
5045 Make_Function_Call
(Loc
,
5046 Name
=> Called_Subprogram
,
5047 Parameter_Associations
=> Parameter_List
)));
5049 if Is_Class_Wide_Type
(Etyp
) then
5051 -- For a remote call to a function with a class-wide type,
5052 -- check that the returned value satisfies the requirements
5055 Append_To
(Inner_Decls
,
5056 Make_Transportable_Check
(Loc
,
5057 New_Occurrence_Of
(Result
, Loc
)));
5061 Append_To
(After_Statements
,
5062 Make_Attribute_Reference
(Loc
,
5063 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5064 Attribute_Name
=> Name_Output
,
5065 Expressions
=> New_List
(
5066 Make_Selected_Component
(Loc
,
5067 Prefix
=> Request_Parameter
,
5068 Selector_Name
=> Name_Result
),
5069 New_Occurrence_Of
(Result
, Loc
))));
5072 Append_To
(Statements
,
5073 Make_Block_Statement
(Loc
,
5074 Declarations
=> Inner_Decls
,
5075 Handled_Statement_Sequence
=>
5076 Make_Handled_Sequence_Of_Statements
(Loc
,
5077 Statements
=> After_Statements
)));
5080 -- The remote subprogram is a procedure. We do not need any inner
5081 -- block in this case.
5083 if Dynamically_Asynchronous
then
5085 Make_Object_Declaration
(Loc
,
5086 Defining_Identifier
=> Dynamic_Async
,
5087 Object_Definition
=>
5088 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
5090 Append_To
(Statements
,
5091 Make_Attribute_Reference
(Loc
,
5092 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
5093 Attribute_Name
=> Name_Read
,
5094 Expressions
=> New_List
(
5095 Make_Selected_Component
(Loc
,
5096 Prefix
=> Request_Parameter
,
5097 Selector_Name
=> Name_Params
),
5098 New_Occurrence_Of
(Dynamic_Async
, Loc
))));
5101 Append_To
(Statements
,
5102 Make_Procedure_Call_Statement
(Loc
,
5103 Name
=> Called_Subprogram
,
5104 Parameter_Associations
=> Parameter_List
));
5106 Append_List_To
(Statements
, After_Statements
);
5109 if Asynchronous
and then not Dynamically_Asynchronous
then
5111 -- For an asynchronous procedure, add a null exception handler
5113 Excep_Handlers
:= New_List
(
5114 Make_Implicit_Exception_Handler
(Loc
,
5115 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5116 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
5119 -- In the other cases, if an exception is raised, then the
5120 -- exception occurrence is copied into the output stream and
5121 -- no other output parameter is written.
5124 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
5126 Excep_Code
:= New_List
(
5127 Make_Attribute_Reference
(Loc
,
5129 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
5130 Attribute_Name
=> Name_Write
,
5131 Expressions
=> New_List
(
5132 Make_Selected_Component
(Loc
,
5133 Prefix
=> Request_Parameter
,
5134 Selector_Name
=> Name_Result
),
5135 New_Occurrence_Of
(Excep_Choice
, Loc
))));
5137 if Dynamically_Asynchronous
then
5138 Excep_Code
:= New_List
(
5139 Make_Implicit_If_Statement
(Vis_Decl
,
5140 Condition
=> Make_Op_Not
(Loc
,
5141 New_Occurrence_Of
(Dynamic_Async
, Loc
)),
5142 Then_Statements
=> Excep_Code
));
5145 Excep_Handlers
:= New_List
(
5146 Make_Implicit_Exception_Handler
(Loc
,
5147 Choice_Parameter
=> Excep_Choice
,
5148 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5149 Statements
=> Excep_Code
));
5154 Make_Procedure_Specification
(Loc
,
5155 Defining_Unit_Name
=>
5156 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
5158 Parameter_Specifications
=> New_List
(
5159 Make_Parameter_Specification
(Loc
,
5160 Defining_Identifier
=> Request_Parameter
,
5162 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
5165 Make_Subprogram_Body
(Loc
,
5166 Specification
=> Subp_Spec
,
5167 Declarations
=> Decls
,
5168 Handled_Statement_Sequence
=>
5169 Make_Handled_Sequence_Of_Statements
(Loc
,
5170 Statements
=> Statements
,
5171 Exception_Handlers
=> Excep_Handlers
));
5172 end Build_Subprogram_Receiving_Stubs
;
5178 function Result
return Node_Id
is
5180 return Make_Identifier
(Loc
, Name_V
);
5183 ----------------------
5184 -- Stream_Parameter --
5185 ----------------------
5187 function Stream_Parameter
return Node_Id
is
5189 return Make_Identifier
(Loc
, Name_S
);
5190 end Stream_Parameter
;
5194 -------------------------------
5195 -- Get_And_Reset_RACW_Bodies --
5196 -------------------------------
5198 function Get_And_Reset_RACW_Bodies
(RACW_Type
: Entity_Id
) return List_Id
is
5199 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
5200 Stub_Elements
: Stub_Structure
:= Stubs_Table
.Get
(Desig
);
5202 Body_Decls
: List_Id
;
5203 -- Returned list of declarations
5206 if Stub_Elements
= Empty_Stub_Structure
then
5208 -- Stub elements may be missing as a consequence of a previously
5214 Body_Decls
:= Stub_Elements
.Body_Decls
;
5215 Stub_Elements
.Body_Decls
:= No_List
;
5216 Stubs_Table
.Set
(Desig
, Stub_Elements
);
5218 end Get_And_Reset_RACW_Bodies
;
5220 -----------------------
5221 -- Get_Stub_Elements --
5222 -----------------------
5224 function Get_Stub_Elements
(RACW_Type
: Entity_Id
) return Stub_Structure
is
5225 Desig
: constant Entity_Id
:=
5226 Etype
(Designated_Type
(RACW_Type
));
5227 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
5229 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5230 return Stub_Elements
;
5231 end Get_Stub_Elements
;
5233 -----------------------
5234 -- Get_Subprogram_Id --
5235 -----------------------
5237 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
is
5238 Result
: constant String_Id
:= Get_Subprogram_Ids
(Def
).Str_Identifier
;
5240 pragma Assert
(Result
/= No_String
);
5242 end Get_Subprogram_Id
;
5244 -----------------------
5245 -- Get_Subprogram_Id --
5246 -----------------------
5248 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
is
5250 return Get_Subprogram_Ids
(Def
).Int_Identifier
;
5251 end Get_Subprogram_Id
;
5253 ------------------------
5254 -- Get_Subprogram_Ids --
5255 ------------------------
5257 function Get_Subprogram_Ids
5258 (Def
: Entity_Id
) return Subprogram_Identifiers
5261 return Subprogram_Identifier_Table
.Get
(Def
);
5262 end Get_Subprogram_Ids
;
5268 function Hash
(F
: Entity_Id
) return Hash_Index
is
5270 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
5273 function Hash
(F
: Name_Id
) return Hash_Index
is
5275 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
5278 --------------------------
5279 -- Input_With_Tag_Check --
5280 --------------------------
5282 function Input_With_Tag_Check
5284 Var_Type
: Entity_Id
;
5285 Stream
: Node_Id
) return Node_Id
5289 Make_Subprogram_Body
(Loc
,
5290 Specification
=> Make_Function_Specification
(Loc
,
5291 Defining_Unit_Name
=>
5292 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S')),
5293 Result_Definition
=> New_Occurrence_Of
(Var_Type
, Loc
)),
5294 Declarations
=> No_List
,
5295 Handled_Statement_Sequence
=>
5296 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
5297 Make_Tag_Check
(Loc
,
5298 Make_Simple_Return_Statement
(Loc
,
5299 Make_Attribute_Reference
(Loc
,
5300 Prefix
=> New_Occurrence_Of
(Var_Type
, Loc
),
5301 Attribute_Name
=> Name_Input
,
5303 New_List
(Stream
)))))));
5304 end Input_With_Tag_Check
;
5306 --------------------------------
5307 -- Is_RACW_Controlling_Formal --
5308 --------------------------------
5310 function Is_RACW_Controlling_Formal
5311 (Parameter
: Node_Id
;
5312 Stub_Type
: Entity_Id
) return Boolean
5317 -- If the kind of the parameter is E_Void, then it is not a
5318 -- controlling formal (this can happen in the context of RAS).
5320 if Ekind
(Defining_Identifier
(Parameter
)) = E_Void
then
5324 -- If the parameter is not a controlling formal, then it cannot
5325 -- be possibly a RACW_Controlling_Formal.
5327 if not Is_Controlling_Formal
(Defining_Identifier
(Parameter
)) then
5331 Typ
:= Parameter_Type
(Parameter
);
5332 return (Nkind
(Typ
) = N_Access_Definition
5333 and then Etype
(Subtype_Mark
(Typ
)) = Stub_Type
)
5334 or else Etype
(Typ
) = Stub_Type
;
5335 end Is_RACW_Controlling_Formal
;
5337 ------------------------------
5338 -- Make_Transportable_Check --
5339 ------------------------------
5341 function Make_Transportable_Check
5343 Expr
: Node_Id
) return Node_Id
is
5346 Make_Raise_Program_Error
(Loc
,
5349 Build_Get_Transportable
(Loc
,
5350 Make_Selected_Component
(Loc
,
5352 Selector_Name
=> Make_Identifier
(Loc
, Name_uTag
)))),
5353 Reason
=> PE_Non_Transportable_Actual
);
5354 end Make_Transportable_Check
;
5356 -----------------------------
5357 -- Make_Selected_Component --
5358 -----------------------------
5360 function Make_Selected_Component
5363 Selector_Name
: Name_Id
) return Node_Id
5366 return Make_Selected_Component
(Loc
,
5367 Prefix
=> New_Occurrence_Of
(Prefix
, Loc
),
5368 Selector_Name
=> Make_Identifier
(Loc
, Selector_Name
));
5369 end Make_Selected_Component
;
5371 --------------------
5372 -- Make_Tag_Check --
5373 --------------------
5375 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
is
5376 Occ
: constant Entity_Id
:=
5377 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
5380 return Make_Block_Statement
(Loc
,
5381 Handled_Statement_Sequence
=>
5382 Make_Handled_Sequence_Of_Statements
(Loc
,
5383 Statements
=> New_List
(N
),
5385 Exception_Handlers
=> New_List
(
5386 Make_Implicit_Exception_Handler
(Loc
,
5387 Choice_Parameter
=> Occ
,
5389 Exception_Choices
=>
5390 New_List
(New_Occurrence_Of
(RTE
(RE_Tag_Error
), Loc
)),
5393 New_List
(Make_Procedure_Call_Statement
(Loc
,
5395 (RTE
(RE_Raise_Program_Error_Unknown_Tag
), Loc
),
5396 New_List
(New_Occurrence_Of
(Occ
, Loc
))))))));
5399 ----------------------------
5400 -- Need_Extra_Constrained --
5401 ----------------------------
5403 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean is
5404 Etyp
: constant Entity_Id
:= Etype
(Parameter_Type
(Parameter
));
5406 return Out_Present
(Parameter
)
5407 and then Has_Discriminants
(Etyp
)
5408 and then not Is_Constrained
(Etyp
)
5409 and then not Is_Indefinite_Subtype
(Etyp
);
5410 end Need_Extra_Constrained
;
5412 ------------------------------------
5413 -- Pack_Entity_Into_Stream_Access --
5414 ------------------------------------
5416 function Pack_Entity_Into_Stream_Access
5420 Etyp
: Entity_Id
:= Empty
) return Node_Id
5425 if Present
(Etyp
) then
5428 Typ
:= Etype
(Object
);
5432 Pack_Node_Into_Stream_Access
(Loc
,
5434 Object
=> New_Occurrence_Of
(Object
, Loc
),
5436 end Pack_Entity_Into_Stream_Access
;
5438 ---------------------------
5439 -- Pack_Node_Into_Stream --
5440 ---------------------------
5442 function Pack_Node_Into_Stream
5446 Etyp
: Entity_Id
) return Node_Id
5448 Write_Attribute
: Name_Id
:= Name_Write
;
5451 if not Is_Constrained
(Etyp
) then
5452 Write_Attribute
:= Name_Output
;
5456 Make_Attribute_Reference
(Loc
,
5457 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5458 Attribute_Name
=> Write_Attribute
,
5459 Expressions
=> New_List
(
5460 Make_Attribute_Reference
(Loc
,
5461 Prefix
=> New_Occurrence_Of
(Stream
, Loc
),
5462 Attribute_Name
=> Name_Access
),
5464 end Pack_Node_Into_Stream
;
5466 ----------------------------------
5467 -- Pack_Node_Into_Stream_Access --
5468 ----------------------------------
5470 function Pack_Node_Into_Stream_Access
5474 Etyp
: Entity_Id
) return Node_Id
5476 Write_Attribute
: Name_Id
:= Name_Write
;
5479 if not Is_Constrained
(Etyp
) then
5480 Write_Attribute
:= Name_Output
;
5484 Make_Attribute_Reference
(Loc
,
5485 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5486 Attribute_Name
=> Write_Attribute
,
5487 Expressions
=> New_List
(
5490 end Pack_Node_Into_Stream_Access
;
5492 ---------------------
5493 -- PolyORB_Support --
5494 ---------------------
5496 package body PolyORB_Support
is
5498 -- Local subprograms
5500 procedure Add_RACW_Read_Attribute
5501 (RACW_Type
: Entity_Id
;
5502 Stub_Type
: Entity_Id
;
5503 Stub_Type_Access
: Entity_Id
;
5504 Body_Decls
: List_Id
);
5505 -- Add Read attribute for the RACW type. The declaration and attribute
5506 -- definition clauses are inserted right after the declaration of
5507 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5508 -- appended to it (case where the RACW declaration is in the main unit).
5510 procedure Add_RACW_Write_Attribute
5511 (RACW_Type
: Entity_Id
;
5512 Stub_Type
: Entity_Id
;
5513 Stub_Type_Access
: Entity_Id
;
5514 Body_Decls
: List_Id
);
5515 -- Same as above for the Write attribute
5517 procedure Add_RACW_From_Any
5518 (RACW_Type
: Entity_Id
;
5519 Body_Decls
: List_Id
);
5520 -- Add the From_Any TSS for this RACW type
5522 procedure Add_RACW_To_Any
5523 (RACW_Type
: Entity_Id
;
5524 Body_Decls
: List_Id
);
5525 -- Add the To_Any TSS for this RACW type
5527 procedure Add_RACW_TypeCode
5528 (Designated_Type
: Entity_Id
;
5529 RACW_Type
: Entity_Id
;
5530 Body_Decls
: List_Id
);
5531 -- Add the TypeCode TSS for this RACW type
5533 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
);
5534 -- Add the From_Any TSS for this RAS type
5536 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
);
5537 -- Add the To_Any TSS for this RAS type
5539 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
);
5540 -- Add the TypeCode TSS for this RAS type
5542 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
5543 -- Add a subprogram body for RAS Access TSS
5545 -------------------------------------
5546 -- Add_Obj_RPC_Receiver_Completion --
5547 -------------------------------------
5549 procedure Add_Obj_RPC_Receiver_Completion
5552 RPC_Receiver
: Entity_Id
;
5553 Stub_Elements
: Stub_Structure
)
5555 Desig
: constant Entity_Id
:=
5556 Etype
(Designated_Type
(Stub_Elements
.RACW_Type
));
5559 Make_Procedure_Call_Statement
(Loc
,
5562 RTE
(RE_Register_Obj_Receiving_Stub
), Loc
),
5564 Parameter_Associations
=> New_List
(
5568 Make_String_Literal
(Loc
,
5569 Full_Qualified_Name
(Desig
)),
5573 Make_Attribute_Reference
(Loc
,
5576 Defining_Unit_Name
(Parent
(RPC_Receiver
)), Loc
),
5582 Make_Attribute_Reference
(Loc
,
5585 Defining_Identifier
(
5586 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5589 end Add_Obj_RPC_Receiver_Completion
;
5591 -----------------------
5592 -- Add_RACW_Features --
5593 -----------------------
5595 procedure Add_RACW_Features
5596 (RACW_Type
: Entity_Id
;
5598 Stub_Type
: Entity_Id
;
5599 Stub_Type_Access
: Entity_Id
;
5600 RPC_Receiver_Decl
: Node_Id
;
5601 Body_Decls
: List_Id
)
5603 pragma Warnings
(Off
);
5604 pragma Unreferenced
(RPC_Receiver_Decl
);
5605 pragma Warnings
(On
);
5609 (RACW_Type
=> RACW_Type
,
5610 Body_Decls
=> Body_Decls
);
5613 (RACW_Type
=> RACW_Type
,
5614 Body_Decls
=> Body_Decls
);
5616 Add_RACW_Write_Attribute
5617 (RACW_Type
=> RACW_Type
,
5618 Stub_Type
=> Stub_Type
,
5619 Stub_Type_Access
=> Stub_Type_Access
,
5620 Body_Decls
=> Body_Decls
);
5622 Add_RACW_Read_Attribute
5623 (RACW_Type
=> RACW_Type
,
5624 Stub_Type
=> Stub_Type
,
5625 Stub_Type_Access
=> Stub_Type_Access
,
5626 Body_Decls
=> Body_Decls
);
5629 (Designated_Type
=> Desig
,
5630 RACW_Type
=> RACW_Type
,
5631 Body_Decls
=> Body_Decls
);
5632 end Add_RACW_Features
;
5634 -----------------------
5635 -- Add_RACW_From_Any --
5636 -----------------------
5638 procedure Add_RACW_From_Any
5639 (RACW_Type
: Entity_Id
;
5640 Body_Decls
: List_Id
)
5642 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5643 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5645 Fnam
: constant Entity_Id
:=
5646 Make_Defining_Identifier
(Loc
,
5647 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'F'));
5649 Func_Spec
: Node_Id
;
5650 Func_Decl
: Node_Id
;
5651 Func_Body
: Node_Id
;
5653 Statements
: List_Id
;
5654 -- Various parts of the subprogram
5656 Any_Parameter
: constant Entity_Id
:=
5657 Make_Defining_Identifier
(Loc
, Name_A
);
5659 Asynchronous_Flag
: constant Entity_Id
:=
5660 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5661 -- The flag object declared in Add_RACW_Asynchronous_Flag
5665 Make_Function_Specification
(Loc
,
5666 Defining_Unit_Name
=>
5668 Parameter_Specifications
=> New_List
(
5669 Make_Parameter_Specification
(Loc
,
5670 Defining_Identifier
=>
5673 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
5674 Result_Definition
=> New_Occurrence_Of
(RACW_Type
, Loc
));
5676 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5677 -- entity in the declaration spec, not those of the body spec.
5679 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5680 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5681 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_From_Any
);
5683 if No
(Body_Decls
) then
5687 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5688 -- set on the stub type if, and only if, the RACW type has a pragma
5689 -- Asynchronous. This is incorrect for RACWs that implement RAS
5690 -- types, because in that case the /designated subprogram/ (not the
5691 -- type) might be asynchronous, and that causes the stub to need to
5692 -- be asynchronous too. A solution is to transport a RAS as a struct
5693 -- containing a RACW and an asynchronous flag, and to properly alter
5694 -- the Asynchronous component in the stub type in the RAS's _From_Any
5697 Statements
:= New_List
(
5698 Make_Simple_Return_Statement
(Loc
,
5699 Expression
=> Unchecked_Convert_To
(RACW_Type
,
5700 Make_Function_Call
(Loc
,
5701 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RACW
), Loc
),
5702 Parameter_Associations
=> New_List
(
5703 Make_Function_Call
(Loc
,
5704 Name
=> New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
5705 Parameter_Associations
=> New_List
(
5706 New_Occurrence_Of
(Any_Parameter
, Loc
))),
5707 Build_Stub_Tag
(Loc
, RACW_Type
),
5708 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5709 New_Occurrence_Of
(Asynchronous_Flag
, Loc
))))));
5712 Make_Subprogram_Body
(Loc
,
5713 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
5714 Declarations
=> No_List
,
5715 Handled_Statement_Sequence
=>
5716 Make_Handled_Sequence_Of_Statements
(Loc
,
5717 Statements
=> Statements
));
5719 Append_To
(Body_Decls
, Func_Body
);
5720 end Add_RACW_From_Any
;
5722 -----------------------------
5723 -- Add_RACW_Read_Attribute --
5724 -----------------------------
5726 procedure Add_RACW_Read_Attribute
5727 (RACW_Type
: Entity_Id
;
5728 Stub_Type
: Entity_Id
;
5729 Stub_Type_Access
: Entity_Id
;
5730 Body_Decls
: List_Id
)
5732 pragma Warnings
(Off
);
5733 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
5734 pragma Warnings
(On
);
5735 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5737 Proc_Decl
: Node_Id
;
5738 Attr_Decl
: Node_Id
;
5740 Body_Node
: Node_Id
;
5742 Decls
: constant List_Id
:= New_List
;
5743 Statements
: constant List_Id
:= New_List
;
5744 Reference
: constant Entity_Id
:=
5745 Make_Defining_Identifier
(Loc
, Name_R
);
5746 -- Various parts of the procedure
5748 Pnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
5749 New_Internal_Name
('R'));
5751 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5753 Asynchronous_Flag
: constant Entity_Id
:=
5754 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5755 pragma Assert
(Present
(Asynchronous_Flag
));
5757 function Stream_Parameter
return Node_Id
;
5758 function Result
return Node_Id
;
5760 -- Functions to create occurrences of the formal parameter names
5766 function Result
return Node_Id
is
5768 return Make_Identifier
(Loc
, Name_V
);
5771 ----------------------
5772 -- Stream_Parameter --
5773 ----------------------
5775 function Stream_Parameter
return Node_Id
is
5777 return Make_Identifier
(Loc
, Name_S
);
5778 end Stream_Parameter
;
5780 -- Start of processing for Add_RACW_Read_Attribute
5783 Build_Stream_Procedure
5784 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> True);
5786 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
5787 Copy_Specification
(Loc
, Specification
(Body_Node
)));
5790 Make_Attribute_Definition_Clause
(Loc
,
5791 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
5795 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
5797 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
5798 Insert_After
(Proc_Decl
, Attr_Decl
);
5800 if No
(Body_Decls
) then
5805 Make_Object_Declaration
(Loc
,
5806 Defining_Identifier
=>
5808 Object_Definition
=>
5809 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)));
5811 Append_List_To
(Statements
, New_List
(
5812 Make_Attribute_Reference
(Loc
,
5814 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5815 Attribute_Name
=> Name_Read
,
5816 Expressions
=> New_List
(
5818 New_Occurrence_Of
(Reference
, Loc
))),
5820 Make_Assignment_Statement
(Loc
,
5824 Unchecked_Convert_To
(RACW_Type
,
5825 Make_Function_Call
(Loc
,
5827 New_Occurrence_Of
(RTE
(RE_Get_RACW
), Loc
),
5828 Parameter_Associations
=> New_List
(
5829 New_Occurrence_Of
(Reference
, Loc
),
5830 Build_Stub_Tag
(Loc
, RACW_Type
),
5831 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5832 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)))))));
5834 Set_Declarations
(Body_Node
, Decls
);
5835 Append_To
(Body_Decls
, Body_Node
);
5836 end Add_RACW_Read_Attribute
;
5838 ---------------------
5839 -- Add_RACW_To_Any --
5840 ---------------------
5842 procedure Add_RACW_To_Any
5843 (RACW_Type
: Entity_Id
;
5844 Body_Decls
: List_Id
)
5846 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5848 Fnam
: constant Entity_Id
:=
5849 Make_Defining_Identifier
(Loc
,
5850 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'T'));
5852 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5854 Stub_Elements
: constant Stub_Structure
:=
5855 Get_Stub_Elements
(RACW_Type
);
5857 Func_Spec
: Node_Id
;
5858 Func_Decl
: Node_Id
;
5859 Func_Body
: Node_Id
;
5862 Statements
: List_Id
;
5863 -- Various parts of the subprogram
5865 RACW_Parameter
: constant Entity_Id
:=
5866 Make_Defining_Identifier
(Loc
, Name_R
);
5868 Reference
: constant Entity_Id
:=
5869 Make_Defining_Identifier
5870 (Loc
, New_Internal_Name
('R'));
5871 Any
: constant Entity_Id
:=
5872 Make_Defining_Identifier
5873 (Loc
, New_Internal_Name
('A'));
5877 Make_Function_Specification
(Loc
,
5878 Defining_Unit_Name
=>
5880 Parameter_Specifications
=> New_List
(
5881 Make_Parameter_Specification
(Loc
,
5882 Defining_Identifier
=>
5885 New_Occurrence_Of
(RACW_Type
, Loc
))),
5886 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
5888 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5889 -- entity in the declaration spec, not in the body spec.
5891 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5893 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5894 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_To_Any
);
5896 if No
(Body_Decls
) then
5902 -- R : constant Object_Ref :=
5908 -- RPC_Receiver'Access);
5912 Make_Object_Declaration
(Loc
,
5913 Defining_Identifier
=> Reference
,
5914 Constant_Present
=> True,
5915 Object_Definition
=>
5916 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5918 Make_Function_Call
(Loc
,
5919 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
5920 Parameter_Associations
=> New_List
(
5921 Unchecked_Convert_To
(RTE
(RE_Address
),
5922 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5923 Make_String_Literal
(Loc
,
5924 Strval
=> Full_Qualified_Name
5925 (Etype
(Designated_Type
(RACW_Type
)))),
5926 Build_Stub_Tag
(Loc
, RACW_Type
),
5927 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5928 Make_Attribute_Reference
(Loc
,
5931 (Defining_Identifier
5932 (Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5933 Attribute_Name
=> Name_Access
)))),
5935 Make_Object_Declaration
(Loc
,
5936 Defining_Identifier
=> Any
,
5937 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
5941 -- Any := TA_ObjRef (Reference);
5942 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
5945 Statements
:= New_List
(
5946 Make_Assignment_Statement
(Loc
,
5947 Name
=> New_Occurrence_Of
(Any
, Loc
),
5949 Make_Function_Call
(Loc
,
5950 Name
=> New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
5951 Parameter_Associations
=> New_List
(
5952 New_Occurrence_Of
(Reference
, Loc
)))),
5954 Make_Procedure_Call_Statement
(Loc
,
5955 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
5956 Parameter_Associations
=> New_List
(
5957 New_Occurrence_Of
(Any
, Loc
),
5958 Make_Selected_Component
(Loc
,
5960 Defining_Identifier
(
5961 Stub_Elements
.RPC_Receiver_Decl
),
5962 Selector_Name
=> Name_Obj_TypeCode
))),
5964 Make_Simple_Return_Statement
(Loc
,
5965 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
5968 Make_Subprogram_Body
(Loc
,
5969 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
5970 Declarations
=> Decls
,
5971 Handled_Statement_Sequence
=>
5972 Make_Handled_Sequence_Of_Statements
(Loc
,
5973 Statements
=> Statements
));
5974 Append_To
(Body_Decls
, Func_Body
);
5975 end Add_RACW_To_Any
;
5977 -----------------------
5978 -- Add_RACW_TypeCode --
5979 -----------------------
5981 procedure Add_RACW_TypeCode
5982 (Designated_Type
: Entity_Id
;
5983 RACW_Type
: Entity_Id
;
5984 Body_Decls
: List_Id
)
5986 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5988 Fnam
: constant Entity_Id
:=
5989 Make_Defining_Identifier
(Loc
,
5990 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'Y'));
5992 Stub_Elements
: constant Stub_Structure
:=
5993 Stubs_Table
.Get
(Designated_Type
);
5994 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5996 Func_Spec
: Node_Id
;
5997 Func_Decl
: Node_Id
;
5998 Func_Body
: Node_Id
;
6002 -- The spec for this subprogram has a dummy 'access RACW' argument,
6003 -- which serves only for overloading purposes.
6006 Make_Function_Specification
(Loc
,
6007 Defining_Unit_Name
=> Fnam
,
6008 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6010 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6011 -- entity in the declaration spec, not those of the body spec.
6013 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
6014 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
6015 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_TypeCode
);
6017 if No
(Body_Decls
) then
6022 Make_Subprogram_Body
(Loc
,
6023 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
6024 Declarations
=> Empty_List
,
6025 Handled_Statement_Sequence
=>
6026 Make_Handled_Sequence_Of_Statements
(Loc
,
6027 Statements
=> New_List
(
6028 Make_Simple_Return_Statement
(Loc
,
6030 Make_Selected_Component
(Loc
,
6033 (Stub_Elements
.RPC_Receiver_Decl
),
6034 Selector_Name
=> Name_Obj_TypeCode
)))));
6036 Append_To
(Body_Decls
, Func_Body
);
6037 end Add_RACW_TypeCode
;
6039 ------------------------------
6040 -- Add_RACW_Write_Attribute --
6041 ------------------------------
6043 procedure Add_RACW_Write_Attribute
6044 (RACW_Type
: Entity_Id
;
6045 Stub_Type
: Entity_Id
;
6046 Stub_Type_Access
: Entity_Id
;
6047 Body_Decls
: List_Id
)
6049 pragma Warnings
(Off
);
6050 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
6051 pragma Warnings
(On
);
6053 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
6055 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
6057 Stub_Elements
: constant Stub_Structure
:=
6058 Get_Stub_Elements
(RACW_Type
);
6060 Body_Node
: Node_Id
;
6061 Proc_Decl
: Node_Id
;
6062 Attr_Decl
: Node_Id
;
6064 Statements
: constant List_Id
:= New_List
;
6065 Pnam
: constant Entity_Id
:=
6066 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
6068 function Stream_Parameter
return Node_Id
;
6069 function Object
return Node_Id
;
6070 -- Functions to create occurrences of the formal parameter names
6076 function Object
return Node_Id
is
6078 return Make_Identifier
(Loc
, Name_V
);
6081 ----------------------
6082 -- Stream_Parameter --
6083 ----------------------
6085 function Stream_Parameter
return Node_Id
is
6087 return Make_Identifier
(Loc
, Name_S
);
6088 end Stream_Parameter
;
6090 -- Start of processing for Add_RACW_Write_Attribute
6093 Build_Stream_Procedure
6094 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> False);
6097 Make_Subprogram_Declaration
(Loc
,
6098 Copy_Specification
(Loc
, Specification
(Body_Node
)));
6101 Make_Attribute_Definition_Clause
(Loc
,
6102 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
6103 Chars
=> Name_Write
,
6106 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
6108 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
6109 Insert_After
(Proc_Decl
, Attr_Decl
);
6111 if No
(Body_Decls
) then
6115 Append_To
(Statements
,
6116 Pack_Node_Into_Stream_Access
(Loc
,
6117 Stream
=> Stream_Parameter
,
6119 Make_Function_Call
(Loc
,
6120 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
6121 Parameter_Associations
=> New_List
(
6122 Unchecked_Convert_To
(RTE
(RE_Address
), Object
),
6123 Make_String_Literal
(Loc
,
6124 Strval
=> Full_Qualified_Name
6125 (Etype
(Designated_Type
(RACW_Type
)))),
6126 Build_Stub_Tag
(Loc
, RACW_Type
),
6127 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
6128 Make_Attribute_Reference
(Loc
,
6131 (Defining_Identifier
6132 (Stub_Elements
.RPC_Receiver_Decl
), Loc
),
6133 Attribute_Name
=> Name_Access
))),
6135 Etyp
=> RTE
(RE_Object_Ref
)));
6137 Append_To
(Body_Decls
, Body_Node
);
6138 end Add_RACW_Write_Attribute
;
6140 -----------------------
6141 -- Add_RAST_Features --
6142 -----------------------
6144 procedure Add_RAST_Features
6145 (Vis_Decl
: Node_Id
;
6146 RAS_Type
: Entity_Id
)
6149 Add_RAS_Access_TSS
(Vis_Decl
);
6151 Add_RAS_From_Any
(RAS_Type
);
6152 Add_RAS_TypeCode
(RAS_Type
);
6154 -- To_Any uses TypeCode, and therefore needs to be generated last
6156 Add_RAS_To_Any
(RAS_Type
);
6157 end Add_RAST_Features
;
6159 ------------------------
6160 -- Add_RAS_Access_TSS --
6161 ------------------------
6163 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
6164 Loc
: constant Source_Ptr
:= Sloc
(N
);
6166 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
6167 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
6168 -- Ras_Type is the access to subprogram type; Fat_Type is the
6169 -- corresponding record type.
6171 RACW_Type
: constant Entity_Id
:=
6172 Underlying_RACW_Type
(Ras_Type
);
6174 Stub_Elements
: constant Stub_Structure
:=
6175 Get_Stub_Elements
(RACW_Type
);
6177 Proc
: constant Entity_Id
:=
6178 Make_Defining_Identifier
(Loc
,
6179 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
6181 Proc_Spec
: Node_Id
;
6183 -- Formal parameters
6185 Package_Name
: constant Entity_Id
:=
6186 Make_Defining_Identifier
(Loc
,
6191 Subp_Id
: constant Entity_Id
:=
6192 Make_Defining_Identifier
(Loc
,
6195 -- Target subprogram
6197 Asynch_P
: constant Entity_Id
:=
6198 Make_Defining_Identifier
(Loc
,
6199 Chars
=> Name_Asynchronous
);
6200 -- Is the procedure to which the 'Access applies asynchronous?
6202 All_Calls_Remote
: constant Entity_Id
:=
6203 Make_Defining_Identifier
(Loc
,
6204 Chars
=> Name_All_Calls_Remote
);
6205 -- True if an All_Calls_Remote pragma applies to the RCI unit
6206 -- that contains the subprogram.
6208 -- Common local variables
6210 Proc_Decls
: List_Id
;
6211 Proc_Statements
: List_Id
;
6213 Subp_Ref
: constant Entity_Id
:=
6214 Make_Defining_Identifier
(Loc
, Name_R
);
6215 -- Reference that designates the target subprogram (returned
6216 -- by Get_RAS_Info).
6218 Is_Local
: constant Entity_Id
:=
6219 Make_Defining_Identifier
(Loc
, Name_L
);
6220 Local_Addr
: constant Entity_Id
:=
6221 Make_Defining_Identifier
(Loc
, Name_A
);
6222 -- For the call to Get_Local_Address
6224 -- Additional local variables for the remote case
6226 Local_Stub
: constant Entity_Id
:=
6227 Make_Defining_Identifier
(Loc
,
6228 Chars
=> New_Internal_Name
('L'));
6230 Stub_Ptr
: constant Entity_Id
:=
6231 Make_Defining_Identifier
(Loc
,
6232 Chars
=> New_Internal_Name
('S'));
6235 (Field_Name
: Name_Id
;
6236 Value
: Node_Id
) return Node_Id
;
6237 -- Construct an assignment that sets the named component in the
6245 (Field_Name
: Name_Id
;
6246 Value
: Node_Id
) return Node_Id
6250 Make_Assignment_Statement
(Loc
,
6252 Make_Selected_Component
(Loc
,
6254 Selector_Name
=> Field_Name
),
6255 Expression
=> Value
);
6258 -- Start of processing for Add_RAS_Access_TSS
6261 Proc_Decls
:= New_List
(
6263 -- Common declarations
6265 Make_Object_Declaration
(Loc
,
6266 Defining_Identifier
=> Subp_Ref
,
6267 Object_Definition
=>
6268 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
6270 Make_Object_Declaration
(Loc
,
6271 Defining_Identifier
=> Is_Local
,
6272 Object_Definition
=>
6273 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6275 Make_Object_Declaration
(Loc
,
6276 Defining_Identifier
=> Local_Addr
,
6277 Object_Definition
=>
6278 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
6280 Make_Object_Declaration
(Loc
,
6281 Defining_Identifier
=> Local_Stub
,
6282 Aliased_Present
=> True,
6283 Object_Definition
=>
6284 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
6286 Make_Object_Declaration
(Loc
,
6287 Defining_Identifier
=> Stub_Ptr
,
6288 Object_Definition
=>
6289 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
6291 Make_Attribute_Reference
(Loc
,
6292 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
6293 Attribute_Name
=> Name_Unchecked_Access
)));
6295 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
6296 -- Build_Get_Unique_RP_Call needs this information
6298 -- Get_RAS_Info (Pkg, Subp, R);
6299 -- Obtain a reference to the target subprogram
6301 Proc_Statements
:= New_List
(
6302 Make_Procedure_Call_Statement
(Loc
,
6303 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
6304 Parameter_Associations
=> New_List
(
6305 New_Occurrence_Of
(Package_Name
, Loc
),
6306 New_Occurrence_Of
(Subp_Id
, Loc
),
6307 New_Occurrence_Of
(Subp_Ref
, Loc
))),
6309 -- Get_Local_Address (R, L, A);
6310 -- Determine whether the subprogram is local (L), and if so
6311 -- obtain the local address of its proxy (A).
6313 Make_Procedure_Call_Statement
(Loc
,
6314 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6315 Parameter_Associations
=> New_List
(
6316 New_Occurrence_Of
(Subp_Ref
, Loc
),
6317 New_Occurrence_Of
(Is_Local
, Loc
),
6318 New_Occurrence_Of
(Local_Addr
, Loc
))));
6320 -- Note: Here we assume that the Fat_Type is a record containing just
6321 -- an access to a proxy or stub object.
6323 Append_To
(Proc_Statements
,
6327 Make_Implicit_If_Statement
(N
,
6328 Condition
=> New_Occurrence_Of
(Is_Local
, Loc
),
6330 Then_Statements
=> New_List
(
6332 -- if A.Target = null then
6334 Make_Implicit_If_Statement
(N
,
6337 Make_Selected_Component
(Loc
,
6339 Unchecked_Convert_To
6340 (RTE
(RE_RAS_Proxy_Type_Access
),
6341 New_Occurrence_Of
(Local_Addr
, Loc
)),
6342 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)),
6345 Then_Statements
=> New_List
(
6347 -- A.Target := Entity_Of (Ref);
6349 Make_Assignment_Statement
(Loc
,
6351 Make_Selected_Component
(Loc
,
6353 Unchecked_Convert_To
6354 (RTE
(RE_RAS_Proxy_Type_Access
),
6355 New_Occurrence_Of
(Local_Addr
, Loc
)),
6356 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)),
6358 Make_Function_Call
(Loc
,
6359 Name
=> New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6360 Parameter_Associations
=> New_List
(
6361 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6363 -- Inc_Usage (A.Target);
6365 Make_Procedure_Call_Statement
(Loc
,
6366 Name
=> New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6367 Parameter_Associations
=> New_List
(
6368 Make_Selected_Component
(Loc
,
6370 Unchecked_Convert_To
6371 (RTE
(RE_RAS_Proxy_Type_Access
),
6372 New_Occurrence_Of
(Local_Addr
, Loc
)),
6374 Make_Identifier
(Loc
, Name_Target
)))))),
6377 -- if not All_Calls_Remote then
6378 -- return Fat_Type!(A);
6381 Make_Implicit_If_Statement
(N
,
6385 New_Occurrence_Of
(All_Calls_Remote
, Loc
)),
6387 Then_Statements
=> New_List
(
6388 Make_Simple_Return_Statement
(Loc
,
6390 Unchecked_Convert_To
6391 (Fat_Type
, New_Occurrence_Of
(Local_Addr
, Loc
))))))));
6393 Append_List_To
(Proc_Statements
, New_List
(
6395 -- Stub.Target := Entity_Of (Ref);
6397 Set_Field
(Name_Target
,
6398 Make_Function_Call
(Loc
,
6399 Name
=> New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6400 Parameter_Associations
=> New_List
(
6401 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6403 -- Inc_Usage (Stub.Target);
6405 Make_Procedure_Call_Statement
(Loc
,
6406 Name
=> New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6407 Parameter_Associations
=> New_List
(
6408 Make_Selected_Component
(Loc
,
6410 Selector_Name
=> Name_Target
))),
6412 -- E.4.1(9) A remote call is asynchronous if it is a call to
6413 -- a procedure, or a call through a value of an access-to-procedure
6414 -- type, to which a pragma Asynchronous applies.
6416 -- Parameter Asynch_P is true when the procedure is asynchronous;
6417 -- Expression Asynch_T is true when the type is asynchronous.
6419 Set_Field
(Name_Asynchronous
,
6421 Left_Opnd
=> New_Occurrence_Of
(Asynch_P
, Loc
),
6424 (Boolean_Literals
(Is_Asynchronous
(Ras_Type
)), Loc
)))));
6426 Append_List_To
(Proc_Statements
,
6427 Build_Get_Unique_RP_Call
(Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
6429 Append_To
(Proc_Statements
,
6430 Make_Simple_Return_Statement
(Loc
,
6432 Unchecked_Convert_To
(Fat_Type
,
6433 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
6436 Make_Function_Specification
(Loc
,
6437 Defining_Unit_Name
=> Proc
,
6438 Parameter_Specifications
=> New_List
(
6439 Make_Parameter_Specification
(Loc
,
6440 Defining_Identifier
=> Package_Name
,
6442 New_Occurrence_Of
(Standard_String
, Loc
)),
6444 Make_Parameter_Specification
(Loc
,
6445 Defining_Identifier
=> Subp_Id
,
6447 New_Occurrence_Of
(Standard_String
, Loc
)),
6449 Make_Parameter_Specification
(Loc
,
6450 Defining_Identifier
=> Asynch_P
,
6452 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6454 Make_Parameter_Specification
(Loc
,
6455 Defining_Identifier
=> All_Calls_Remote
,
6457 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
6459 Result_Definition
=>
6460 New_Occurrence_Of
(Fat_Type
, Loc
));
6462 -- Set the kind and return type of the function to prevent
6463 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6465 Set_Ekind
(Proc
, E_Function
);
6466 Set_Etype
(Proc
, Fat_Type
);
6469 Make_Subprogram_Body
(Loc
,
6470 Specification
=> Proc_Spec
,
6471 Declarations
=> Proc_Decls
,
6472 Handled_Statement_Sequence
=>
6473 Make_Handled_Sequence_Of_Statements
(Loc
,
6474 Statements
=> Proc_Statements
)));
6476 Set_TSS
(Fat_Type
, Proc
);
6477 end Add_RAS_Access_TSS
;
6479 ----------------------
6480 -- Add_RAS_From_Any --
6481 ----------------------
6483 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
) is
6484 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6486 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6487 Make_TSS_Name
(RAS_Type
, TSS_From_Any
));
6489 Func_Spec
: Node_Id
;
6491 Statements
: List_Id
;
6493 Any_Parameter
: constant Entity_Id
:=
6494 Make_Defining_Identifier
(Loc
, Name_A
);
6497 Statements
:= New_List
(
6498 Make_Simple_Return_Statement
(Loc
,
6500 Make_Aggregate
(Loc
,
6501 Component_Associations
=> New_List
(
6502 Make_Component_Association
(Loc
,
6503 Choices
=> New_List
(
6504 Make_Identifier
(Loc
, Name_Ras
)),
6506 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
6507 Underlying_RACW_Type
(RAS_Type
),
6508 New_Occurrence_Of
(Any_Parameter
, Loc
),
6512 Make_Function_Specification
(Loc
,
6513 Defining_Unit_Name
=> Fnam
,
6514 Parameter_Specifications
=> New_List
(
6515 Make_Parameter_Specification
(Loc
,
6516 Defining_Identifier
=> Any_Parameter
,
6517 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
6518 Result_Definition
=> New_Occurrence_Of
(RAS_Type
, Loc
));
6521 Make_Subprogram_Body
(Loc
,
6522 Specification
=> Func_Spec
,
6523 Declarations
=> No_List
,
6524 Handled_Statement_Sequence
=>
6525 Make_Handled_Sequence_Of_Statements
(Loc
,
6526 Statements
=> Statements
)));
6527 Set_TSS
(RAS_Type
, Fnam
);
6528 end Add_RAS_From_Any
;
6530 --------------------
6531 -- Add_RAS_To_Any --
6532 --------------------
6534 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
) is
6535 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6537 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6538 Make_TSS_Name
(RAS_Type
, TSS_To_Any
));
6541 Statements
: List_Id
;
6543 Func_Spec
: Node_Id
;
6545 Any
: constant Entity_Id
:=
6546 Make_Defining_Identifier
(Loc
,
6547 Chars
=> New_Internal_Name
('A'));
6548 RAS_Parameter
: constant Entity_Id
:=
6549 Make_Defining_Identifier
(Loc
,
6550 Chars
=> New_Internal_Name
('R'));
6551 RACW_Parameter
: constant Node_Id
:=
6552 Make_Selected_Component
(Loc
,
6553 Prefix
=> RAS_Parameter
,
6554 Selector_Name
=> Name_Ras
);
6557 -- Object declarations
6559 Set_Etype
(RACW_Parameter
, Underlying_RACW_Type
(RAS_Type
));
6561 Make_Object_Declaration
(Loc
,
6562 Defining_Identifier
=> Any
,
6563 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
6565 PolyORB_Support
.Helpers
.Build_To_Any_Call
6566 (RACW_Parameter
, No_List
)));
6568 Statements
:= New_List
(
6569 Make_Procedure_Call_Statement
(Loc
,
6570 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
6571 Parameter_Associations
=> New_List
(
6572 New_Occurrence_Of
(Any
, Loc
),
6573 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
6576 Make_Simple_Return_Statement
(Loc
,
6577 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
6580 Make_Function_Specification
(Loc
,
6581 Defining_Unit_Name
=> Fnam
,
6582 Parameter_Specifications
=> New_List
(
6583 Make_Parameter_Specification
(Loc
,
6584 Defining_Identifier
=> RAS_Parameter
,
6585 Parameter_Type
=> New_Occurrence_Of
(RAS_Type
, Loc
))),
6586 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
6589 Make_Subprogram_Body
(Loc
,
6590 Specification
=> Func_Spec
,
6591 Declarations
=> Decls
,
6592 Handled_Statement_Sequence
=>
6593 Make_Handled_Sequence_Of_Statements
(Loc
,
6594 Statements
=> Statements
)));
6595 Set_TSS
(RAS_Type
, Fnam
);
6598 ----------------------
6599 -- Add_RAS_TypeCode --
6600 ----------------------
6602 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
) is
6603 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6605 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6606 Make_TSS_Name
(RAS_Type
, TSS_TypeCode
));
6608 Func_Spec
: Node_Id
;
6609 Decls
: constant List_Id
:= New_List
;
6610 Name_String
: String_Id
;
6611 Repo_Id_String
: String_Id
;
6615 Make_Function_Specification
(Loc
,
6616 Defining_Unit_Name
=> Fnam
,
6617 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6619 PolyORB_Support
.Helpers
.Build_Name_And_Repository_Id
6620 (RAS_Type
, Name_Str
=> Name_String
, Repo_Id_Str
=> Repo_Id_String
);
6623 Make_Subprogram_Body
(Loc
,
6624 Specification
=> Func_Spec
,
6625 Declarations
=> Decls
,
6626 Handled_Statement_Sequence
=>
6627 Make_Handled_Sequence_Of_Statements
(Loc
,
6628 Statements
=> New_List
(
6629 Make_Simple_Return_Statement
(Loc
,
6631 Make_Function_Call
(Loc
,
6632 Name
=> New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
6633 Parameter_Associations
=> New_List
(
6634 New_Occurrence_Of
(RTE
(RE_TC_Object
), Loc
),
6635 Make_Aggregate
(Loc
,
6638 Make_Function_Call
(Loc
,
6641 (RTE
(RE_TA_String
), Loc
),
6642 Parameter_Associations
=> New_List
(
6643 Make_String_Literal
(Loc
, Name_String
))),
6644 Make_Function_Call
(Loc
,
6647 (RTE
(RE_TA_String
), Loc
),
6648 Parameter_Associations
=> New_List
(
6649 Make_String_Literal
(Loc
,
6650 Strval
=> Repo_Id_String
))))))))))));
6651 Set_TSS
(RAS_Type
, Fnam
);
6652 end Add_RAS_TypeCode
;
6654 -----------------------------------------
6655 -- Add_Receiving_Stubs_To_Declarations --
6656 -----------------------------------------
6658 procedure Add_Receiving_Stubs_To_Declarations
6659 (Pkg_Spec
: Node_Id
;
6663 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
6665 Pkg_RPC_Receiver
: constant Entity_Id
:=
6666 Make_Defining_Identifier
(Loc
,
6667 New_Internal_Name
('H'));
6668 Pkg_RPC_Receiver_Object
: Node_Id
;
6669 Pkg_RPC_Receiver_Body
: Node_Id
;
6670 Pkg_RPC_Receiver_Decls
: List_Id
;
6671 Pkg_RPC_Receiver_Statements
: List_Id
;
6673 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
6674 -- A Pkg_RPC_Receiver is built to decode the request
6677 -- Request object received from neutral layer
6679 Subp_Id
: Entity_Id
;
6680 -- Subprogram identifier as received from the neutral
6681 -- distribution core.
6683 Subp_Index
: Entity_Id
;
6684 -- Internal index as determined by matching either the method name
6685 -- from the request structure, or the local subprogram address (in
6688 Is_Local
: constant Entity_Id
:=
6689 Make_Defining_Identifier
(Loc
,
6690 Chars
=> New_Internal_Name
('L'));
6692 Local_Address
: constant Entity_Id
:=
6693 Make_Defining_Identifier
(Loc
,
6694 Chars
=> New_Internal_Name
('A'));
6695 -- Address of a local subprogram designated by a reference
6696 -- corresponding to a RAS.
6698 Dispatch_On_Address
: constant List_Id
:= New_List
;
6699 Dispatch_On_Name
: constant List_Id
:= New_List
;
6701 Current_Declaration
: Node_Id
;
6702 Current_Stubs
: Node_Id
;
6703 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
6705 Subp_Info_Array
: constant Entity_Id
:=
6706 Make_Defining_Identifier
(Loc
,
6707 Chars
=> New_Internal_Name
('I'));
6709 Subp_Info_List
: constant List_Id
:= New_List
;
6711 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
6713 All_Calls_Remote_E
: Entity_Id
;
6715 procedure Append_Stubs_To
6716 (RPC_Receiver_Cases
: List_Id
;
6717 Declaration
: Node_Id
;
6720 Subp_Dist_Name
: Entity_Id
;
6721 Subp_Proxy_Addr
: Entity_Id
);
6722 -- Add one case to the specified RPC receiver case list associating
6723 -- Subprogram_Number with the subprogram declared by Declaration, for
6724 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6725 -- subprogram index. Subp_Dist_Name is the string used to call the
6726 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6727 -- object, used in the context of calls through remote
6728 -- access-to-subprogram types.
6730 ---------------------
6731 -- Append_Stubs_To --
6732 ---------------------
6734 procedure Append_Stubs_To
6735 (RPC_Receiver_Cases
: List_Id
;
6736 Declaration
: Node_Id
;
6739 Subp_Dist_Name
: Entity_Id
;
6740 Subp_Proxy_Addr
: Entity_Id
)
6742 Case_Stmts
: List_Id
;
6744 Case_Stmts
:= New_List
(
6745 Make_Procedure_Call_Statement
(Loc
,
6748 Defining_Entity
(Stubs
), Loc
),
6749 Parameter_Associations
=>
6750 New_List
(New_Occurrence_Of
(Request
, Loc
))));
6752 if Nkind
(Specification
(Declaration
)) = N_Function_Specification
6754 Is_Asynchronous
(Defining_Entity
(Specification
(Declaration
)))
6756 Append_To
(Case_Stmts
, Make_Simple_Return_Statement
(Loc
));
6759 Append_To
(RPC_Receiver_Cases
,
6760 Make_Case_Statement_Alternative
(Loc
,
6762 New_List
(Make_Integer_Literal
(Loc
, Subp_Number
)),
6763 Statements
=> Case_Stmts
));
6765 Append_To
(Dispatch_On_Name
,
6766 Make_Elsif_Part
(Loc
,
6768 Make_Function_Call
(Loc
,
6770 New_Occurrence_Of
(RTE
(RE_Caseless_String_Eq
), Loc
),
6771 Parameter_Associations
=> New_List
(
6772 New_Occurrence_Of
(Subp_Id
, Loc
),
6773 New_Occurrence_Of
(Subp_Dist_Name
, Loc
))),
6775 Then_Statements
=> New_List
(
6776 Make_Assignment_Statement
(Loc
,
6777 New_Occurrence_Of
(Subp_Index
, Loc
),
6778 Make_Integer_Literal
(Loc
, Subp_Number
)))));
6780 Append_To
(Dispatch_On_Address
,
6781 Make_Elsif_Part
(Loc
,
6784 Left_Opnd
=> New_Occurrence_Of
(Local_Address
, Loc
),
6785 Right_Opnd
=> New_Occurrence_Of
(Subp_Proxy_Addr
, Loc
)),
6787 Then_Statements
=> New_List
(
6788 Make_Assignment_Statement
(Loc
,
6789 New_Occurrence_Of
(Subp_Index
, Loc
),
6790 Make_Integer_Literal
(Loc
, Subp_Number
)))));
6791 end Append_Stubs_To
;
6793 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6796 -- Building receiving stubs consist in several operations:
6798 -- - a package RPC receiver must be built. This subprogram
6799 -- will get a Subprogram_Id from the incoming stream
6800 -- and will dispatch the call to the right subprogram;
6802 -- - a receiving stub for each subprogram visible in the package
6803 -- spec. This stub will read all the parameters from the stream,
6804 -- and put the result as well as the exception occurrence in the
6807 -- - a dummy package with an empty spec and a body made of an
6808 -- elaboration part, whose job is to register the receiving
6809 -- part of this RCI package on the name server. This is done
6810 -- by calling System.Partition_Interface.Register_Receiving_Stub.
6812 Build_RPC_Receiver_Body
(
6813 RPC_Receiver
=> Pkg_RPC_Receiver
,
6816 Subp_Index
=> Subp_Index
,
6817 Stmts
=> Pkg_RPC_Receiver_Statements
,
6818 Decl
=> Pkg_RPC_Receiver_Body
);
6819 Pkg_RPC_Receiver_Decls
:= Declarations
(Pkg_RPC_Receiver_Body
);
6821 -- Extract local address information from the target reference:
6822 -- if non-null, that means that this is a reference that denotes
6823 -- one particular operation, and hence that the operation name
6824 -- must not be taken into account for dispatching.
6826 Append_To
(Pkg_RPC_Receiver_Decls
,
6827 Make_Object_Declaration
(Loc
,
6828 Defining_Identifier
=> Is_Local
,
6829 Object_Definition
=>
6830 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
6832 Append_To
(Pkg_RPC_Receiver_Decls
,
6833 Make_Object_Declaration
(Loc
,
6834 Defining_Identifier
=> Local_Address
,
6835 Object_Definition
=>
6836 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6838 Append_To
(Pkg_RPC_Receiver_Statements
,
6839 Make_Procedure_Call_Statement
(Loc
,
6840 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6841 Parameter_Associations
=> New_List
(
6842 Make_Selected_Component
(Loc
,
6844 Selector_Name
=> Name_Target
),
6845 New_Occurrence_Of
(Is_Local
, Loc
),
6846 New_Occurrence_Of
(Local_Address
, Loc
))));
6848 -- For each subprogram, the receiving stub will be built and a
6849 -- case statement will be made on the Subprogram_Id to dispatch
6850 -- to the right subprogram.
6852 All_Calls_Remote_E
:= Boolean_Literals
(
6853 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
6855 Overload_Counter_Table
.Reset
;
6856 Reserve_NamingContext_Methods
;
6858 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
6859 while Present
(Current_Declaration
) loop
6860 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
6861 and then Comes_From_Source
(Current_Declaration
)
6864 Loc
: constant Source_Ptr
:= Sloc
(Current_Declaration
);
6865 -- While specifically processing Current_Declaration, use
6866 -- its Sloc as the location of all generated nodes.
6868 Subp_Def
: constant Entity_Id
:=
6870 (Specification
(Current_Declaration
));
6872 Subp_Val
: String_Id
;
6874 Subp_Dist_Name
: constant Entity_Id
:=
6875 Make_Defining_Identifier
(Loc
,
6878 (Related_Id
=> Chars
(Subp_Def
),
6880 Suffix_Index
=> -1));
6882 Proxy_Object_Addr
: Entity_Id
;
6885 -- Build receiving stub
6888 Build_Subprogram_Receiving_Stubs
6889 (Vis_Decl
=> Current_Declaration
,
6891 Nkind
(Specification
(Current_Declaration
)) =
6892 N_Procedure_Specification
6893 and then Is_Asynchronous
(Subp_Def
));
6895 Append_To
(Decls
, Current_Stubs
);
6896 Analyze
(Current_Stubs
);
6900 Add_RAS_Proxy_And_Analyze
(Decls
,
6901 Vis_Decl
=> Current_Declaration
,
6902 All_Calls_Remote_E
=> All_Calls_Remote_E
,
6903 Proxy_Object_Addr
=> Proxy_Object_Addr
);
6905 -- Compute distribution identifier
6907 Assign_Subprogram_Identifier
6909 Current_Subprogram_Number
,
6913 (Current_Subprogram_Number
= Get_Subprogram_Id
(Subp_Def
));
6916 Make_Object_Declaration
(Loc
,
6917 Defining_Identifier
=> Subp_Dist_Name
,
6918 Constant_Present
=> True,
6919 Object_Definition
=>
6920 New_Occurrence_Of
(Standard_String
, Loc
),
6922 Make_String_Literal
(Loc
, Subp_Val
)));
6923 Analyze
(Last
(Decls
));
6925 -- Add subprogram descriptor (RCI_Subp_Info) to the
6926 -- subprograms table for this receiver. The aggregate
6927 -- below must be kept consistent with the declaration
6928 -- of type RCI_Subp_Info in System.Partition_Interface.
6930 Append_To
(Subp_Info_List
,
6931 Make_Component_Association
(Loc
,
6932 Choices
=> New_List
(
6933 Make_Integer_Literal
(Loc
, Current_Subprogram_Number
)),
6936 Make_Aggregate
(Loc
,
6937 Expressions
=> New_List
(
6938 Make_Attribute_Reference
(Loc
,
6940 New_Occurrence_Of
(Subp_Dist_Name
, Loc
),
6941 Attribute_Name
=> Name_Address
),
6943 Make_Attribute_Reference
(Loc
,
6945 New_Occurrence_Of
(Subp_Dist_Name
, Loc
),
6946 Attribute_Name
=> Name_Length
),
6948 New_Occurrence_Of
(Proxy_Object_Addr
, Loc
)))));
6950 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
6951 Declaration
=> Current_Declaration
,
6952 Stubs
=> Current_Stubs
,
6953 Subp_Number
=> Current_Subprogram_Number
,
6954 Subp_Dist_Name
=> Subp_Dist_Name
,
6955 Subp_Proxy_Addr
=> Proxy_Object_Addr
);
6958 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
6961 Next
(Current_Declaration
);
6965 Make_Object_Declaration
(Loc
,
6966 Defining_Identifier
=> Subp_Info_Array
,
6967 Constant_Present
=> True,
6968 Aliased_Present
=> True,
6969 Object_Definition
=>
6970 Make_Subtype_Indication
(Loc
,
6972 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
6974 Make_Index_Or_Discriminant_Constraint
(Loc
,
6978 Make_Integer_Literal
(Loc
,
6979 Intval
=> First_RCI_Subprogram_Id
),
6981 Make_Integer_Literal
(Loc
,
6983 First_RCI_Subprogram_Id
6984 + List_Length
(Subp_Info_List
) - 1)))))));
6986 if Present
(First
(Subp_Info_List
)) then
6987 Set_Expression
(Last
(Decls
),
6988 Make_Aggregate
(Loc
,
6989 Component_Associations
=> Subp_Info_List
));
6991 -- Generate the dispatch statement to determine the subprogram id
6992 -- of the called subprogram.
6994 -- We first test whether the reference that was used to make the
6995 -- call was the base RCI reference (in which case Local_Address is
6996 -- zero, and the method identifier from the request must be used
6997 -- to determine which subprogram is called) or a reference
6998 -- identifying one particular subprogram (in which case
6999 -- Local_Address is the address of that subprogram, and the
7000 -- method name from the request is ignored). The latter occurs
7001 -- for the case of a call through a remote access-to-subprogram.
7003 -- In each case, cascaded elsifs are used to determine the proper
7004 -- subprogram index. Using hash tables might be more efficient.
7006 Append_To
(Pkg_RPC_Receiver_Statements
,
7007 Make_Implicit_If_Statement
(Pkg_Spec
,
7010 Left_Opnd
=> New_Occurrence_Of
(Local_Address
, Loc
),
7011 Right_Opnd
=> New_Occurrence_Of
7012 (RTE
(RE_Null_Address
), Loc
)),
7014 Then_Statements
=> New_List
(
7015 Make_Implicit_If_Statement
(Pkg_Spec
,
7016 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
7017 Then_Statements
=> New_List
(
7018 Make_Null_Statement
(Loc
)),
7019 Elsif_Parts
=> Dispatch_On_Address
)),
7021 Else_Statements
=> New_List
(
7022 Make_Implicit_If_Statement
(Pkg_Spec
,
7023 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
7024 Then_Statements
=> New_List
(Make_Null_Statement
(Loc
)),
7025 Elsif_Parts
=> Dispatch_On_Name
))));
7028 -- For a degenerate RCI with no visible subprograms,
7029 -- Subp_Info_List has zero length, and the declaration is for an
7030 -- empty array, in which case no initialization aggregate must be
7031 -- generated. We do not generate a Dispatch_Statement either.
7033 -- No initialization provided: remove CONSTANT so that the
7034 -- declaration is not an incomplete deferred constant.
7036 Set_Constant_Present
(Last
(Decls
), False);
7039 -- Analyze Subp_Info_Array declaration
7041 Analyze
(Last
(Decls
));
7043 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7044 -- rather than raising an exception since we do not want someone
7045 -- to crash a remote partition by sending invalid subprogram ids.
7046 -- This is consistent with the other parts of the case statement
7047 -- since even in presence of incorrect parameters in the stream,
7048 -- every exception will be caught and (if the subprogram is not an
7049 -- APC) put into the result stream and sent away.
7051 Append_To
(Pkg_RPC_Receiver_Cases
,
7052 Make_Case_Statement_Alternative
(Loc
,
7053 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7054 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
7056 Append_To
(Pkg_RPC_Receiver_Statements
,
7057 Make_Case_Statement
(Loc
,
7058 Expression
=> New_Occurrence_Of
(Subp_Index
, Loc
),
7059 Alternatives
=> Pkg_RPC_Receiver_Cases
));
7061 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7064 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
7065 Analyze
(Last
(Decls
));
7067 Pkg_RPC_Receiver_Object
:=
7068 Make_Object_Declaration
(Loc
,
7069 Defining_Identifier
=>
7070 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
7071 Aliased_Present
=> True,
7072 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7073 Append_To
(Decls
, Pkg_RPC_Receiver_Object
);
7074 Analyze
(Last
(Decls
));
7076 Get_Library_Unit_Name_String
(Pkg_Spec
);
7080 Append_To
(Register_Pkg_Actuals
,
7081 Make_String_Literal
(Loc
,
7082 Strval
=> String_From_Name_Buffer
));
7086 Append_To
(Register_Pkg_Actuals
,
7087 Make_Attribute_Reference
(Loc
,
7090 (Defining_Entity
(Pkg_Spec
), Loc
),
7091 Attribute_Name
=> Name_Version
));
7095 Append_To
(Register_Pkg_Actuals
,
7096 Make_Attribute_Reference
(Loc
,
7098 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
7099 Attribute_Name
=> Name_Access
));
7103 Append_To
(Register_Pkg_Actuals
,
7104 Make_Attribute_Reference
(Loc
,
7107 Defining_Identifier
(Pkg_RPC_Receiver_Object
), Loc
),
7108 Attribute_Name
=> Name_Access
));
7112 Append_To
(Register_Pkg_Actuals
,
7113 Make_Attribute_Reference
(Loc
,
7114 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
7115 Attribute_Name
=> Name_Address
));
7119 Append_To
(Register_Pkg_Actuals
,
7120 Make_Attribute_Reference
(Loc
,
7121 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
7122 Attribute_Name
=> Name_Length
));
7124 -- Is_All_Calls_Remote
7126 Append_To
(Register_Pkg_Actuals
,
7127 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
));
7132 Make_Procedure_Call_Statement
(Loc
,
7134 New_Occurrence_Of
(RTE
(RE_Register_Pkg_Receiving_Stub
), Loc
),
7135 Parameter_Associations
=> Register_Pkg_Actuals
));
7136 Analyze
(Last
(Stmts
));
7137 end Add_Receiving_Stubs_To_Declarations
;
7139 ---------------------------------
7140 -- Build_General_Calling_Stubs --
7141 ---------------------------------
7143 procedure Build_General_Calling_Stubs
7145 Statements
: List_Id
;
7146 Target_Object
: Node_Id
;
7147 Subprogram_Id
: Node_Id
;
7148 Asynchronous
: Node_Id
:= Empty
;
7149 Is_Known_Asynchronous
: Boolean := False;
7150 Is_Known_Non_Asynchronous
: Boolean := False;
7151 Is_Function
: Boolean;
7153 Stub_Type
: Entity_Id
:= Empty
;
7154 RACW_Type
: Entity_Id
:= Empty
;
7157 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
7159 Arguments
: Node_Id
;
7160 -- Name of the named values list used to transmit parameters
7161 -- to the remote package
7164 -- The request object constructed by these stubs
7167 -- Name of the result named value (in non-APC cases) which get the
7168 -- result of the remote subprogram.
7170 Result_TC
: Node_Id
;
7171 -- Typecode expression for the result of the request (void
7172 -- typecode for procedures).
7174 Exception_Return_Parameter
: Node_Id
;
7175 -- Name of the parameter which will hold the exception sent by the
7176 -- remote subprogram.
7178 Current_Parameter
: Node_Id
;
7179 -- Current parameter being handled
7181 Ordered_Parameters_List
: constant List_Id
:=
7182 Build_Ordered_Parameters_List
(Spec
);
7184 Asynchronous_P
: Node_Id
;
7185 -- A Boolean expression indicating whether this call is asynchronous
7187 Asynchronous_Statements
: List_Id
:= No_List
;
7188 Non_Asynchronous_Statements
: List_Id
:= No_List
;
7189 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7191 Extra_Formal_Statements
: constant List_Id
:= New_List
;
7192 -- List of statements for extra formal parameters. It will appear
7193 -- after the regular statements for writing out parameters.
7195 After_Statements
: constant List_Id
:= New_List
;
7196 -- Statements to be executed after call returns (to assign
7197 -- in out or out parameter values).
7200 -- The type of the formal parameter being processed
7202 Is_Controlling_Formal
: Boolean;
7203 Is_First_Controlling_Formal
: Boolean;
7204 First_Controlling_Formal_Seen
: Boolean := False;
7205 -- Controlling formal parameters of distributed object primitives
7206 -- require special handling, and the first such parameter needs even
7207 -- more special handling.
7210 -- ??? document general form of stub subprograms for the PolyORB case
7211 Request
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
7214 Make_Object_Declaration
(Loc
,
7215 Defining_Identifier
=> Request
,
7216 Aliased_Present
=> False,
7217 Object_Definition
=>
7218 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
)));
7221 Make_Defining_Identifier
(Loc
,
7222 Chars
=> New_Internal_Name
('R'));
7226 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7227 (Loc
, Etype
(Result_Definition
(Spec
)), Decls
);
7229 Result_TC
:= New_Occurrence_Of
(RTE
(RE_TC_Void
), Loc
);
7233 Make_Object_Declaration
(Loc
,
7234 Defining_Identifier
=> Result
,
7235 Aliased_Present
=> False,
7236 Object_Definition
=>
7237 New_Occurrence_Of
(RTE
(RE_NamedValue
), Loc
),
7239 Make_Aggregate
(Loc
,
7240 Component_Associations
=> New_List
(
7241 Make_Component_Association
(Loc
,
7242 Choices
=> New_List
(Make_Identifier
(Loc
, Name_Name
)),
7244 New_Occurrence_Of
(RTE
(RE_Result_Name
), Loc
)),
7245 Make_Component_Association
(Loc
,
7246 Choices
=> New_List
(
7247 Make_Identifier
(Loc
, Name_Argument
)),
7249 Make_Function_Call
(Loc
,
7250 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7251 Parameter_Associations
=> New_List
(Result_TC
))),
7252 Make_Component_Association
(Loc
,
7253 Choices
=> New_List
(
7254 Make_Identifier
(Loc
, Name_Arg_Modes
)),
7255 Expression
=> Make_Integer_Literal
(Loc
, 0))))));
7257 if not Is_Known_Asynchronous
then
7258 Exception_Return_Parameter
:=
7259 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
7262 Make_Object_Declaration
(Loc
,
7263 Defining_Identifier
=> Exception_Return_Parameter
,
7264 Object_Definition
=>
7265 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
7268 Exception_Return_Parameter
:= Empty
;
7271 -- Initialize and fill in arguments list
7274 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
7275 Declare_Create_NVList
(Loc
, Arguments
, Decls
, Statements
);
7277 Current_Parameter
:= First
(Ordered_Parameters_List
);
7278 while Present
(Current_Parameter
) loop
7279 if Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
) then
7280 Is_Controlling_Formal
:= True;
7281 Is_First_Controlling_Formal
:=
7282 not First_Controlling_Formal_Seen
;
7283 First_Controlling_Formal_Seen
:= True;
7286 Is_Controlling_Formal
:= False;
7287 Is_First_Controlling_Formal
:= False;
7290 if Is_Controlling_Formal
then
7292 -- For a controlling formal argument, we send its reference
7297 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7300 -- The first controlling formal parameter is treated specially:
7301 -- it is used to set the target object of the call.
7303 if not Is_First_Controlling_Formal
then
7305 Constrained
: constant Boolean :=
7306 Is_Constrained
(Etyp
)
7307 or else Is_Elementary_Type
(Etyp
);
7309 Any
: constant Entity_Id
:=
7310 Make_Defining_Identifier
(Loc
,
7311 New_Internal_Name
('A'));
7313 Actual_Parameter
: Node_Id
:=
7315 Defining_Identifier
(
7316 Current_Parameter
), Loc
);
7321 if Is_Controlling_Formal
then
7323 -- For a controlling formal parameter (other than the
7324 -- first one), use the corresponding RACW. If the
7325 -- parameter is not an anonymous access parameter, that
7326 -- involves taking its 'Unrestricted_Access.
7328 if Nkind
(Parameter_Type
(Current_Parameter
))
7329 = N_Access_Definition
7331 Actual_Parameter
:= OK_Convert_To
7332 (Etyp
, Actual_Parameter
);
7334 Actual_Parameter
:= OK_Convert_To
(Etyp
,
7335 Make_Attribute_Reference
(Loc
,
7336 Prefix
=> Actual_Parameter
,
7337 Attribute_Name
=> Name_Unrestricted_Access
));
7342 if In_Present
(Current_Parameter
)
7343 or else not Out_Present
(Current_Parameter
)
7344 or else not Constrained
7345 or else Is_Controlling_Formal
7347 -- The parameter has an input value, is constrained at
7348 -- runtime by an input value, or is a controlling formal
7349 -- parameter (always passed as a reference) other than
7352 Expr
:= PolyORB_Support
.Helpers
.Build_To_Any_Call
7353 (Actual_Parameter
, Decls
);
7356 Expr
:= Make_Function_Call
(Loc
,
7357 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7358 Parameter_Associations
=> New_List
(
7359 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7360 (Loc
, Etyp
, Decls
)));
7364 Make_Object_Declaration
(Loc
,
7365 Defining_Identifier
=> Any
,
7366 Aliased_Present
=> False,
7367 Object_Definition
=>
7368 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7369 Expression
=> Expr
));
7371 Append_To
(Statements
,
7372 Add_Parameter_To_NVList
(Loc
,
7373 Parameter
=> Current_Parameter
,
7374 NVList
=> Arguments
,
7375 Constrained
=> Constrained
,
7378 if Out_Present
(Current_Parameter
)
7379 and then not Is_Controlling_Formal
7381 Append_To
(After_Statements
,
7382 Make_Assignment_Statement
(Loc
,
7385 Defining_Identifier
(Current_Parameter
), Loc
),
7387 PolyORB_Support
.Helpers
.Build_From_Any_Call
7388 (Etype
(Parameter_Type
(Current_Parameter
)),
7389 New_Occurrence_Of
(Any
, Loc
),
7396 -- If the current parameter has a dynamic constrained status, then
7397 -- this status is transmitted as well.
7398 -- This should be done for accessibility as well ???
7400 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7402 and then Need_Extra_Constrained
(Current_Parameter
)
7404 -- In this block, we do not use the extra formal that has been
7405 -- created because it does not exist at the time of expansion
7406 -- when building calling stubs for remote access to subprogram
7407 -- types. We create an extra variable of this type and push it
7408 -- in the stream after the regular parameters.
7411 Extra_Any_Parameter
: constant Entity_Id
:=
7412 Make_Defining_Identifier
7413 (Loc
, New_Internal_Name
('P'));
7415 Parameter_Exp
: constant Node_Id
:=
7416 Make_Attribute_Reference
(Loc
,
7417 Prefix
=> New_Occurrence_Of
(
7418 Defining_Identifier
(Current_Parameter
), Loc
),
7419 Attribute_Name
=> Name_Constrained
);
7422 Set_Etype
(Parameter_Exp
, Etype
(Standard_Boolean
));
7425 Make_Object_Declaration
(Loc
,
7426 Defining_Identifier
=> Extra_Any_Parameter
,
7427 Aliased_Present
=> False,
7428 Object_Definition
=>
7429 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7431 PolyORB_Support
.Helpers
.Build_To_Any_Call
7432 (Parameter_Exp
, Decls
)));
7434 Append_To
(Extra_Formal_Statements
,
7435 Add_Parameter_To_NVList
(Loc
,
7436 Parameter
=> Extra_Any_Parameter
,
7437 NVList
=> Arguments
,
7438 Constrained
=> True,
7439 Any
=> Extra_Any_Parameter
));
7443 Next
(Current_Parameter
);
7446 -- Append the formal statements list to the statements
7448 Append_List_To
(Statements
, Extra_Formal_Statements
);
7450 Append_To
(Statements
,
7451 Make_Procedure_Call_Statement
(Loc
,
7453 New_Occurrence_Of
(RTE
(RE_Request_Create
), Loc
),
7455 Parameter_Associations
=> New_List
(
7458 New_Occurrence_Of
(Arguments
, Loc
),
7459 New_Occurrence_Of
(Result
, Loc
),
7460 New_Occurrence_Of
(RTE
(RE_Nil_Exc_List
), Loc
))));
7462 Append_To
(Parameter_Associations
(Last
(Statements
)),
7463 New_Occurrence_Of
(Request
, Loc
));
7466 (not (Is_Known_Non_Asynchronous
and Is_Known_Asynchronous
));
7468 if Is_Known_Non_Asynchronous
or Is_Known_Asynchronous
then
7471 (Boolean_Literals
(Is_Known_Asynchronous
), Loc
);
7474 pragma Assert
(Present
(Asynchronous
));
7475 Asynchronous_P
:= New_Copy_Tree
(Asynchronous
);
7477 -- The expression node Asynchronous will be used to build an 'if'
7478 -- statement at the end of Build_General_Calling_Stubs: we need to
7479 -- make a copy here.
7482 Append_To
(Parameter_Associations
(Last
(Statements
)),
7483 Make_Indexed_Component
(Loc
,
7486 RTE
(RE_Asynchronous_P_To_Sync_Scope
), Loc
),
7487 Expressions
=> New_List
(Asynchronous_P
)));
7489 Append_To
(Statements
,
7490 Make_Procedure_Call_Statement
(Loc
,
7492 New_Occurrence_Of
(RTE
(RE_Request_Invoke
), Loc
),
7493 Parameter_Associations
=> New_List
(
7494 New_Occurrence_Of
(Request
, Loc
))));
7496 Non_Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7497 Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7499 if not Is_Known_Asynchronous
then
7501 -- Reraise an exception occurrence from the completed request.
7502 -- If the exception occurrence is empty, this is a no-op.
7504 Append_To
(Non_Asynchronous_Statements
,
7505 Make_Procedure_Call_Statement
(Loc
,
7507 New_Occurrence_Of
(RTE
(RE_Request_Raise_Occurrence
), Loc
),
7508 Parameter_Associations
=> New_List
(
7509 New_Occurrence_Of
(Request
, Loc
))));
7513 -- If this is a function call, read the value and return it
7515 Append_To
(Non_Asynchronous_Statements
,
7516 Make_Tag_Check
(Loc
,
7517 Make_Simple_Return_Statement
(Loc
,
7518 PolyORB_Support
.Helpers
.Build_From_Any_Call
7519 (Etype
(Result_Definition
(Spec
)),
7520 Make_Selected_Component
(Loc
,
7522 Selector_Name
=> Name_Argument
),
7527 Append_List_To
(Non_Asynchronous_Statements
, After_Statements
);
7529 if Is_Known_Asynchronous
then
7530 Append_List_To
(Statements
, Asynchronous_Statements
);
7532 elsif Is_Known_Non_Asynchronous
then
7533 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
7536 pragma Assert
(Present
(Asynchronous
));
7537 Append_To
(Statements
,
7538 Make_Implicit_If_Statement
(Nod
,
7539 Condition
=> Asynchronous
,
7540 Then_Statements
=> Asynchronous_Statements
,
7541 Else_Statements
=> Non_Asynchronous_Statements
));
7543 end Build_General_Calling_Stubs
;
7545 -----------------------
7546 -- Build_Stub_Target --
7547 -----------------------
7549 function Build_Stub_Target
7552 RCI_Locator
: Entity_Id
;
7553 Controlling_Parameter
: Entity_Id
) return RPC_Target
7555 Target_Info
: RPC_Target
(PCS_Kind
=> Name_PolyORB_DSA
);
7556 Target_Reference
: constant Entity_Id
:=
7557 Make_Defining_Identifier
(Loc
,
7558 New_Internal_Name
('T'));
7560 if Present
(Controlling_Parameter
) then
7562 Make_Object_Declaration
(Loc
,
7563 Defining_Identifier
=> Target_Reference
,
7565 Object_Definition
=>
7566 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
7569 Make_Function_Call
(Loc
,
7571 New_Occurrence_Of
(RTE
(RE_Make_Ref
), Loc
),
7572 Parameter_Associations
=> New_List
(
7573 Make_Selected_Component
(Loc
,
7574 Prefix
=> Controlling_Parameter
,
7575 Selector_Name
=> Name_Target
)))));
7577 -- Note: Controlling_Parameter has the same components as
7578 -- System.Partition_Interface.RACW_Stub_Type.
7580 Target_Info
.Object
:= New_Occurrence_Of
(Target_Reference
, Loc
);
7583 Target_Info
.Object
:=
7584 Make_Selected_Component
(Loc
,
7585 Prefix
=> Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
7587 Make_Identifier
(Loc
, Name_Get_RCI_Package_Ref
));
7591 end Build_Stub_Target
;
7593 ---------------------
7594 -- Build_Stub_Type --
7595 ---------------------
7597 procedure Build_Stub_Type
7598 (RACW_Type
: Entity_Id
;
7599 Stub_Type
: Entity_Id
;
7600 Stub_Type_Decl
: out Node_Id
;
7601 RPC_Receiver_Decl
: out Node_Id
)
7603 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
7604 pragma Warnings
(Off
);
7605 pragma Unreferenced
(RACW_Type
);
7606 pragma Warnings
(On
);
7610 Make_Full_Type_Declaration
(Loc
,
7611 Defining_Identifier
=> Stub_Type
,
7613 Make_Record_Definition
(Loc
,
7614 Tagged_Present
=> True,
7615 Limited_Present
=> True,
7617 Make_Component_List
(Loc
,
7618 Component_Items
=> New_List
(
7620 Make_Component_Declaration
(Loc
,
7621 Defining_Identifier
=>
7622 Make_Defining_Identifier
(Loc
, Name_Target
),
7623 Component_Definition
=>
7624 Make_Component_Definition
(Loc
,
7625 Aliased_Present
=> False,
7626 Subtype_Indication
=>
7627 New_Occurrence_Of
(RTE
(RE_Entity_Ptr
), Loc
))),
7629 Make_Component_Declaration
(Loc
,
7630 Defining_Identifier
=>
7631 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
7633 Component_Definition
=>
7634 Make_Component_Definition
(Loc
,
7635 Aliased_Present
=> False,
7636 Subtype_Indication
=>
7637 New_Occurrence_Of
(Standard_Boolean
, Loc
)))))));
7639 RPC_Receiver_Decl
:=
7640 Make_Object_Declaration
(Loc
,
7641 Defining_Identifier
=> Make_Defining_Identifier
(Loc
,
7642 New_Internal_Name
('R')),
7643 Aliased_Present
=> True,
7644 Object_Definition
=>
7645 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7646 end Build_Stub_Type
;
7648 -----------------------------
7649 -- Build_RPC_Receiver_Body --
7650 -----------------------------
7652 procedure Build_RPC_Receiver_Body
7653 (RPC_Receiver
: Entity_Id
;
7654 Request
: out Entity_Id
;
7655 Subp_Id
: out Entity_Id
;
7656 Subp_Index
: out Entity_Id
;
7657 Stmts
: out List_Id
;
7660 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
7662 RPC_Receiver_Spec
: Node_Id
;
7663 RPC_Receiver_Decls
: List_Id
;
7666 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
7668 RPC_Receiver_Spec
:=
7669 Build_RPC_Receiver_Specification
(
7670 RPC_Receiver
=> RPC_Receiver
,
7671 Request_Parameter
=> Request
);
7673 Subp_Id
:= Make_Defining_Identifier
(Loc
, Name_P
);
7674 Subp_Index
:= Make_Defining_Identifier
(Loc
, Name_I
);
7676 RPC_Receiver_Decls
:= New_List
(
7677 Make_Object_Renaming_Declaration
(Loc
,
7678 Defining_Identifier
=> Subp_Id
,
7679 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
7681 Make_Explicit_Dereference
(Loc
,
7683 Make_Selected_Component
(Loc
,
7685 Selector_Name
=> Name_Operation
))),
7687 Make_Object_Declaration
(Loc
,
7688 Defining_Identifier
=> Subp_Index
,
7689 Object_Definition
=>
7690 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7692 Make_Attribute_Reference
(Loc
,
7694 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7695 Attribute_Name
=> Name_Last
)));
7700 Make_Subprogram_Body
(Loc
,
7701 Specification
=> RPC_Receiver_Spec
,
7702 Declarations
=> RPC_Receiver_Decls
,
7703 Handled_Statement_Sequence
=>
7704 Make_Handled_Sequence_Of_Statements
(Loc
,
7705 Statements
=> Stmts
));
7706 end Build_RPC_Receiver_Body
;
7708 --------------------------------------
7709 -- Build_Subprogram_Receiving_Stubs --
7710 --------------------------------------
7712 function Build_Subprogram_Receiving_Stubs
7713 (Vis_Decl
: Node_Id
;
7714 Asynchronous
: Boolean;
7715 Dynamically_Asynchronous
: Boolean := False;
7716 Stub_Type
: Entity_Id
:= Empty
;
7717 RACW_Type
: Entity_Id
:= Empty
;
7718 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
7720 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
7722 Request_Parameter
: constant Entity_Id
:=
7723 Make_Defining_Identifier
(Loc
,
7724 New_Internal_Name
('R'));
7725 -- Formal parameter for receiving stubs: a descriptor for an incoming
7728 Outer_Decls
: constant List_Id
:= New_List
;
7729 -- At the outermost level, an NVList and Any's are declared for all
7730 -- parameters. The Dynamic_Async flag also needs to be declared there
7731 -- to be visible from the exception handling code.
7733 Outer_Statements
: constant List_Id
:= New_List
;
7734 -- Statements that occur prior to the declaration of the actual
7735 -- parameter variables.
7737 Outer_Extra_Formal_Statements
: constant List_Id
:= New_List
;
7738 -- Statements concerning extra formal parameters, prior to the
7739 -- declaration of the actual parameter variables.
7741 Decls
: constant List_Id
:= New_List
;
7742 -- All the parameters will get declared before calling the real
7743 -- subprograms. Also the out parameters will be declared.
7744 -- At this level, parameters may be unconstrained.
7746 Statements
: constant List_Id
:= New_List
;
7748 After_Statements
: constant List_Id
:= New_List
;
7749 -- Statements to be executed after the subprogram call
7751 Inner_Decls
: List_Id
:= No_List
;
7752 -- In case of a function, the inner declarations are needed since
7753 -- the result may be unconstrained.
7755 Excep_Handlers
: List_Id
:= No_List
;
7757 Parameter_List
: constant List_Id
:= New_List
;
7758 -- List of parameters to be passed to the subprogram
7760 First_Controlling_Formal_Seen
: Boolean := False;
7762 Current_Parameter
: Node_Id
;
7764 Ordered_Parameters_List
: constant List_Id
:=
7765 Build_Ordered_Parameters_List
7766 (Specification
(Vis_Decl
));
7768 Arguments
: constant Entity_Id
:=
7769 Make_Defining_Identifier
(Loc
,
7770 New_Internal_Name
('A'));
7771 -- Name of the named values list used to retrieve parameters
7773 Subp_Spec
: Node_Id
;
7774 -- Subprogram specification
7776 Called_Subprogram
: Node_Id
;
7777 -- The subprogram to call
7780 if Present
(RACW_Type
) then
7781 Called_Subprogram
:=
7782 New_Occurrence_Of
(Parent_Primitive
, Loc
);
7784 Called_Subprogram
:=
7786 (Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
7789 Declare_Create_NVList
(Loc
, Arguments
, Outer_Decls
, Outer_Statements
);
7791 -- Loop through every parameter and get its value from the stream. If
7792 -- the parameter is unconstrained, then the parameter is read using
7793 -- 'Input at the point of declaration.
7795 Current_Parameter
:= First
(Ordered_Parameters_List
);
7796 while Present
(Current_Parameter
) loop
7799 Constrained
: Boolean;
7800 Any
: Entity_Id
:= Empty
;
7801 Object
: constant Entity_Id
:=
7802 Make_Defining_Identifier
(Loc
,
7803 Chars
=> New_Internal_Name
('P'));
7804 Expr
: Node_Id
:= Empty
;
7806 Is_Controlling_Formal
: constant Boolean :=
7807 Is_RACW_Controlling_Formal
7808 (Current_Parameter
, Stub_Type
);
7810 Is_First_Controlling_Formal
: Boolean := False;
7812 Need_Extra_Constrained
: Boolean;
7813 -- True when an extra constrained actual is required
7816 if Is_Controlling_Formal
then
7818 -- Controlling formals in distributed object primitive
7819 -- operations are handled specially:
7820 -- - the first controlling formal is used as the
7821 -- target of the call;
7822 -- - the remaining controlling formals are transmitted
7826 Is_First_Controlling_Formal
:=
7827 not First_Controlling_Formal_Seen
;
7828 First_Controlling_Formal_Seen
:= True;
7831 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7835 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
7837 if not Is_First_Controlling_Formal
then
7839 Make_Defining_Identifier
(Loc
,
7840 Chars
=> New_Internal_Name
('A'));
7842 Append_To
(Outer_Decls
,
7843 Make_Object_Declaration
(Loc
,
7844 Defining_Identifier
=> Any
,
7845 Object_Definition
=>
7846 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7848 Make_Function_Call
(Loc
,
7849 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7850 Parameter_Associations
=> New_List
(
7851 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7852 (Loc
, Etyp
, Outer_Decls
)))));
7854 Append_To
(Outer_Statements
,
7855 Add_Parameter_To_NVList
(Loc
,
7856 Parameter
=> Current_Parameter
,
7857 NVList
=> Arguments
,
7858 Constrained
=> Constrained
,
7862 if Is_First_Controlling_Formal
then
7864 Addr
: constant Entity_Id
:=
7865 Make_Defining_Identifier
(Loc
,
7866 Chars
=> New_Internal_Name
('A'));
7868 Is_Local
: constant Entity_Id
:=
7869 Make_Defining_Identifier
(Loc
,
7870 Chars
=> New_Internal_Name
('L'));
7873 -- Special case: obtain the first controlling formal
7874 -- from the target of the remote call, instead of the
7877 Append_To
(Outer_Decls
,
7878 Make_Object_Declaration
(Loc
,
7879 Defining_Identifier
=> Addr
,
7880 Object_Definition
=>
7881 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
7883 Append_To
(Outer_Decls
,
7884 Make_Object_Declaration
(Loc
,
7885 Defining_Identifier
=> Is_Local
,
7886 Object_Definition
=>
7887 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7889 Append_To
(Outer_Statements
,
7890 Make_Procedure_Call_Statement
(Loc
,
7892 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
7893 Parameter_Associations
=> New_List
(
7894 Make_Selected_Component
(Loc
,
7897 Request_Parameter
, Loc
),
7899 Make_Identifier
(Loc
, Name_Target
)),
7900 New_Occurrence_Of
(Is_Local
, Loc
),
7901 New_Occurrence_Of
(Addr
, Loc
))));
7903 Expr
:= Unchecked_Convert_To
(RACW_Type
,
7904 New_Occurrence_Of
(Addr
, Loc
));
7907 elsif In_Present
(Current_Parameter
)
7908 or else not Out_Present
(Current_Parameter
)
7909 or else not Constrained
7911 -- If an input parameter is constrained, then its reading is
7912 -- deferred until the beginning of the subprogram body. If
7913 -- it is unconstrained, then an expression is built for
7914 -- the object declaration and the variable is set using
7915 -- 'Input instead of 'Read.
7917 Expr
:= PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7918 Etyp
, New_Occurrence_Of
(Any
, Loc
), Decls
);
7921 Append_To
(Statements
,
7922 Make_Assignment_Statement
(Loc
,
7923 Name
=> New_Occurrence_Of
(Object
, Loc
),
7924 Expression
=> Expr
));
7929 -- Expr will be used to initialize (and constrain) the
7930 -- parameter when it is declared.
7935 Need_Extra_Constrained
:=
7936 Nkind
(Parameter_Type
(Current_Parameter
)) /=
7939 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
7941 Present
(Extra_Constrained
7942 (Defining_Identifier
(Current_Parameter
)));
7944 -- We may not associate an extra constrained actual to a
7945 -- constant object, so if one is needed, declare the actual
7946 -- as a variable even if it won't be modified.
7948 Build_Actual_Object_Declaration
7951 Variable
=> Need_Extra_Constrained
7952 or else Out_Present
(Current_Parameter
),
7955 Set_Etype
(Object
, Etyp
);
7957 -- An out parameter may be written back using a 'Write
7958 -- attribute instead of a 'Output because it has been
7959 -- constrained by the parameter given to the caller. Note that
7960 -- out controlling arguments in the case of a RACW are not put
7961 -- back in the stream because the pointer on them has not
7964 if Out_Present
(Current_Parameter
)
7965 and then not Is_Controlling_Formal
7967 Append_To
(After_Statements
,
7968 Make_Procedure_Call_Statement
(Loc
,
7969 Name
=> New_Occurrence_Of
(RTE
(RE_Move_Any_Value
), Loc
),
7970 Parameter_Associations
=> New_List
(
7971 New_Occurrence_Of
(Any
, Loc
),
7972 PolyORB_Support
.Helpers
.Build_To_Any_Call
7973 (New_Occurrence_Of
(Object
, Loc
), Decls
))));
7976 -- For RACW controlling formals, the Etyp of Object is always
7977 -- an RACW, even if the parameter is not of an anonymous access
7978 -- type. In such case, we need to dereference it at call time.
7980 if Is_Controlling_Formal
then
7981 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7984 Append_To
(Parameter_List
,
7985 Make_Parameter_Association
(Loc
,
7988 (Defining_Identifier
(Current_Parameter
), Loc
),
7989 Explicit_Actual_Parameter
=>
7990 Make_Explicit_Dereference
(Loc
,
7992 Unchecked_Convert_To
(RACW_Type
,
7993 OK_Convert_To
(RTE
(RE_Address
),
7994 New_Occurrence_Of
(Object
, Loc
))))));
7997 Append_To
(Parameter_List
,
7998 Make_Parameter_Association
(Loc
,
8001 (Defining_Identifier
(Current_Parameter
), Loc
),
8003 Explicit_Actual_Parameter
=>
8004 Unchecked_Convert_To
(RACW_Type
,
8005 OK_Convert_To
(RTE
(RE_Address
),
8006 New_Occurrence_Of
(Object
, Loc
)))));
8010 Append_To
(Parameter_List
,
8011 Make_Parameter_Association
(Loc
,
8014 Defining_Identifier
(Current_Parameter
), Loc
),
8015 Explicit_Actual_Parameter
=>
8016 New_Occurrence_Of
(Object
, Loc
)));
8019 -- If the current parameter needs an extra formal, then read it
8020 -- from the stream and set the corresponding semantic field in
8021 -- the variable. If the kind of the parameter identifier is
8022 -- E_Void, then this is a compiler generated parameter that
8023 -- doesn't need an extra constrained status.
8025 -- The case of Extra_Accessibility should also be handled ???
8027 if Need_Extra_Constrained
then
8029 Extra_Parameter
: constant Entity_Id
:=
8031 (Defining_Identifier
8032 (Current_Parameter
));
8034 Extra_Any
: constant Entity_Id
:=
8035 Make_Defining_Identifier
(Loc
,
8036 Chars
=> New_Internal_Name
('A'));
8038 Formal_Entity
: constant Entity_Id
:=
8039 Make_Defining_Identifier
(Loc
,
8040 Chars
=> Chars
(Extra_Parameter
));
8042 Formal_Type
: constant Entity_Id
:=
8043 Etype
(Extra_Parameter
);
8046 Append_To
(Outer_Decls
,
8047 Make_Object_Declaration
(Loc
,
8048 Defining_Identifier
=> Extra_Any
,
8049 Object_Definition
=>
8050 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8052 Make_Function_Call
(Loc
,
8054 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
8055 Parameter_Associations
=> New_List
(
8056 PolyORB_Support
.Helpers
.Build_TypeCode_Call
8057 (Loc
, Formal_Type
, Outer_Decls
)))));
8059 Append_To
(Outer_Extra_Formal_Statements
,
8060 Add_Parameter_To_NVList
(Loc
,
8061 Parameter
=> Extra_Parameter
,
8062 NVList
=> Arguments
,
8063 Constrained
=> True,
8067 Make_Object_Declaration
(Loc
,
8068 Defining_Identifier
=> Formal_Entity
,
8069 Object_Definition
=>
8070 New_Occurrence_Of
(Formal_Type
, Loc
)));
8072 Append_To
(Statements
,
8073 Make_Assignment_Statement
(Loc
,
8074 Name
=> New_Occurrence_Of
(Formal_Entity
, Loc
),
8076 PolyORB_Support
.Helpers
.Build_From_Any_Call
8078 New_Occurrence_Of
(Extra_Any
, Loc
),
8080 Set_Extra_Constrained
(Object
, Formal_Entity
);
8085 Next
(Current_Parameter
);
8088 -- Extra Formals should go after all the other parameters
8090 Append_List_To
(Outer_Statements
, Outer_Extra_Formal_Statements
);
8092 Append_To
(Outer_Statements
,
8093 Make_Procedure_Call_Statement
(Loc
,
8094 Name
=> New_Occurrence_Of
(RTE
(RE_Request_Arguments
), Loc
),
8095 Parameter_Associations
=> New_List
(
8096 New_Occurrence_Of
(Request_Parameter
, Loc
),
8097 New_Occurrence_Of
(Arguments
, Loc
))));
8099 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
8101 -- The remote subprogram is a function: Build an inner block to be
8102 -- able to hold a potentially unconstrained result in a variable.
8105 Etyp
: constant Entity_Id
:=
8106 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
8107 Result
: constant Node_Id
:=
8108 Make_Defining_Identifier
(Loc
,
8109 Chars
=> New_Internal_Name
('R'));
8112 Inner_Decls
:= New_List
(
8113 Make_Object_Declaration
(Loc
,
8114 Defining_Identifier
=> Result
,
8115 Constant_Present
=> True,
8116 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
8118 Make_Function_Call
(Loc
,
8119 Name
=> Called_Subprogram
,
8120 Parameter_Associations
=> Parameter_List
)));
8122 if Is_Class_Wide_Type
(Etyp
) then
8124 -- For a remote call to a function with a class-wide type,
8125 -- check that the returned value satisfies the requirements
8128 Append_To
(Inner_Decls
,
8129 Make_Transportable_Check
(Loc
,
8130 New_Occurrence_Of
(Result
, Loc
)));
8134 Set_Etype
(Result
, Etyp
);
8135 Append_To
(After_Statements
,
8136 Make_Procedure_Call_Statement
(Loc
,
8137 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Result
), Loc
),
8138 Parameter_Associations
=> New_List
(
8139 New_Occurrence_Of
(Request_Parameter
, Loc
),
8140 PolyORB_Support
.Helpers
.Build_To_Any_Call
8141 (New_Occurrence_Of
(Result
, Loc
), Decls
))));
8143 -- A DSA function does not have out or inout arguments
8146 Append_To
(Statements
,
8147 Make_Block_Statement
(Loc
,
8148 Declarations
=> Inner_Decls
,
8149 Handled_Statement_Sequence
=>
8150 Make_Handled_Sequence_Of_Statements
(Loc
,
8151 Statements
=> After_Statements
)));
8154 -- The remote subprogram is a procedure. We do not need any inner
8155 -- block in this case. No specific processing is required here for
8156 -- the dynamically asynchronous case: the indication of whether
8157 -- call is asynchronous or not is managed by the Sync_Scope
8158 -- attibute of the request, and is handled entirely in the
8161 Append_To
(After_Statements
,
8162 Make_Procedure_Call_Statement
(Loc
,
8163 Name
=> New_Occurrence_Of
(RTE
(RE_Request_Set_Out
), Loc
),
8164 Parameter_Associations
=> New_List
(
8165 New_Occurrence_Of
(Request_Parameter
, Loc
))));
8167 Append_To
(Statements
,
8168 Make_Procedure_Call_Statement
(Loc
,
8169 Name
=> Called_Subprogram
,
8170 Parameter_Associations
=> Parameter_List
));
8172 Append_List_To
(Statements
, After_Statements
);
8176 Make_Procedure_Specification
(Loc
,
8177 Defining_Unit_Name
=>
8178 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
8180 Parameter_Specifications
=> New_List
(
8181 Make_Parameter_Specification
(Loc
,
8182 Defining_Identifier
=> Request_Parameter
,
8184 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
8186 -- An exception raised during the execution of an incoming
8187 -- remote subprogram call and that needs to be sent back
8188 -- to the caller is propagated by the receiving stubs, and
8189 -- will be handled by the caller (the distribution runtime).
8191 if Asynchronous
and then not Dynamically_Asynchronous
then
8193 -- For an asynchronous procedure, add a null exception handler
8195 Excep_Handlers
:= New_List
(
8196 Make_Implicit_Exception_Handler
(Loc
,
8197 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8198 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
8201 -- In the other cases, if an exception is raised, then the
8202 -- exception occurrence is propagated.
8207 Append_To
(Outer_Statements
,
8208 Make_Block_Statement
(Loc
,
8209 Declarations
=> Decls
,
8210 Handled_Statement_Sequence
=>
8211 Make_Handled_Sequence_Of_Statements
(Loc
,
8212 Statements
=> Statements
)));
8215 Make_Subprogram_Body
(Loc
,
8216 Specification
=> Subp_Spec
,
8217 Declarations
=> Outer_Decls
,
8218 Handled_Statement_Sequence
=>
8219 Make_Handled_Sequence_Of_Statements
(Loc
,
8220 Statements
=> Outer_Statements
,
8221 Exception_Handlers
=> Excep_Handlers
));
8222 end Build_Subprogram_Receiving_Stubs
;
8228 package body Helpers
is
8230 -----------------------
8231 -- Local Subprograms --
8232 -----------------------
8234 function Find_Numeric_Representation
8235 (Typ
: Entity_Id
) return Entity_Id
;
8236 -- Given a numeric type Typ, return the smallest integer or floating
8237 -- point type from Standard, or the smallest unsigned (modular) type
8238 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8240 function Make_Helper_Function_Name
8243 Nam
: Name_Id
) return Entity_Id
;
8244 -- Return the name to be assigned for helper subprogram Nam of Typ
8246 ------------------------------------------------------------
8247 -- Common subprograms for building various tree fragments --
8248 ------------------------------------------------------------
8250 function Build_Get_Aggregate_Element
8254 Idx
: Node_Id
) return Node_Id
;
8255 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8256 -- returning the Idx'th element.
8259 Subprogram
: Entity_Id
;
8260 -- Reference location for constructed nodes
8263 -- For 'Range and Etype
8266 -- For the construction of the innermost element expression
8268 with procedure Add_Process_Element
8271 Counter
: Entity_Id
;
8274 procedure Append_Array_Traversal
8277 Counter
: Entity_Id
:= Empty
;
8279 -- Build nested loop statements that iterate over the elements of an
8280 -- array Arry. The statement(s) built by Add_Process_Element are
8281 -- executed for each element; Indices is the list of indices to be
8282 -- used in the construction of the indexed component that denotes the
8283 -- current element. Subprogram is the entity for the subprogram for
8284 -- which this iterator is generated. The generated statements are
8285 -- appended to Stmts.
8289 -- The record entity being dealt with
8291 with procedure Add_Process_Element
8293 Container
: Node_Or_Entity_Id
;
8294 Counter
: in out Int
;
8297 -- Rec is the instance of the record type, or Empty.
8298 -- Field is either the N_Defining_Identifier for a component,
8299 -- or an N_Variant_Part.
8301 procedure Append_Record_Traversal
8304 Container
: Node_Or_Entity_Id
;
8305 Counter
: in out Int
);
8306 -- Process component list Clist. Individual fields are passed
8307 -- to Field_Processing. Each variant part is also processed.
8308 -- Container is the outer Any (for From_Any/To_Any),
8309 -- the outer typecode (for TC) to which the operation applies.
8311 -----------------------------
8312 -- Append_Record_Traversal --
8313 -----------------------------
8315 procedure Append_Record_Traversal
8318 Container
: Node_Or_Entity_Id
;
8319 Counter
: in out Int
)
8323 -- Clist's Component_Items and Variant_Part
8333 CI
:= Component_Items
(Clist
);
8334 VP
:= Variant_Part
(Clist
);
8337 while Present
(Item
) loop
8338 Def
:= Defining_Identifier
(Item
);
8340 if not Is_Internal_Name
(Chars
(Def
)) then
8342 (Stmts
, Container
, Counter
, Rec
, Def
);
8348 if Present
(VP
) then
8349 Add_Process_Element
(Stmts
, Container
, Counter
, Rec
, VP
);
8351 end Append_Record_Traversal
;
8353 -------------------------
8354 -- Build_From_Any_Call --
8355 -------------------------
8357 function Build_From_Any_Call
8360 Decls
: List_Id
) return Node_Id
8362 Loc
: constant Source_Ptr
:= Sloc
(N
);
8364 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
8366 Fnam
: Entity_Id
:= Empty
;
8367 Lib_RE
: RE_Id
:= RE_Null
;
8371 -- First simple case where the From_Any function is present
8372 -- in the type's TSS.
8374 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_From_Any
);
8376 if Sloc
(U_Type
) <= Standard_Location
then
8377 U_Type
:= Base_Type
(U_Type
);
8380 -- Check first for Boolean and Character. These are enumeration
8381 -- types, but we treat them specially, since they may require
8382 -- special handling in the transfer protocol. However, this
8383 -- special handling only applies if they have standard
8384 -- representation, otherwise they are treated like any other
8385 -- enumeration type.
8387 if Present
(Fnam
) then
8390 elsif U_Type
= Standard_Boolean
then
8393 elsif U_Type
= Standard_Character
then
8396 elsif U_Type
= Standard_Wide_Character
then
8399 elsif U_Type
= Standard_Wide_Wide_Character
then
8400 Lib_RE
:= RE_FA_WWC
;
8402 -- Floating point types
8404 elsif U_Type
= Standard_Short_Float
then
8407 elsif U_Type
= Standard_Float
then
8410 elsif U_Type
= Standard_Long_Float
then
8413 elsif U_Type
= Standard_Long_Long_Float
then
8414 Lib_RE
:= RE_FA_LLF
;
8418 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
8419 Lib_RE
:= RE_FA_SSI
;
8421 elsif U_Type
= Etype
(Standard_Short_Integer
) then
8424 elsif U_Type
= Etype
(Standard_Integer
) then
8427 elsif U_Type
= Etype
(Standard_Long_Integer
) then
8430 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
8431 Lib_RE
:= RE_FA_LLI
;
8433 -- Unsigned integer types
8435 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
8436 Lib_RE
:= RE_FA_SSU
;
8438 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
8441 elsif U_Type
= RTE
(RE_Unsigned
) then
8444 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
8447 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
8448 Lib_RE
:= RE_FA_LLU
;
8450 elsif U_Type
= Standard_String
then
8451 Lib_RE
:= RE_FA_String
;
8453 -- Special DSA types
8455 elsif Is_RTE
(U_Type
, RE_Any_Container_Ptr
) then
8458 -- Other (non-primitive) types
8464 Build_From_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
8465 Append_To
(Decls
, Decl
);
8469 -- Call the function
8471 if Lib_RE
/= RE_Null
then
8472 pragma Assert
(No
(Fnam
));
8473 Fnam
:= RTE
(Lib_RE
);
8477 Make_Function_Call
(Loc
,
8478 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
8479 Parameter_Associations
=> New_List
(N
));
8481 -- We must set the type of Result, so the unchecked conversion
8482 -- from the underlying type to the base type is properly done.
8484 Set_Etype
(Result
, U_Type
);
8486 return Unchecked_Convert_To
(Typ
, Result
);
8487 end Build_From_Any_Call
;
8489 -----------------------------
8490 -- Build_From_Any_Function --
8491 -----------------------------
8493 procedure Build_From_Any_Function
8497 Fnam
: out Entity_Id
)
8500 Decls
: constant List_Id
:= New_List
;
8501 Stms
: constant List_Id
:= New_List
;
8503 Any_Parameter
: constant Entity_Id
:=
8504 Make_Defining_Identifier
(Loc
,
8505 New_Internal_Name
('A'));
8507 Use_Opaque_Representation
: Boolean;
8510 if Is_Itype
(Typ
) then
8511 Build_From_Any_Function
8519 Fnam
:= Make_Helper_Function_Name
(Loc
, Typ
, Name_From_Any
);
8522 Make_Function_Specification
(Loc
,
8523 Defining_Unit_Name
=> Fnam
,
8524 Parameter_Specifications
=> New_List
(
8525 Make_Parameter_Specification
(Loc
,
8526 Defining_Identifier
=> Any_Parameter
,
8527 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
8528 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
8530 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8533 (not (Is_Remote_Access_To_Class_Wide_Type
(Typ
)));
8535 Use_Opaque_Representation
:= False;
8537 if Has_Stream_Attribute_Definition
8538 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
8540 Has_Stream_Attribute_Definition
8541 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
8543 -- If user-defined stream attributes are specified for this
8544 -- type, use them and transmit data as an opaque sequence of
8547 Use_Opaque_Representation
:= True;
8549 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
8551 Make_Simple_Return_Statement
(Loc
,
8556 New_Occurrence_Of
(Any_Parameter
, Loc
),
8559 elsif Is_Record_Type
(Typ
)
8560 and then not Is_Derived_Type
(Typ
)
8561 and then not Is_Tagged_Type
(Typ
)
8563 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
8565 Make_Simple_Return_Statement
(Loc
,
8570 New_Occurrence_Of
(Any_Parameter
, Loc
),
8575 Disc
: Entity_Id
:= Empty
;
8576 Discriminant_Associations
: List_Id
;
8577 Rdef
: constant Node_Id
:=
8579 (Declaration_Node
(Typ
));
8580 Component_Counter
: Int
:= 0;
8582 -- The returned object
8584 Res
: constant Entity_Id
:=
8585 Make_Defining_Identifier
(Loc
,
8586 New_Internal_Name
('R'));
8588 Res_Definition
: Node_Id
:= New_Occurrence_Of
(Typ
, Loc
);
8590 procedure FA_Rec_Add_Process_Element
8593 Counter
: in out Int
;
8597 procedure FA_Append_Record_Traversal
is
8598 new Append_Record_Traversal
8600 Add_Process_Element
=> FA_Rec_Add_Process_Element
);
8602 --------------------------------
8603 -- FA_Rec_Add_Process_Element --
8604 --------------------------------
8606 procedure FA_Rec_Add_Process_Element
8609 Counter
: in out Int
;
8614 if Nkind
(Field
) = N_Defining_Identifier
then
8616 -- A regular component
8619 Make_Assignment_Statement
(Loc
,
8620 Name
=> Make_Selected_Component
(Loc
,
8622 New_Occurrence_Of
(Rec
, Loc
),
8624 New_Occurrence_Of
(Field
, Loc
)),
8626 Build_From_Any_Call
(Etype
(Field
),
8627 Build_Get_Aggregate_Element
(Loc
,
8629 TC
=> Build_TypeCode_Call
(Loc
,
8630 Etype
(Field
), Decls
),
8631 Idx
=> Make_Integer_Literal
(Loc
,
8640 Struct_Counter
: Int
:= 0;
8642 Block_Decls
: constant List_Id
:= New_List
;
8643 Block_Stmts
: constant List_Id
:= New_List
;
8646 Alt_List
: constant List_Id
:= New_List
;
8647 Choice_List
: List_Id
;
8649 Struct_Any
: constant Entity_Id
:=
8650 Make_Defining_Identifier
(Loc
,
8651 New_Internal_Name
('S'));
8655 Make_Object_Declaration
(Loc
,
8656 Defining_Identifier
=> Struct_Any
,
8657 Constant_Present
=> True,
8658 Object_Definition
=>
8659 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8661 Make_Function_Call
(Loc
,
8664 (RTE
(RE_Extract_Union_Value
), Loc
),
8666 Parameter_Associations
=> New_List
(
8667 Build_Get_Aggregate_Element
(Loc
,
8670 Make_Function_Call
(Loc
,
8671 Name
=> New_Occurrence_Of
(
8672 RTE
(RE_Any_Member_Type
), Loc
),
8673 Parameter_Associations
=>
8675 New_Occurrence_Of
(Any
, Loc
),
8676 Make_Integer_Literal
(Loc
,
8677 Intval
=> Counter
))),
8679 Make_Integer_Literal
(Loc
,
8680 Intval
=> Counter
))))));
8683 Make_Block_Statement
(Loc
,
8684 Declarations
=> Block_Decls
,
8685 Handled_Statement_Sequence
=>
8686 Make_Handled_Sequence_Of_Statements
(Loc
,
8687 Statements
=> Block_Stmts
)));
8689 Append_To
(Block_Stmts
,
8690 Make_Case_Statement
(Loc
,
8692 Make_Selected_Component
(Loc
,
8694 Selector_Name
=> Chars
(Name
(Field
))),
8695 Alternatives
=> Alt_List
));
8697 Variant
:= First_Non_Pragma
(Variants
(Field
));
8698 while Present
(Variant
) loop
8701 (Discrete_Choices
(Variant
));
8703 VP_Stmts
:= New_List
;
8705 -- Struct_Counter should be reset before
8706 -- handling a variant part. Indeed only one
8707 -- of the case statement alternatives will be
8708 -- executed at run-time, so the counter must
8709 -- start at 0 for every case statement.
8711 Struct_Counter
:= 0;
8713 FA_Append_Record_Traversal
(
8715 Clist
=> Component_List
(Variant
),
8716 Container
=> Struct_Any
,
8717 Counter
=> Struct_Counter
);
8719 Append_To
(Alt_List
,
8720 Make_Case_Statement_Alternative
(Loc
,
8721 Discrete_Choices
=> Choice_List
,
8722 Statements
=> VP_Stmts
));
8723 Next_Non_Pragma
(Variant
);
8728 Counter
:= Counter
+ 1;
8729 end FA_Rec_Add_Process_Element
;
8732 -- First all discriminants
8734 if Has_Discriminants
(Typ
) then
8735 Discriminant_Associations
:= New_List
;
8737 Disc
:= First_Discriminant
(Typ
);
8738 while Present
(Disc
) loop
8740 Disc_Var_Name
: constant Entity_Id
:=
8741 Make_Defining_Identifier
(Loc
,
8742 Chars
=> Chars
(Disc
));
8743 Disc_Type
: constant Entity_Id
:=
8748 Make_Object_Declaration
(Loc
,
8749 Defining_Identifier
=> Disc_Var_Name
,
8750 Constant_Present
=> True,
8751 Object_Definition
=>
8752 New_Occurrence_Of
(Disc_Type
, Loc
),
8755 Build_From_Any_Call
(Disc_Type
,
8756 Build_Get_Aggregate_Element
(Loc
,
8757 Any
=> Any_Parameter
,
8758 TC
=> Build_TypeCode_Call
8759 (Loc
, Disc_Type
, Decls
),
8760 Idx
=> Make_Integer_Literal
(Loc
,
8761 Intval
=> Component_Counter
)),
8764 Component_Counter
:= Component_Counter
+ 1;
8766 Append_To
(Discriminant_Associations
,
8767 Make_Discriminant_Association
(Loc
,
8768 Selector_Names
=> New_List
(
8769 New_Occurrence_Of
(Disc
, Loc
)),
8771 New_Occurrence_Of
(Disc_Var_Name
, Loc
)));
8773 Next_Discriminant
(Disc
);
8777 Make_Subtype_Indication
(Loc
,
8778 Subtype_Mark
=> Res_Definition
,
8780 Make_Index_Or_Discriminant_Constraint
(Loc
,
8781 Discriminant_Associations
));
8784 -- Now we have all the discriminants in variables, we can
8785 -- declared a constrained object. Note that we are not
8786 -- initializing (non-discriminant) components directly in
8787 -- the object declarations, because which fields to
8788 -- initialize depends (at run time) on the discriminant
8792 Make_Object_Declaration
(Loc
,
8793 Defining_Identifier
=> Res
,
8794 Object_Definition
=> Res_Definition
));
8796 -- ... then all components
8798 FA_Append_Record_Traversal
(Stms
,
8799 Clist
=> Component_List
(Rdef
),
8800 Container
=> Any_Parameter
,
8801 Counter
=> Component_Counter
);
8804 Make_Simple_Return_Statement
(Loc
,
8805 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
8809 elsif Is_Array_Type
(Typ
) then
8811 Constrained
: constant Boolean := Is_Constrained
(Typ
);
8813 procedure FA_Ary_Add_Process_Element
8816 Counter
: Entity_Id
;
8818 -- Assign the current element (as identified by Counter) of
8819 -- Any to the variable denoted by name Datum, and advance
8820 -- Counter by 1. If Datum is not an Any, a call to From_Any
8821 -- for its type is inserted.
8823 --------------------------------
8824 -- FA_Ary_Add_Process_Element --
8825 --------------------------------
8827 procedure FA_Ary_Add_Process_Element
8830 Counter
: Entity_Id
;
8833 Assignment
: constant Node_Id
:=
8834 Make_Assignment_Statement
(Loc
,
8836 Expression
=> Empty
);
8838 Element_Any
: Node_Id
;
8842 Element_TC
: Node_Id
;
8845 if Etype
(Datum
) = RTE
(RE_Any
) then
8847 -- When Datum is an Any the Etype field is not
8848 -- sufficient to determine the typecode of Datum
8849 -- (which can be a TC_SEQUENCE or TC_ARRAY
8850 -- depending on the value of Constrained).
8852 -- Therefore we retrieve the typecode which has
8853 -- been constructed in Append_Array_Traversal with
8854 -- a call to Get_Any_Type.
8857 Make_Function_Call
(Loc
,
8858 Name
=> New_Occurrence_Of
(
8859 RTE
(RE_Get_Any_Type
), Loc
),
8860 Parameter_Associations
=> New_List
(
8861 New_Occurrence_Of
(Entity
(Datum
), Loc
)));
8863 -- For non Any Datum we simply construct a typecode
8864 -- matching the Etype of the Datum.
8866 Element_TC
:= Build_TypeCode_Call
8867 (Loc
, Etype
(Datum
), Decls
);
8871 Build_Get_Aggregate_Element
(Loc
,
8874 Idx
=> New_Occurrence_Of
(Counter
, Loc
));
8877 -- Note: here we *prepend* statements to Stmts, so
8878 -- we must do it in reverse order.
8881 Make_Assignment_Statement
(Loc
,
8883 New_Occurrence_Of
(Counter
, Loc
),
8886 Left_Opnd
=> New_Occurrence_Of
(Counter
, Loc
),
8887 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
8889 if Nkind
(Datum
) /= N_Attribute_Reference
then
8891 -- We ignore the value of the length of each
8892 -- dimension, since the target array has already
8893 -- been constrained anyway.
8895 if Etype
(Datum
) /= RTE
(RE_Any
) then
8896 Set_Expression
(Assignment
,
8898 (Component_Type
(Typ
), Element_Any
, Decls
));
8900 Set_Expression
(Assignment
, Element_Any
);
8903 Prepend_To
(Stmts
, Assignment
);
8905 end FA_Ary_Add_Process_Element
;
8907 ------------------------
8908 -- Local Declarations --
8909 ------------------------
8911 Counter
: constant Entity_Id
:=
8912 Make_Defining_Identifier
(Loc
, Name_J
);
8914 Initial_Counter_Value
: Int
:= 0;
8916 Component_TC
: constant Entity_Id
:=
8917 Make_Defining_Identifier
(Loc
, Name_T
);
8919 Res
: constant Entity_Id
:=
8920 Make_Defining_Identifier
(Loc
, Name_R
);
8922 procedure Append_From_Any_Array_Iterator
is
8923 new Append_Array_Traversal
(
8926 Indices
=> New_List
,
8927 Add_Process_Element
=> FA_Ary_Add_Process_Element
);
8929 Res_Subtype_Indication
: Node_Id
:=
8930 New_Occurrence_Of
(Typ
, Loc
);
8933 if not Constrained
then
8935 Ndim
: constant Int
:= Number_Dimensions
(Typ
);
8938 Indx
: Node_Id
:= First_Index
(Typ
);
8941 Ranges
: constant List_Id
:= New_List
;
8944 for J
in 1 .. Ndim
loop
8945 Lnam
:= New_External_Name
('L', J
);
8946 Hnam
:= New_External_Name
('H', J
);
8947 Indt
:= Etype
(Indx
);
8950 Make_Object_Declaration
(Loc
,
8951 Defining_Identifier
=>
8952 Make_Defining_Identifier
(Loc
, Lnam
),
8953 Constant_Present
=> True,
8954 Object_Definition
=>
8955 New_Occurrence_Of
(Indt
, Loc
),
8959 Build_Get_Aggregate_Element
(Loc
,
8960 Any
=> Any_Parameter
,
8961 TC
=> Build_TypeCode_Call
8964 Make_Integer_Literal
(Loc
, J
- 1)),
8968 Make_Object_Declaration
(Loc
,
8969 Defining_Identifier
=>
8970 Make_Defining_Identifier
(Loc
, Hnam
),
8972 Constant_Present
=> True,
8974 Object_Definition
=>
8975 New_Occurrence_Of
(Indt
, Loc
),
8977 Expression
=> Make_Attribute_Reference
(Loc
,
8979 New_Occurrence_Of
(Indt
, Loc
),
8981 Attribute_Name
=> Name_Val
,
8983 Expressions
=> New_List
(
8984 Make_Op_Subtract
(Loc
,
8989 Standard_Long_Integer
,
8990 Make_Identifier
(Loc
, Lnam
)),
8994 Standard_Long_Integer
,
8995 Make_Function_Call
(Loc
,
8997 New_Occurrence_Of
(RTE
(
8998 RE_Get_Nested_Sequence_Length
9000 Parameter_Associations
=>
9003 Any_Parameter
, Loc
),
9004 Make_Integer_Literal
(Loc
,
9008 Make_Integer_Literal
(Loc
, 1))))));
9012 Low_Bound
=> Make_Identifier
(Loc
, Lnam
),
9013 High_Bound
=> Make_Identifier
(Loc
, Hnam
)));
9018 -- Now we have all the necessary bound information:
9019 -- apply the set of range constraints to the
9020 -- (unconstrained) nominal subtype of Res.
9022 Initial_Counter_Value
:= Ndim
;
9023 Res_Subtype_Indication
:= Make_Subtype_Indication
(Loc
,
9024 Subtype_Mark
=> Res_Subtype_Indication
,
9026 Make_Index_Or_Discriminant_Constraint
(Loc
,
9027 Constraints
=> Ranges
));
9032 Make_Object_Declaration
(Loc
,
9033 Defining_Identifier
=> Res
,
9034 Object_Definition
=> Res_Subtype_Indication
));
9035 Set_Etype
(Res
, Typ
);
9038 Make_Object_Declaration
(Loc
,
9039 Defining_Identifier
=> Counter
,
9040 Object_Definition
=>
9041 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
9043 Make_Integer_Literal
(Loc
, Initial_Counter_Value
)));
9046 Make_Object_Declaration
(Loc
,
9047 Defining_Identifier
=> Component_TC
,
9048 Constant_Present
=> True,
9049 Object_Definition
=>
9050 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
),
9052 Build_TypeCode_Call
(Loc
,
9053 Component_Type
(Typ
), Decls
)));
9055 Append_From_Any_Array_Iterator
9056 (Stms
, Any_Parameter
, Counter
);
9059 Make_Simple_Return_Statement
(Loc
,
9060 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
9063 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9065 Make_Simple_Return_Statement
(Loc
,
9067 Unchecked_Convert_To
(Typ
,
9069 (Find_Numeric_Representation
(Typ
),
9070 New_Occurrence_Of
(Any_Parameter
, Loc
),
9074 Use_Opaque_Representation
:= True;
9077 if Use_Opaque_Representation
then
9079 -- Default: type is represented as an opaque sequence of bytes
9082 Strm
: constant Entity_Id
:=
9083 Make_Defining_Identifier
(Loc
,
9084 Chars
=> New_Internal_Name
('S'));
9085 Res
: constant Entity_Id
:=
9086 Make_Defining_Identifier
(Loc
,
9087 Chars
=> New_Internal_Name
('R'));
9090 -- Strm : Buffer_Stream_Type;
9093 Make_Object_Declaration
(Loc
,
9094 Defining_Identifier
=> Strm
,
9095 Aliased_Present
=> True,
9096 Object_Definition
=>
9097 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
9099 -- Allocate_Buffer (Strm);
9102 Make_Procedure_Call_Statement
(Loc
,
9104 New_Occurrence_Of
(RTE
(RE_Allocate_Buffer
), Loc
),
9105 Parameter_Associations
=> New_List
(
9106 New_Occurrence_Of
(Strm
, Loc
))));
9108 -- Any_To_BS (Strm, A);
9111 Make_Procedure_Call_Statement
(Loc
,
9112 Name
=> New_Occurrence_Of
(RTE
(RE_Any_To_BS
), Loc
),
9113 Parameter_Associations
=> New_List
(
9114 New_Occurrence_Of
(Any_Parameter
, Loc
),
9115 New_Occurrence_Of
(Strm
, Loc
))));
9118 -- Res : constant T := T'Input (Strm);
9120 -- Release_Buffer (Strm);
9124 Append_To
(Stms
, Make_Block_Statement
(Loc
,
9125 Declarations
=> New_List
(
9126 Make_Object_Declaration
(Loc
,
9127 Defining_Identifier
=> Res
,
9128 Constant_Present
=> True,
9129 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
9131 Make_Attribute_Reference
(Loc
,
9132 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
9133 Attribute_Name
=> Name_Input
,
9134 Expressions
=> New_List
(
9135 Make_Attribute_Reference
(Loc
,
9136 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
9137 Attribute_Name
=> Name_Access
))))),
9139 Handled_Statement_Sequence
=>
9140 Make_Handled_Sequence_Of_Statements
(Loc
,
9141 Statements
=> New_List
(
9142 Make_Procedure_Call_Statement
(Loc
,
9144 New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
9145 Parameter_Associations
=>
9146 New_List
(New_Occurrence_Of
(Strm
, Loc
))),
9147 Make_Simple_Return_Statement
(Loc
,
9148 Expression
=> New_Occurrence_Of
(Res
, Loc
))))));
9154 Make_Subprogram_Body
(Loc
,
9155 Specification
=> Spec
,
9156 Declarations
=> Decls
,
9157 Handled_Statement_Sequence
=>
9158 Make_Handled_Sequence_Of_Statements
(Loc
,
9159 Statements
=> Stms
));
9160 end Build_From_Any_Function
;
9162 ---------------------------------
9163 -- Build_Get_Aggregate_Element --
9164 ---------------------------------
9166 function Build_Get_Aggregate_Element
9170 Idx
: Node_Id
) return Node_Id
9173 return Make_Function_Call
(Loc
,
9175 New_Occurrence_Of
(RTE
(RE_Get_Aggregate_Element
), Loc
),
9176 Parameter_Associations
=> New_List
(
9177 New_Occurrence_Of
(Any
, Loc
),
9180 end Build_Get_Aggregate_Element
;
9182 -------------------------
9183 -- Build_Reposiroty_Id --
9184 -------------------------
9186 procedure Build_Name_And_Repository_Id
9188 Name_Str
: out String_Id
;
9189 Repo_Id_Str
: out String_Id
)
9193 Store_String_Chars
("DSA:");
9194 Get_Library_Unit_Name_String
(Scope
(E
));
9196 (Name_Buffer
(Name_Buffer
'First ..
9197 Name_Buffer
'First + Name_Len
- 1));
9198 Store_String_Char
('.');
9199 Get_Name_String
(Chars
(E
));
9201 (Name_Buffer
(Name_Buffer
'First ..
9202 Name_Buffer
'First + Name_Len
- 1));
9203 Store_String_Chars
(":1.0");
9204 Repo_Id_Str
:= End_String
;
9205 Name_Str
:= String_From_Name_Buffer
;
9206 end Build_Name_And_Repository_Id
;
9208 -----------------------
9209 -- Build_To_Any_Call --
9210 -----------------------
9212 function Build_To_Any_Call
9214 Decls
: List_Id
) return Node_Id
9216 Loc
: constant Source_Ptr
:= Sloc
(N
);
9218 Typ
: Entity_Id
:= Etype
(N
);
9220 Fnam
: Entity_Id
:= Empty
;
9221 Lib_RE
: RE_Id
:= RE_Null
;
9224 -- If N is a selected component, then maybe its Etype has not been
9225 -- set yet: try to use Etype of the selector_name in that case.
9227 if No
(Typ
) and then Nkind
(N
) = N_Selected_Component
then
9228 Typ
:= Etype
(Selector_Name
(N
));
9230 pragma Assert
(Present
(Typ
));
9232 -- Get full view for private type, completion for incomplete type
9234 U_Type
:= Underlying_Type
(Typ
);
9236 -- First simple case where the To_Any function is present in the
9239 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_To_Any
);
9241 -- Check first for Boolean and Character. These are enumeration
9242 -- types, but we treat them specially, since they may require
9243 -- special handling in the transfer protocol. However, this
9244 -- special handling only applies if they have standard
9245 -- representation, otherwise they are treated like any other
9246 -- enumeration type.
9248 if Sloc
(U_Type
) <= Standard_Location
then
9249 U_Type
:= Base_Type
(U_Type
);
9252 if Present
(Fnam
) then
9255 elsif U_Type
= Standard_Boolean
then
9258 elsif U_Type
= Standard_Character
then
9261 elsif U_Type
= Standard_Wide_Character
then
9264 elsif U_Type
= Standard_Wide_Wide_Character
then
9265 Lib_RE
:= RE_TA_WWC
;
9267 -- Floating point types
9269 elsif U_Type
= Standard_Short_Float
then
9272 elsif U_Type
= Standard_Float
then
9275 elsif U_Type
= Standard_Long_Float
then
9278 elsif U_Type
= Standard_Long_Long_Float
then
9279 Lib_RE
:= RE_TA_LLF
;
9283 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
9284 Lib_RE
:= RE_TA_SSI
;
9286 elsif U_Type
= Etype
(Standard_Short_Integer
) then
9289 elsif U_Type
= Etype
(Standard_Integer
) then
9292 elsif U_Type
= Etype
(Standard_Long_Integer
) then
9295 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
9296 Lib_RE
:= RE_TA_LLI
;
9298 -- Unsigned integer types
9300 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
9301 Lib_RE
:= RE_TA_SSU
;
9303 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
9306 elsif U_Type
= RTE
(RE_Unsigned
) then
9309 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
9312 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
9313 Lib_RE
:= RE_TA_LLU
;
9315 elsif U_Type
= Standard_String
then
9316 Lib_RE
:= RE_TA_String
;
9318 -- Special DSA types
9320 elsif Is_RTE
(U_Type
, RE_Any_Container_Ptr
) then
9324 elsif U_Type
= Underlying_Type
(RTE
(RE_TypeCode
)) then
9326 -- No corresponding FA_TC ???
9330 -- Other (non-primitive) types
9336 Build_To_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
9337 Append_To
(Decls
, Decl
);
9341 -- Call the function
9343 if Lib_RE
/= RE_Null
then
9344 pragma Assert
(No
(Fnam
));
9345 Fnam
:= RTE
(Lib_RE
);
9349 Make_Function_Call
(Loc
,
9350 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
9351 Parameter_Associations
=>
9352 New_List
(Unchecked_Convert_To
(U_Type
, N
)));
9353 end Build_To_Any_Call
;
9355 ---------------------------
9356 -- Build_To_Any_Function --
9357 ---------------------------
9359 procedure Build_To_Any_Function
9363 Fnam
: out Entity_Id
)
9366 Decls
: constant List_Id
:= New_List
;
9367 Stms
: constant List_Id
:= New_List
;
9369 Expr_Parameter
: constant Entity_Id
:=
9370 Make_Defining_Identifier
(Loc
, Name_E
);
9372 Any
: constant Entity_Id
:=
9373 Make_Defining_Identifier
(Loc
, Name_A
);
9376 Result_TC
: Node_Id
:= Build_TypeCode_Call
(Loc
, Typ
, Decls
);
9378 Use_Opaque_Representation
: Boolean;
9379 -- When True, use stream attributes and represent type as an
9380 -- opaque sequence of bytes.
9383 if Is_Itype
(Typ
) then
9384 Build_To_Any_Function
9392 Fnam
:= Make_Helper_Function_Name
(Loc
, Typ
, Name_To_Any
);
9395 Make_Function_Specification
(Loc
,
9396 Defining_Unit_Name
=> Fnam
,
9397 Parameter_Specifications
=> New_List
(
9398 Make_Parameter_Specification
(Loc
,
9399 Defining_Identifier
=> Expr_Parameter
,
9400 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
9401 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9402 Set_Etype
(Expr_Parameter
, Typ
);
9405 Make_Object_Declaration
(Loc
,
9406 Defining_Identifier
=> Any
,
9407 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9409 Use_Opaque_Representation
:= False;
9411 if Has_Stream_Attribute_Definition
9412 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
9414 Has_Stream_Attribute_Definition
9415 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
9417 -- If user-defined stream attributes are specified for this
9418 -- type, use them and transmit data as an opaque sequence of
9421 Use_Opaque_Representation
:= True;
9423 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9425 -- Non-tagged derived type: convert to root type
9428 Rt_Type
: constant Entity_Id
:= Root_Type
(Typ
);
9429 Expr
: constant Node_Id
:=
9432 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9434 Set_Expression
(Any_Decl
, Build_To_Any_Call
(Expr
, Decls
));
9437 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9439 -- Non-tagged record type
9441 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
9443 Rt_Type
: constant Entity_Id
:= Etype
(Typ
);
9444 Expr
: constant Node_Id
:=
9445 OK_Convert_To
(Rt_Type
,
9446 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9450 (Any_Decl
, Build_To_Any_Call
(Expr
, Decls
));
9453 -- Comment needed here (and label on declare block ???)
9457 Disc
: Entity_Id
:= Empty
;
9458 Rdef
: constant Node_Id
:=
9459 Type_Definition
(Declaration_Node
(Typ
));
9461 Elements
: constant List_Id
:= New_List
;
9463 procedure TA_Rec_Add_Process_Element
9465 Container
: Node_Or_Entity_Id
;
9466 Counter
: in out Int
;
9469 -- Processing routine for traversal below
9471 procedure TA_Append_Record_Traversal
is
9472 new Append_Record_Traversal
9473 (Rec
=> Expr_Parameter
,
9474 Add_Process_Element
=> TA_Rec_Add_Process_Element
);
9476 --------------------------------
9477 -- TA_Rec_Add_Process_Element --
9478 --------------------------------
9480 procedure TA_Rec_Add_Process_Element
9482 Container
: Node_Or_Entity_Id
;
9483 Counter
: in out Int
;
9487 Field_Ref
: Node_Id
;
9490 if Nkind
(Field
) = N_Defining_Identifier
then
9492 -- A regular component
9494 Field_Ref
:= Make_Selected_Component
(Loc
,
9495 Prefix
=> New_Occurrence_Of
(Rec
, Loc
),
9496 Selector_Name
=> New_Occurrence_Of
(Field
, Loc
));
9497 Set_Etype
(Field_Ref
, Etype
(Field
));
9500 Make_Procedure_Call_Statement
(Loc
,
9503 RTE
(RE_Add_Aggregate_Element
), Loc
),
9504 Parameter_Associations
=> New_List
(
9505 New_Occurrence_Of
(Container
, Loc
),
9506 Build_To_Any_Call
(Field_Ref
, Decls
))));
9511 Variant_Part
: declare
9513 Struct_Counter
: Int
:= 0;
9515 Block_Decls
: constant List_Id
:= New_List
;
9516 Block_Stmts
: constant List_Id
:= New_List
;
9519 Alt_List
: constant List_Id
:= New_List
;
9520 Choice_List
: List_Id
;
9522 Union_Any
: constant Entity_Id
:=
9523 Make_Defining_Identifier
(Loc
,
9524 New_Internal_Name
('V'));
9526 Struct_Any
: constant Entity_Id
:=
9527 Make_Defining_Identifier
(Loc
,
9528 New_Internal_Name
('S'));
9530 function Make_Discriminant_Reference
9532 -- Build reference to the discriminant for this
9535 ---------------------------------
9536 -- Make_Discriminant_Reference --
9537 ---------------------------------
9539 function Make_Discriminant_Reference
9542 Nod
: constant Node_Id
:=
9543 Make_Selected_Component
(Loc
,
9546 Chars
(Name
(Field
)));
9548 Set_Etype
(Nod
, Etype
(Name
(Field
)));
9550 end Make_Discriminant_Reference
;
9552 -- Start processing for Variant_Part
9556 Make_Block_Statement
(Loc
,
9559 Handled_Statement_Sequence
=>
9560 Make_Handled_Sequence_Of_Statements
(Loc
,
9561 Statements
=> Block_Stmts
)));
9563 -- Declare variant part aggregate (Union_Any).
9564 -- Knowing the position of this VP in the
9565 -- variant record, we can fetch the VP typecode
9568 Append_To
(Block_Decls
,
9569 Make_Object_Declaration
(Loc
,
9570 Defining_Identifier
=> Union_Any
,
9571 Object_Definition
=>
9572 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9574 Make_Function_Call
(Loc
,
9575 Name
=> New_Occurrence_Of
(
9576 RTE
(RE_Create_Any
), Loc
),
9577 Parameter_Associations
=> New_List
(
9578 Make_Function_Call
(Loc
,
9581 RTE
(RE_Any_Member_Type
), Loc
),
9582 Parameter_Associations
=> New_List
(
9583 New_Occurrence_Of
(Container
, Loc
),
9584 Make_Integer_Literal
(Loc
,
9587 -- Declare inner struct aggregate (which
9588 -- contains the components of this VP).
9590 Append_To
(Block_Decls
,
9591 Make_Object_Declaration
(Loc
,
9592 Defining_Identifier
=> Struct_Any
,
9593 Object_Definition
=>
9594 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9596 Make_Function_Call
(Loc
,
9597 Name
=> New_Occurrence_Of
(
9598 RTE
(RE_Create_Any
), Loc
),
9599 Parameter_Associations
=> New_List
(
9600 Make_Function_Call
(Loc
,
9603 RTE
(RE_Any_Member_Type
), Loc
),
9604 Parameter_Associations
=> New_List
(
9605 New_Occurrence_Of
(Union_Any
, Loc
),
9606 Make_Integer_Literal
(Loc
,
9609 -- Build case statement
9611 Append_To
(Block_Stmts
,
9612 Make_Case_Statement
(Loc
,
9613 Expression
=> Make_Discriminant_Reference
,
9614 Alternatives
=> Alt_List
));
9616 Variant
:= First_Non_Pragma
(Variants
(Field
));
9617 while Present
(Variant
) loop
9618 Choice_List
:= New_Copy_List_Tree
9619 (Discrete_Choices
(Variant
));
9621 VP_Stmts
:= New_List
;
9623 -- Append discriminant val to union aggregate
9625 Append_To
(VP_Stmts
,
9626 Make_Procedure_Call_Statement
(Loc
,
9629 RTE
(RE_Add_Aggregate_Element
), Loc
),
9630 Parameter_Associations
=> New_List
(
9631 New_Occurrence_Of
(Union_Any
, Loc
),
9633 (Make_Discriminant_Reference
,
9636 -- Populate inner struct aggregate
9638 -- Struct_Counter should be reset before
9639 -- handling a variant part. Indeed only one
9640 -- of the case statement alternatives will be
9641 -- executed at run-time, so the counter must
9642 -- start at 0 for every case statement.
9644 Struct_Counter
:= 0;
9646 TA_Append_Record_Traversal
(
9648 Clist
=> Component_List
(Variant
),
9649 Container
=> Struct_Any
,
9650 Counter
=> Struct_Counter
);
9652 -- Append inner struct to union aggregate
9654 Append_To
(VP_Stmts
,
9655 Make_Procedure_Call_Statement
(Loc
,
9658 RTE
(RE_Add_Aggregate_Element
), Loc
),
9659 Parameter_Associations
=> New_List
(
9660 New_Occurrence_Of
(Union_Any
, Loc
),
9661 New_Occurrence_Of
(Struct_Any
, Loc
))));
9663 -- Append union to outer aggregate
9665 Append_To
(VP_Stmts
,
9666 Make_Procedure_Call_Statement
(Loc
,
9669 RTE
(RE_Add_Aggregate_Element
), Loc
),
9670 Parameter_Associations
=> New_List
(
9671 New_Occurrence_Of
(Container
, Loc
),
9673 (Union_Any
, Loc
))));
9675 Append_To
(Alt_List
,
9676 Make_Case_Statement_Alternative
(Loc
,
9677 Discrete_Choices
=> Choice_List
,
9678 Statements
=> VP_Stmts
));
9680 Next_Non_Pragma
(Variant
);
9685 Counter
:= Counter
+ 1;
9686 end TA_Rec_Add_Process_Element
;
9689 -- Records are encoded in a TC_STRUCT aggregate:
9691 -- -- Outer aggregate (TC_STRUCT)
9692 -- | [discriminant1]
9693 -- | [discriminant2]
9700 -- A component can be a common component or variant part
9702 -- A variant part is encoded as a TC_UNION aggregate:
9704 -- -- Variant Part Aggregate (TC_UNION)
9705 -- | [discriminant choice for this Variant Part]
9707 -- | -- Inner struct (TC_STRUCT)
9712 -- Let's start by building the outer aggregate. First we
9713 -- construct Elements array containing all discriminants.
9715 if Has_Discriminants
(Typ
) then
9716 Disc
:= First_Discriminant
(Typ
);
9717 while Present
(Disc
) loop
9719 Discriminant
: constant Entity_Id
:=
9720 Make_Selected_Component
(Loc
,
9727 Set_Etype
(Discriminant
, Etype
(Disc
));
9729 Append_To
(Elements
,
9730 Make_Component_Association
(Loc
,
9731 Choices
=> New_List
(
9732 Make_Integer_Literal
(Loc
, Counter
)),
9734 Build_To_Any_Call
(Discriminant
, Decls
)));
9737 Counter
:= Counter
+ 1;
9738 Next_Discriminant
(Disc
);
9742 -- If there are no discriminants, we declare an empty
9746 Dummy_Any
: constant Entity_Id
:=
9747 Make_Defining_Identifier
(Loc
,
9748 Chars
=> New_Internal_Name
('A'));
9752 Make_Object_Declaration
(Loc
,
9753 Defining_Identifier
=> Dummy_Any
,
9754 Object_Definition
=>
9755 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
9757 Append_To
(Elements
,
9758 Make_Component_Association
(Loc
,
9759 Choices
=> New_List
(
9762 Make_Integer_Literal
(Loc
, 1),
9764 Make_Integer_Literal
(Loc
, 0))),
9766 New_Occurrence_Of
(Dummy_Any
, Loc
)));
9770 -- We build the result aggregate with discriminants
9771 -- as the first elements.
9773 Set_Expression
(Any_Decl
,
9774 Make_Function_Call
(Loc
,
9775 Name
=> New_Occurrence_Of
(
9776 RTE
(RE_Any_Aggregate_Build
), Loc
),
9777 Parameter_Associations
=> New_List
(
9779 Make_Aggregate
(Loc
,
9780 Component_Associations
=> Elements
))));
9783 -- Then we append all the components to the result
9786 TA_Append_Record_Traversal
(Stms
,
9787 Clist
=> Component_List
(Rdef
),
9789 Counter
=> Counter
);
9793 elsif Is_Array_Type
(Typ
) then
9795 -- Constrained and unconstrained array types
9798 Constrained
: constant Boolean := Is_Constrained
(Typ
);
9800 procedure TA_Ary_Add_Process_Element
9803 Counter
: Entity_Id
;
9806 --------------------------------
9807 -- TA_Ary_Add_Process_Element --
9808 --------------------------------
9810 procedure TA_Ary_Add_Process_Element
9813 Counter
: Entity_Id
;
9816 pragma Warnings
(Off
);
9817 pragma Unreferenced
(Counter
);
9818 pragma Warnings
(On
);
9820 Element_Any
: Node_Id
;
9823 if Etype
(Datum
) = RTE
(RE_Any
) then
9824 Element_Any
:= Datum
;
9826 Element_Any
:= Build_To_Any_Call
(Datum
, Decls
);
9830 Make_Procedure_Call_Statement
(Loc
,
9831 Name
=> New_Occurrence_Of
(
9832 RTE
(RE_Add_Aggregate_Element
), Loc
),
9833 Parameter_Associations
=> New_List
(
9834 New_Occurrence_Of
(Any
, Loc
),
9836 end TA_Ary_Add_Process_Element
;
9838 procedure Append_To_Any_Array_Iterator
is
9839 new Append_Array_Traversal
(
9841 Arry
=> Expr_Parameter
,
9842 Indices
=> New_List
,
9843 Add_Process_Element
=> TA_Ary_Add_Process_Element
);
9848 Set_Expression
(Any_Decl
,
9849 Make_Function_Call
(Loc
,
9851 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
9852 Parameter_Associations
=> New_List
(Result_TC
)));
9855 if not Constrained
then
9856 Index
:= First_Index
(Typ
);
9857 for J
in 1 .. Number_Dimensions
(Typ
) loop
9859 Make_Procedure_Call_Statement
(Loc
,
9862 RTE
(RE_Add_Aggregate_Element
), Loc
),
9863 Parameter_Associations
=> New_List
(
9864 New_Occurrence_Of
(Any
, Loc
),
9866 OK_Convert_To
(Etype
(Index
),
9867 Make_Attribute_Reference
(Loc
,
9869 New_Occurrence_Of
(Expr_Parameter
, Loc
),
9870 Attribute_Name
=> Name_First
,
9871 Expressions
=> New_List
(
9872 Make_Integer_Literal
(Loc
, J
)))),
9878 Append_To_Any_Array_Iterator
(Stms
, Any
);
9881 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9885 Set_Expression
(Any_Decl
,
9888 Find_Numeric_Representation
(Typ
),
9889 New_Occurrence_Of
(Expr_Parameter
, Loc
)),
9893 -- Default case, including tagged types: opaque representation
9895 Use_Opaque_Representation
:= True;
9898 if Use_Opaque_Representation
then
9900 Strm
: constant Entity_Id
:=
9901 Make_Defining_Identifier
(Loc
,
9902 Chars
=> New_Internal_Name
('S'));
9903 -- Stream used to store data representation produced by
9904 -- stream attribute.
9908 -- Strm : aliased Buffer_Stream_Type;
9911 Make_Object_Declaration
(Loc
,
9912 Defining_Identifier
=>
9916 Object_Definition
=>
9917 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
9920 -- Allocate_Buffer (Strm);
9923 Make_Procedure_Call_Statement
(Loc
,
9925 New_Occurrence_Of
(RTE
(RE_Allocate_Buffer
), Loc
),
9926 Parameter_Associations
=> New_List
(
9927 New_Occurrence_Of
(Strm
, Loc
))));
9930 -- T'Output (Strm'Access, E);
9933 Make_Attribute_Reference
(Loc
,
9934 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
9935 Attribute_Name
=> Name_Output
,
9936 Expressions
=> New_List
(
9937 Make_Attribute_Reference
(Loc
,
9938 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
9939 Attribute_Name
=> Name_Access
),
9940 New_Occurrence_Of
(Expr_Parameter
, Loc
))));
9943 -- BS_To_Any (Strm, A);
9946 Make_Procedure_Call_Statement
(Loc
,
9947 Name
=> New_Occurrence_Of
(RTE
(RE_BS_To_Any
), Loc
),
9948 Parameter_Associations
=> New_List
(
9949 New_Occurrence_Of
(Strm
, Loc
),
9950 New_Occurrence_Of
(Any
, Loc
))));
9953 -- Release_Buffer (Strm);
9956 Make_Procedure_Call_Statement
(Loc
,
9957 Name
=> New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
9958 Parameter_Associations
=> New_List
(
9959 New_Occurrence_Of
(Strm
, Loc
))));
9963 Append_To
(Decls
, Any_Decl
);
9965 if Present
(Result_TC
) then
9967 Make_Procedure_Call_Statement
(Loc
,
9968 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
9969 Parameter_Associations
=> New_List
(
9970 New_Occurrence_Of
(Any
, Loc
),
9975 Make_Simple_Return_Statement
(Loc
,
9976 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
9979 Make_Subprogram_Body
(Loc
,
9980 Specification
=> Spec
,
9981 Declarations
=> Decls
,
9982 Handled_Statement_Sequence
=>
9983 Make_Handled_Sequence_Of_Statements
(Loc
,
9984 Statements
=> Stms
));
9985 end Build_To_Any_Function
;
9987 -------------------------
9988 -- Build_TypeCode_Call --
9989 -------------------------
9991 function Build_TypeCode_Call
9994 Decls
: List_Id
) return Node_Id
9996 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
9997 -- The full view, if Typ is private; the completion,
9998 -- if Typ is incomplete.
10000 Fnam
: Entity_Id
:= Empty
;
10001 Lib_RE
: RE_Id
:= RE_Null
;
10005 -- Special case System.PolyORB.Interface.Any: its primitives have
10006 -- not been set yet, so can't call Find_Inherited_TSS.
10008 if Typ
= RTE
(RE_Any
) then
10009 Fnam
:= RTE
(RE_TC_A
);
10012 -- First simple case where the TypeCode is present
10013 -- in the type's TSS.
10015 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_TypeCode
);
10019 if Sloc
(U_Type
) <= Standard_Location
then
10021 -- Do not try to build alias typecodes for subtypes from
10024 U_Type
:= Base_Type
(U_Type
);
10027 if U_Type
= Standard_Boolean
then
10030 elsif U_Type
= Standard_Character
then
10033 elsif U_Type
= Standard_Wide_Character
then
10034 Lib_RE
:= RE_TC_WC
;
10036 elsif U_Type
= Standard_Wide_Wide_Character
then
10037 Lib_RE
:= RE_TC_WWC
;
10039 -- Floating point types
10041 elsif U_Type
= Standard_Short_Float
then
10042 Lib_RE
:= RE_TC_SF
;
10044 elsif U_Type
= Standard_Float
then
10047 elsif U_Type
= Standard_Long_Float
then
10048 Lib_RE
:= RE_TC_LF
;
10050 elsif U_Type
= Standard_Long_Long_Float
then
10051 Lib_RE
:= RE_TC_LLF
;
10053 -- Integer types (walk back to the base type)
10055 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
10056 Lib_RE
:= RE_TC_SSI
;
10058 elsif U_Type
= Etype
(Standard_Short_Integer
) then
10059 Lib_RE
:= RE_TC_SI
;
10061 elsif U_Type
= Etype
(Standard_Integer
) then
10064 elsif U_Type
= Etype
(Standard_Long_Integer
) then
10065 Lib_RE
:= RE_TC_LI
;
10067 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
10068 Lib_RE
:= RE_TC_LLI
;
10070 -- Unsigned integer types
10072 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
10073 Lib_RE
:= RE_TC_SSU
;
10075 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
10076 Lib_RE
:= RE_TC_SU
;
10078 elsif U_Type
= RTE
(RE_Unsigned
) then
10081 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
10082 Lib_RE
:= RE_TC_LU
;
10084 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
10085 Lib_RE
:= RE_TC_LLU
;
10087 elsif U_Type
= Standard_String
then
10088 Lib_RE
:= RE_TC_String
;
10090 -- Special DSA types
10092 elsif Is_RTE
(U_Type
, RE_Any_Container_Ptr
) then
10095 -- Other (non-primitive) types
10101 Build_TypeCode_Function
(Loc
, U_Type
, Decl
, Fnam
);
10102 Append_To
(Decls
, Decl
);
10106 if Lib_RE
/= RE_Null
then
10107 Fnam
:= RTE
(Lib_RE
);
10111 -- Call the function
10114 Make_Function_Call
(Loc
, Name
=> New_Occurrence_Of
(Fnam
, Loc
));
10116 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10118 Set_Etype
(Expr
, RTE
(RE_TypeCode
));
10121 end Build_TypeCode_Call
;
10123 -----------------------------
10124 -- Build_TypeCode_Function --
10125 -----------------------------
10127 procedure Build_TypeCode_Function
10130 Decl
: out Node_Id
;
10131 Fnam
: out Entity_Id
)
10134 Decls
: constant List_Id
:= New_List
;
10135 Stms
: constant List_Id
:= New_List
;
10137 TCNam
: constant Entity_Id
:=
10138 Make_Helper_Function_Name
(Loc
, Typ
, Name_TypeCode
);
10140 Parameters
: List_Id
;
10142 procedure Add_String_Parameter
10144 Parameter_List
: List_Id
);
10145 -- Add a literal for S to Parameters
10147 procedure Add_TypeCode_Parameter
10148 (TC_Node
: Node_Id
;
10149 Parameter_List
: List_Id
);
10150 -- Add the typecode for Typ to Parameters
10152 procedure Add_Long_Parameter
10153 (Expr_Node
: Node_Id
;
10154 Parameter_List
: List_Id
);
10155 -- Add a signed long integer expression to Parameters
10157 procedure Initialize_Parameter_List
10158 (Name_String
: String_Id
;
10159 Repo_Id_String
: String_Id
;
10160 Parameter_List
: out List_Id
);
10161 -- Return a list that contains the first two parameters
10162 -- for a parameterized typecode: name and repository id.
10164 function Make_Constructed_TypeCode
10166 Parameters
: List_Id
) return Node_Id
;
10167 -- Call TC_Build with the given kind and parameters
10169 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
);
10170 -- Make a return statement that calls TC_Build with the given
10171 -- typecode kind, and the constructed parameters list.
10173 procedure Return_Alias_TypeCode
(Base_TypeCode
: Node_Id
);
10174 -- Return a typecode that is a TC_Alias for the given typecode
10176 --------------------------
10177 -- Add_String_Parameter --
10178 --------------------------
10180 procedure Add_String_Parameter
10182 Parameter_List
: List_Id
)
10185 Append_To
(Parameter_List
,
10186 Make_Function_Call
(Loc
,
10187 Name
=> New_Occurrence_Of
(RTE
(RE_TA_String
), Loc
),
10188 Parameter_Associations
=> New_List
(
10189 Make_String_Literal
(Loc
, S
))));
10190 end Add_String_Parameter
;
10192 ----------------------------
10193 -- Add_TypeCode_Parameter --
10194 ----------------------------
10196 procedure Add_TypeCode_Parameter
10197 (TC_Node
: Node_Id
;
10198 Parameter_List
: List_Id
)
10201 Append_To
(Parameter_List
,
10202 Make_Function_Call
(Loc
,
10203 Name
=> New_Occurrence_Of
(RTE
(RE_TA_TC
), Loc
),
10204 Parameter_Associations
=> New_List
(TC_Node
)));
10205 end Add_TypeCode_Parameter
;
10207 ------------------------
10208 -- Add_Long_Parameter --
10209 ------------------------
10211 procedure Add_Long_Parameter
10212 (Expr_Node
: Node_Id
;
10213 Parameter_List
: List_Id
)
10216 Append_To
(Parameter_List
,
10217 Make_Function_Call
(Loc
,
10218 Name
=> New_Occurrence_Of
(RTE
(RE_TA_LI
), Loc
),
10219 Parameter_Associations
=> New_List
(Expr_Node
)));
10220 end Add_Long_Parameter
;
10222 -------------------------------
10223 -- Initialize_Parameter_List --
10224 -------------------------------
10226 procedure Initialize_Parameter_List
10227 (Name_String
: String_Id
;
10228 Repo_Id_String
: String_Id
;
10229 Parameter_List
: out List_Id
)
10232 Parameter_List
:= New_List
;
10233 Add_String_Parameter
(Name_String
, Parameter_List
);
10234 Add_String_Parameter
(Repo_Id_String
, Parameter_List
);
10235 end Initialize_Parameter_List
;
10237 ---------------------------
10238 -- Return_Alias_TypeCode --
10239 ---------------------------
10241 procedure Return_Alias_TypeCode
10242 (Base_TypeCode
: Node_Id
)
10245 Add_TypeCode_Parameter
(Base_TypeCode
, Parameters
);
10246 Return_Constructed_TypeCode
(RTE
(RE_TC_Alias
));
10247 end Return_Alias_TypeCode
;
10249 -------------------------------
10250 -- Make_Constructed_TypeCode --
10251 -------------------------------
10253 function Make_Constructed_TypeCode
10255 Parameters
: List_Id
) return Node_Id
10257 Constructed_TC
: constant Node_Id
:=
10258 Make_Function_Call
(Loc
,
10260 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
10261 Parameter_Associations
=> New_List
(
10262 New_Occurrence_Of
(Kind
, Loc
),
10263 Make_Aggregate
(Loc
,
10264 Expressions
=> Parameters
)));
10266 Set_Etype
(Constructed_TC
, RTE
(RE_TypeCode
));
10267 return Constructed_TC
;
10268 end Make_Constructed_TypeCode
;
10270 ---------------------------------
10271 -- Return_Constructed_TypeCode --
10272 ---------------------------------
10274 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
) is
10277 Make_Simple_Return_Statement
(Loc
,
10279 Make_Constructed_TypeCode
(Kind
, Parameters
)));
10280 end Return_Constructed_TypeCode
;
10286 procedure TC_Rec_Add_Process_Element
10289 Counter
: in out Int
;
10293 procedure TC_Append_Record_Traversal
is
10294 new Append_Record_Traversal
(
10296 Add_Process_Element
=> TC_Rec_Add_Process_Element
);
10298 --------------------------------
10299 -- TC_Rec_Add_Process_Element --
10300 --------------------------------
10302 procedure TC_Rec_Add_Process_Element
10305 Counter
: in out Int
;
10309 pragma Warnings
(Off
);
10310 pragma Unreferenced
(Any
, Counter
, Rec
);
10311 pragma Warnings
(On
);
10314 if Nkind
(Field
) = N_Defining_Identifier
then
10316 -- A regular component
10318 Add_TypeCode_Parameter
10319 (Build_TypeCode_Call
(Loc
, Etype
(Field
), Decls
), Params
);
10320 Get_Name_String
(Chars
(Field
));
10321 Add_String_Parameter
(String_From_Name_Buffer
, Params
);
10328 Discriminant_Type
: constant Entity_Id
:=
10329 Etype
(Name
(Field
));
10331 Is_Enum
: constant Boolean :=
10332 Is_Enumeration_Type
(Discriminant_Type
);
10334 Union_TC_Params
: List_Id
;
10336 U_Name
: constant Name_Id
:=
10337 New_External_Name
(Chars
(Typ
), 'V', -1);
10339 Name_Str
: String_Id
;
10340 Struct_TC_Params
: List_Id
;
10344 Default
: constant Node_Id
:=
10345 Make_Integer_Literal
(Loc
, -1);
10347 Dummy_Counter
: Int
:= 0;
10349 Choice_Index
: Int
:= 0;
10351 procedure Add_Params_For_Variant_Components
;
10352 -- Add a struct TypeCode and a corresponding member name
10353 -- to the union parameter list.
10355 -- Ordering of declarations is a complete mess in this
10356 -- area, it is supposed to be types/varibles, then
10357 -- subprogram specs, then subprogram bodies ???
10359 ---------------------------------------
10360 -- Add_Params_For_Variant_Components --
10361 ---------------------------------------
10363 procedure Add_Params_For_Variant_Components
10365 S_Name
: constant Name_Id
:=
10366 New_External_Name
(U_Name
, 'S', -1);
10369 Get_Name_String
(S_Name
);
10370 Name_Str
:= String_From_Name_Buffer
;
10371 Initialize_Parameter_List
10372 (Name_Str
, Name_Str
, Struct_TC_Params
);
10374 -- Build struct parameters
10376 TC_Append_Record_Traversal
(Struct_TC_Params
,
10377 Component_List
(Variant
),
10381 Add_TypeCode_Parameter
10382 (Make_Constructed_TypeCode
10383 (RTE
(RE_TC_Struct
), Struct_TC_Params
),
10386 Add_String_Parameter
(Name_Str
, Union_TC_Params
);
10387 end Add_Params_For_Variant_Components
;
10390 Get_Name_String
(U_Name
);
10391 Name_Str
:= String_From_Name_Buffer
;
10393 Initialize_Parameter_List
10394 (Name_Str
, Name_Str
, Union_TC_Params
);
10396 -- Add union in enclosing parameter list
10398 Add_TypeCode_Parameter
10399 (Make_Constructed_TypeCode
10400 (RTE
(RE_TC_Union
), Union_TC_Params
),
10403 Add_String_Parameter
(Name_Str
, Params
);
10405 -- Build union parameters
10407 Add_TypeCode_Parameter
10408 (Build_TypeCode_Call
10409 (Loc
, Discriminant_Type
, Decls
),
10412 Add_Long_Parameter
(Default
, Union_TC_Params
);
10414 Variant
:= First_Non_Pragma
(Variants
(Field
));
10415 while Present
(Variant
) loop
10416 Choice
:= First
(Discrete_Choices
(Variant
));
10417 while Present
(Choice
) loop
10418 case Nkind
(Choice
) is
10421 L
: constant Uint
:=
10422 Expr_Value
(Low_Bound
(Choice
));
10423 H
: constant Uint
:=
10424 Expr_Value
(High_Bound
(Choice
));
10426 -- 3.8.1(8) guarantees that the bounds of
10427 -- this range are static.
10434 Expr
:= New_Occurrence_Of
(
10435 Get_Enum_Lit_From_Pos
(
10436 Discriminant_Type
, J
, Loc
), Loc
);
10439 Make_Integer_Literal
(Loc
, J
);
10441 Append_To
(Union_TC_Params
,
10442 Build_To_Any_Call
(Expr
, Decls
));
10444 Add_Params_For_Variant_Components
;
10449 when N_Others_Choice
=>
10451 -- This variant possess a default choice.
10452 -- We must therefore set the default
10453 -- parameter to the current choice index. The
10454 -- default parameter is by construction the
10455 -- fourth in the Union_TC_Params list.
10458 Default_Node
: constant Node_Id
:=
10459 Pick
(Union_TC_Params
, 4);
10461 New_Default_Node
: constant Node_Id
:=
10462 Make_Function_Call
(Loc
,
10465 (RTE
(RE_TA_LI
), Loc
),
10466 Parameter_Associations
=>
10468 Make_Integer_Literal
10469 (Loc
, Choice_Index
)));
10475 Remove
(Default_Node
);
10478 -- Add a placeholder member label
10479 -- for the default case.
10480 -- It must be of the discriminant type.
10483 Exp
: constant Node_Id
:=
10484 Make_Attribute_Reference
(Loc
,
10485 Prefix
=> New_Occurrence_Of
10486 (Discriminant_Type
, Loc
),
10487 Attribute_Name
=> Name_First
);
10489 Set_Etype
(Exp
, Discriminant_Type
);
10490 Append_To
(Union_TC_Params
,
10491 Build_To_Any_Call
(Exp
, Decls
));
10494 Add_Params_For_Variant_Components
;
10498 -- Case of an explicit choice
10501 Exp
: constant Node_Id
:=
10502 New_Copy_Tree
(Choice
);
10504 Append_To
(Union_TC_Params
,
10505 Build_To_Any_Call
(Exp
, Decls
));
10508 Add_Params_For_Variant_Components
;
10512 Choice_Index
:= Choice_Index
+ 1;
10515 Next_Non_Pragma
(Variant
);
10519 end TC_Rec_Add_Process_Element
;
10521 Type_Name_Str
: String_Id
;
10522 Type_Repo_Id_Str
: String_Id
;
10525 if Is_Itype
(Typ
) then
10526 Build_TypeCode_Function
10528 Typ
=> Etype
(Typ
),
10537 Make_Function_Specification
(Loc
,
10538 Defining_Unit_Name
=> Fnam
,
10539 Parameter_Specifications
=> Empty_List
,
10540 Result_Definition
=>
10541 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
10543 Build_Name_And_Repository_Id
(Typ
,
10544 Name_Str
=> Type_Name_Str
, Repo_Id_Str
=> Type_Repo_Id_Str
);
10546 Initialize_Parameter_List
10547 (Type_Name_Str
, Type_Repo_Id_Str
, Parameters
);
10549 if Has_Stream_Attribute_Definition
10550 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
10552 Has_Stream_Attribute_Definition
10553 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
10555 -- If user-defined stream attributes are specified for this
10556 -- type, use them and transmit data as an opaque sequence of
10557 -- stream elements.
10559 Return_Alias_TypeCode
10560 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10562 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
10563 Return_Alias_TypeCode
(
10564 Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10566 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
10567 Return_Alias_TypeCode
(
10568 Build_TypeCode_Call
(Loc
,
10569 Find_Numeric_Representation
(Typ
), Decls
));
10571 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
10573 -- Record typecodes are encoded as follows:
10577 -- | [Repository Id]
10579 -- Then for each discriminant:
10581 -- | [Discriminant Type Code]
10582 -- | [Discriminant Name]
10585 -- Then for each component:
10587 -- | [Component Type Code]
10588 -- | [Component Name]
10591 -- Variants components type codes are encoded as follows:
10595 -- | [Repository Id]
10596 -- | [Discriminant Type Code]
10597 -- | [Index of Default Variant Part or -1 for no default]
10599 -- Then for each Variant Part :
10604 -- | | [Variant Part Name]
10605 -- | | [Variant Part Repository Id]
10607 -- | Then for each VP component:
10608 -- | | [VP component Typecode]
10609 -- | | [VP component Name]
10615 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
10616 Return_Alias_TypeCode
10617 (Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10621 Disc
: Entity_Id
:= Empty
;
10622 Rdef
: constant Node_Id
:=
10623 Type_Definition
(Declaration_Node
(Typ
));
10624 Dummy_Counter
: Int
:= 0;
10627 -- Construct the discriminants typecodes
10629 if Has_Discriminants
(Typ
) then
10630 Disc
:= First_Discriminant
(Typ
);
10633 while Present
(Disc
) loop
10634 Add_TypeCode_Parameter
(
10635 Build_TypeCode_Call
(Loc
, Etype
(Disc
), Decls
),
10637 Get_Name_String
(Chars
(Disc
));
10638 Add_String_Parameter
(
10639 String_From_Name_Buffer
,
10641 Next_Discriminant
(Disc
);
10644 -- then the components typecodes
10646 TC_Append_Record_Traversal
10647 (Parameters
, Component_List
(Rdef
),
10648 Empty
, Dummy_Counter
);
10649 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10653 elsif Is_Array_Type
(Typ
) then
10655 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10656 Inner_TypeCode
: Node_Id
;
10657 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10658 Indx
: Node_Id
:= First_Index
(Typ
);
10662 Build_TypeCode_Call
(Loc
, Component_Type
(Typ
), Decls
);
10664 for J
in 1 .. Ndim
loop
10665 if Constrained
then
10666 Inner_TypeCode
:= Make_Constructed_TypeCode
10667 (RTE
(RE_TC_Array
), New_List
(
10668 Build_To_Any_Call
(
10669 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10670 Make_Attribute_Reference
(Loc
,
10671 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
10672 Attribute_Name
=> Name_Length
,
10673 Expressions
=> New_List
(
10674 Make_Integer_Literal
(Loc
,
10675 Intval
=> Ndim
- J
+ 1)))),
10677 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10680 -- Unconstrained case: add low bound for each
10683 Add_TypeCode_Parameter
10684 (Build_TypeCode_Call
(Loc
, Etype
(Indx
), Decls
),
10686 Get_Name_String
(New_External_Name
('L', J
));
10687 Add_String_Parameter
(
10688 String_From_Name_Buffer
,
10692 Inner_TypeCode
:= Make_Constructed_TypeCode
10693 (RTE
(RE_TC_Sequence
), New_List
(
10694 Build_To_Any_Call
(
10695 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10696 Make_Integer_Literal
(Loc
, 0)),
10698 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10702 if Constrained
then
10703 Return_Alias_TypeCode
(Inner_TypeCode
);
10705 Add_TypeCode_Parameter
(Inner_TypeCode
, Parameters
);
10707 Store_String_Char
('V');
10708 Add_String_Parameter
(End_String
, Parameters
);
10709 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10714 -- Default: type is represented as an opaque sequence of bytes
10716 Return_Alias_TypeCode
10717 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10721 Make_Subprogram_Body
(Loc
,
10722 Specification
=> Spec
,
10723 Declarations
=> Decls
,
10724 Handled_Statement_Sequence
=>
10725 Make_Handled_Sequence_Of_Statements
(Loc
,
10726 Statements
=> Stms
));
10727 end Build_TypeCode_Function
;
10729 ---------------------------------
10730 -- Find_Numeric_Representation --
10731 ---------------------------------
10733 function Find_Numeric_Representation
10734 (Typ
: Entity_Id
) return Entity_Id
10736 FST
: constant Entity_Id
:= First_Subtype
(Typ
);
10737 P_Size
: constant Uint
:= Esize
(FST
);
10740 if Is_Unsigned_Type
(Typ
) then
10741 if P_Size
<= Standard_Short_Short_Integer_Size
then
10742 return RTE
(RE_Short_Short_Unsigned
);
10744 elsif P_Size
<= Standard_Short_Integer_Size
then
10745 return RTE
(RE_Short_Unsigned
);
10747 elsif P_Size
<= Standard_Integer_Size
then
10748 return RTE
(RE_Unsigned
);
10750 elsif P_Size
<= Standard_Long_Integer_Size
then
10751 return RTE
(RE_Long_Unsigned
);
10754 return RTE
(RE_Long_Long_Unsigned
);
10757 elsif Is_Integer_Type
(Typ
) then
10758 if P_Size
<= Standard_Short_Short_Integer_Size
then
10759 return Standard_Short_Short_Integer
;
10761 elsif P_Size
<= Standard_Short_Integer_Size
then
10762 return Standard_Short_Integer
;
10764 elsif P_Size
<= Standard_Integer_Size
then
10765 return Standard_Integer
;
10767 elsif P_Size
<= Standard_Long_Integer_Size
then
10768 return Standard_Long_Integer
;
10771 return Standard_Long_Long_Integer
;
10774 elsif Is_Floating_Point_Type
(Typ
) then
10775 if P_Size
<= Standard_Short_Float_Size
then
10776 return Standard_Short_Float
;
10778 elsif P_Size
<= Standard_Float_Size
then
10779 return Standard_Float
;
10781 elsif P_Size
<= Standard_Long_Float_Size
then
10782 return Standard_Long_Float
;
10785 return Standard_Long_Long_Float
;
10789 raise Program_Error
;
10792 -- TBD: fixed point types???
10793 -- TBverified numeric types with a biased representation???
10795 end Find_Numeric_Representation
;
10797 ---------------------------
10798 -- Append_Array_Traversal --
10799 ---------------------------
10801 procedure Append_Array_Traversal
10804 Counter
: Entity_Id
:= Empty
;
10807 Loc
: constant Source_Ptr
:= Sloc
(Subprogram
);
10808 Typ
: constant Entity_Id
:= Etype
(Arry
);
10809 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10810 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10812 Inner_Any
, Inner_Counter
: Entity_Id
;
10814 Loop_Stm
: Node_Id
;
10815 Inner_Stmts
: constant List_Id
:= New_List
;
10818 if Depth
> Ndim
then
10820 -- Processing for one element of an array
10823 Element_Expr
: constant Node_Id
:=
10824 Make_Indexed_Component
(Loc
,
10825 New_Occurrence_Of
(Arry
, Loc
),
10828 Set_Etype
(Element_Expr
, Component_Type
(Typ
));
10829 Add_Process_Element
(Stmts
,
10831 Counter
=> Counter
,
10832 Datum
=> Element_Expr
);
10838 Append_To
(Indices
,
10839 Make_Identifier
(Loc
, New_External_Name
('L', Depth
)));
10841 if not Constrained
or else Depth
> 1 then
10842 Inner_Any
:= Make_Defining_Identifier
(Loc
,
10843 New_External_Name
('A', Depth
));
10844 Set_Etype
(Inner_Any
, RTE
(RE_Any
));
10846 Inner_Any
:= Empty
;
10849 if Present
(Counter
) then
10850 Inner_Counter
:= Make_Defining_Identifier
(Loc
,
10851 New_External_Name
('J', Depth
));
10853 Inner_Counter
:= Empty
;
10857 Loop_Any
: Node_Id
:= Inner_Any
;
10860 -- For the first dimension of a constrained array, we add
10861 -- elements directly in the corresponding Any; there is no
10862 -- intervening inner Any.
10864 if No
(Loop_Any
) then
10868 Append_Array_Traversal
(Inner_Stmts
,
10870 Counter
=> Inner_Counter
,
10871 Depth
=> Depth
+ 1);
10875 Make_Implicit_Loop_Statement
(Subprogram
,
10876 Iteration_Scheme
=>
10877 Make_Iteration_Scheme
(Loc
,
10878 Loop_Parameter_Specification
=>
10879 Make_Loop_Parameter_Specification
(Loc
,
10880 Defining_Identifier
=>
10881 Make_Defining_Identifier
(Loc
,
10882 Chars
=> New_External_Name
('L', Depth
)),
10884 Discrete_Subtype_Definition
=>
10885 Make_Attribute_Reference
(Loc
,
10886 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10887 Attribute_Name
=> Name_Range
,
10889 Expressions
=> New_List
(
10890 Make_Integer_Literal
(Loc
, Depth
))))),
10891 Statements
=> Inner_Stmts
);
10894 Decls
: constant List_Id
:= New_List
;
10895 Dimen_Stmts
: constant List_Id
:= New_List
;
10896 Length_Node
: Node_Id
;
10898 Inner_Any_TypeCode
: constant Entity_Id
:=
10899 Make_Defining_Identifier
(Loc
,
10900 New_External_Name
('T', Depth
));
10902 Inner_Any_TypeCode_Expr
: Node_Id
;
10906 if Constrained
then
10907 Inner_Any_TypeCode_Expr
:=
10908 Make_Function_Call
(Loc
,
10909 Name
=> New_Occurrence_Of
(RTE
(RE_Get_TC
), Loc
),
10910 Parameter_Associations
=> New_List
(
10911 New_Occurrence_Of
(Any
, Loc
)));
10913 Inner_Any_TypeCode_Expr
:=
10914 Make_Function_Call
(Loc
,
10916 New_Occurrence_Of
(RTE
(RE_Any_Member_Type
), Loc
),
10917 Parameter_Associations
=> New_List
(
10918 New_Occurrence_Of
(Any
, Loc
),
10919 Make_Integer_Literal
(Loc
, Ndim
)));
10922 Inner_Any_TypeCode_Expr
:=
10923 Make_Function_Call
(Loc
,
10924 Name
=> New_Occurrence_Of
(RTE
(RE_Content_Type
), Loc
),
10925 Parameter_Associations
=> New_List
(
10926 Make_Identifier
(Loc
,
10927 Chars
=> New_External_Name
('T', Depth
- 1))));
10931 Make_Object_Declaration
(Loc
,
10932 Defining_Identifier
=> Inner_Any_TypeCode
,
10933 Constant_Present
=> True,
10934 Object_Definition
=> New_Occurrence_Of
(
10935 RTE
(RE_TypeCode
), Loc
),
10936 Expression
=> Inner_Any_TypeCode_Expr
));
10938 if Present
(Inner_Any
) then
10940 Make_Object_Declaration
(Loc
,
10941 Defining_Identifier
=> Inner_Any
,
10942 Object_Definition
=>
10943 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
10945 Make_Function_Call
(Loc
,
10947 New_Occurrence_Of
(
10948 RTE
(RE_Create_Any
), Loc
),
10949 Parameter_Associations
=> New_List
(
10950 New_Occurrence_Of
(Inner_Any_TypeCode
, Loc
)))));
10953 if Present
(Inner_Counter
) then
10955 Make_Object_Declaration
(Loc
,
10956 Defining_Identifier
=> Inner_Counter
,
10957 Object_Definition
=>
10958 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
10960 Make_Integer_Literal
(Loc
, 0)));
10963 if not Constrained
then
10964 Length_Node
:= Make_Attribute_Reference
(Loc
,
10965 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10966 Attribute_Name
=> Name_Length
,
10968 New_List
(Make_Integer_Literal
(Loc
, Depth
)));
10969 Set_Etype
(Length_Node
, RTE
(RE_Long_Unsigned
));
10971 Add_Process_Element
(Dimen_Stmts
,
10972 Datum
=> Length_Node
,
10974 Counter
=> Inner_Counter
);
10977 -- Loop_Stm does appropriate processing for each element
10980 Append_To
(Dimen_Stmts
, Loop_Stm
);
10982 -- Link outer and inner any
10984 if Present
(Inner_Any
) then
10985 Add_Process_Element
(Dimen_Stmts
,
10987 Counter
=> Counter
,
10988 Datum
=> New_Occurrence_Of
(Inner_Any
, Loc
));
10992 Make_Block_Statement
(Loc
,
10995 Handled_Statement_Sequence
=>
10996 Make_Handled_Sequence_Of_Statements
(Loc
,
10997 Statements
=> Dimen_Stmts
)));
10999 end Append_Array_Traversal
;
11001 -------------------------------
11002 -- Make_Helper_Function_Name --
11003 -------------------------------
11005 function Make_Helper_Function_Name
11008 Nam
: Name_Id
) return Entity_Id
11013 -- For tagged types, we use a canonical name so that it matches
11014 -- the primitive spec. For all other cases, we use a serialized
11015 -- name so that multiple generations of the same procedure do
11019 if not Is_Tagged_Type
(Typ
) then
11020 Serial
:= Increment_Serial_Number
;
11023 -- Use prefixed underscore to avoid potential clash with used
11024 -- identifier (we use attribute names for Nam).
11027 Make_Defining_Identifier
(Loc
,
11030 (Related_Id
=> Nam
,
11031 Suffix
=> ' ', Suffix_Index
=> Serial
,
11034 end Make_Helper_Function_Name
;
11037 -----------------------------------
11038 -- Reserve_NamingContext_Methods --
11039 -----------------------------------
11041 procedure Reserve_NamingContext_Methods
is
11042 Str_Resolve
: constant String := "resolve";
11044 Name_Buffer
(1 .. Str_Resolve
'Length) := Str_Resolve
;
11045 Name_Len
:= Str_Resolve
'Length;
11046 Overload_Counter_Table
.Set
(Name_Find
, 1);
11047 end Reserve_NamingContext_Methods
;
11049 end PolyORB_Support
;
11051 -------------------------------
11052 -- RACW_Type_Is_Asynchronous --
11053 -------------------------------
11055 procedure RACW_Type_Is_Asynchronous
(RACW_Type
: Entity_Id
) is
11056 Asynchronous_Flag
: constant Entity_Id
:=
11057 Asynchronous_Flags_Table
.Get
(RACW_Type
);
11059 Replace
(Expression
(Parent
(Asynchronous_Flag
)),
11060 New_Occurrence_Of
(Standard_True
, Sloc
(Asynchronous_Flag
)));
11061 end RACW_Type_Is_Asynchronous
;
11063 -------------------------
11064 -- RCI_Package_Locator --
11065 -------------------------
11067 function RCI_Package_Locator
11069 Package_Spec
: Node_Id
) return Node_Id
11072 Pkg_Name
: String_Id
;
11075 Get_Library_Unit_Name_String
(Package_Spec
);
11076 Pkg_Name
:= String_From_Name_Buffer
;
11078 Make_Package_Instantiation
(Loc
,
11079 Defining_Unit_Name
=>
11080 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
11082 New_Occurrence_Of
(RTE
(RE_RCI_Locator
), Loc
),
11083 Generic_Associations
=> New_List
(
11084 Make_Generic_Association
(Loc
,
11086 Make_Identifier
(Loc
, Name_RCI_Name
),
11087 Explicit_Generic_Actual_Parameter
=>
11088 Make_String_Literal
(Loc
,
11089 Strval
=> Pkg_Name
)),
11090 Make_Generic_Association
(Loc
,
11092 Make_Identifier
(Loc
, Name_Version
),
11093 Explicit_Generic_Actual_Parameter
=>
11094 Make_Attribute_Reference
(Loc
,
11096 New_Occurrence_Of
(Defining_Entity
(Package_Spec
), Loc
),
11100 RCI_Locator_Table
.Set
(Defining_Unit_Name
(Package_Spec
),
11101 Defining_Unit_Name
(Inst
));
11103 end RCI_Package_Locator
;
11105 -----------------------------------------------
11106 -- Remote_Types_Tagged_Full_View_Encountered --
11107 -----------------------------------------------
11109 procedure Remote_Types_Tagged_Full_View_Encountered
11110 (Full_View
: Entity_Id
)
11112 Stub_Elements
: constant Stub_Structure
:=
11113 Stubs_Table
.Get
(Full_View
);
11116 -- For an RACW encountered before the freeze point of its designated
11117 -- type, the stub type is generated at the point of the RACW declaration
11118 -- but the primitives are generated only once the designated type is
11119 -- frozen. That freeze can occur in another scope, for example when the
11120 -- RACW is declared in a nested package. In that case we need to
11121 -- reestablish the stub type's scope prior to generating its primitive
11124 if Stub_Elements
/= Empty_Stub_Structure
then
11126 Saved_Scope
: constant Entity_Id
:= Current_Scope
;
11127 Stubs_Scope
: constant Entity_Id
:=
11128 Scope
(Stub_Elements
.Stub_Type
);
11131 if Current_Scope
/= Stubs_Scope
then
11132 Push_Scope
(Stubs_Scope
);
11135 Add_RACW_Primitive_Declarations_And_Bodies
11137 Stub_Elements
.RPC_Receiver_Decl
,
11138 Stub_Elements
.Body_Decls
);
11140 if Current_Scope
/= Saved_Scope
then
11145 end Remote_Types_Tagged_Full_View_Encountered
;
11147 -------------------
11148 -- Scope_Of_Spec --
11149 -------------------
11151 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
is
11152 Unit_Name
: Node_Id
;
11155 Unit_Name
:= Defining_Unit_Name
(Spec
);
11156 while Nkind
(Unit_Name
) /= N_Defining_Identifier
loop
11157 Unit_Name
:= Defining_Identifier
(Unit_Name
);
11163 ----------------------
11164 -- Set_Renaming_TSS --
11165 ----------------------
11167 procedure Set_Renaming_TSS
11170 TSS_Nam
: TSS_Name_Type
)
11172 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
11173 Spec
: constant Node_Id
:= Parent
(Nam
);
11175 TSS_Node
: constant Node_Id
:=
11176 Make_Subprogram_Renaming_Declaration
(Loc
,
11178 Copy_Specification
(Loc
,
11180 New_Name
=> Make_TSS_Name
(Typ
, TSS_Nam
)),
11181 Name
=> New_Occurrence_Of
(Nam
, Loc
));
11183 Snam
: constant Entity_Id
:=
11184 Defining_Unit_Name
(Specification
(TSS_Node
));
11187 if Nkind
(Spec
) = N_Function_Specification
then
11188 Set_Ekind
(Snam
, E_Function
);
11189 Set_Etype
(Snam
, Entity
(Result_Definition
(Spec
)));
11191 Set_Ekind
(Snam
, E_Procedure
);
11192 Set_Etype
(Snam
, Standard_Void_Type
);
11195 Set_TSS
(Typ
, Snam
);
11196 end Set_Renaming_TSS
;
11198 ----------------------------------------------
11199 -- Specific_Add_Obj_RPC_Receiver_Completion --
11200 ----------------------------------------------
11202 procedure Specific_Add_Obj_RPC_Receiver_Completion
11205 RPC_Receiver
: Entity_Id
;
11206 Stub_Elements
: Stub_Structure
)
11209 case Get_PCS_Name
is
11210 when Name_PolyORB_DSA
=>
11211 PolyORB_Support
.Add_Obj_RPC_Receiver_Completion
(Loc
,
11212 Decls
, RPC_Receiver
, Stub_Elements
);
11214 GARLIC_Support
.Add_Obj_RPC_Receiver_Completion
(Loc
,
11215 Decls
, RPC_Receiver
, Stub_Elements
);
11217 end Specific_Add_Obj_RPC_Receiver_Completion
;
11219 --------------------------------
11220 -- Specific_Add_RACW_Features --
11221 --------------------------------
11223 procedure Specific_Add_RACW_Features
11224 (RACW_Type
: Entity_Id
;
11226 Stub_Type
: Entity_Id
;
11227 Stub_Type_Access
: Entity_Id
;
11228 RPC_Receiver_Decl
: Node_Id
;
11229 Body_Decls
: List_Id
)
11232 case Get_PCS_Name
is
11233 when Name_PolyORB_DSA
=>
11234 PolyORB_Support
.Add_RACW_Features
11243 GARLIC_Support
.Add_RACW_Features
11250 end Specific_Add_RACW_Features
;
11252 --------------------------------
11253 -- Specific_Add_RAST_Features --
11254 --------------------------------
11256 procedure Specific_Add_RAST_Features
11257 (Vis_Decl
: Node_Id
;
11258 RAS_Type
: Entity_Id
)
11261 case Get_PCS_Name
is
11262 when Name_PolyORB_DSA
=>
11263 PolyORB_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
11265 GARLIC_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
11267 end Specific_Add_RAST_Features
;
11269 --------------------------------------------------
11270 -- Specific_Add_Receiving_Stubs_To_Declarations --
11271 --------------------------------------------------
11273 procedure Specific_Add_Receiving_Stubs_To_Declarations
11274 (Pkg_Spec
: Node_Id
;
11279 case Get_PCS_Name
is
11280 when Name_PolyORB_DSA
=>
11281 PolyORB_Support
.Add_Receiving_Stubs_To_Declarations
11282 (Pkg_Spec
, Decls
, Stmts
);
11284 GARLIC_Support
.Add_Receiving_Stubs_To_Declarations
11285 (Pkg_Spec
, Decls
, Stmts
);
11287 end Specific_Add_Receiving_Stubs_To_Declarations
;
11289 ------------------------------------------
11290 -- Specific_Build_General_Calling_Stubs --
11291 ------------------------------------------
11293 procedure Specific_Build_General_Calling_Stubs
11295 Statements
: List_Id
;
11296 Target
: RPC_Target
;
11297 Subprogram_Id
: Node_Id
;
11298 Asynchronous
: Node_Id
:= Empty
;
11299 Is_Known_Asynchronous
: Boolean := False;
11300 Is_Known_Non_Asynchronous
: Boolean := False;
11301 Is_Function
: Boolean;
11303 Stub_Type
: Entity_Id
:= Empty
;
11304 RACW_Type
: Entity_Id
:= Empty
;
11308 case Get_PCS_Name
is
11309 when Name_PolyORB_DSA
=>
11310 PolyORB_Support
.Build_General_Calling_Stubs
11316 Is_Known_Asynchronous
,
11317 Is_Known_Non_Asynchronous
,
11325 GARLIC_Support
.Build_General_Calling_Stubs
11329 Target
.RPC_Receiver
,
11332 Is_Known_Asynchronous
,
11333 Is_Known_Non_Asynchronous
,
11340 end Specific_Build_General_Calling_Stubs
;
11342 --------------------------------------
11343 -- Specific_Build_RPC_Receiver_Body --
11344 --------------------------------------
11346 procedure Specific_Build_RPC_Receiver_Body
11347 (RPC_Receiver
: Entity_Id
;
11348 Request
: out Entity_Id
;
11349 Subp_Id
: out Entity_Id
;
11350 Subp_Index
: out Entity_Id
;
11351 Stmts
: out List_Id
;
11352 Decl
: out Node_Id
)
11355 case Get_PCS_Name
is
11356 when Name_PolyORB_DSA
=>
11357 PolyORB_Support
.Build_RPC_Receiver_Body
11366 GARLIC_Support
.Build_RPC_Receiver_Body
11374 end Specific_Build_RPC_Receiver_Body
;
11376 --------------------------------
11377 -- Specific_Build_Stub_Target --
11378 --------------------------------
11380 function Specific_Build_Stub_Target
11383 RCI_Locator
: Entity_Id
;
11384 Controlling_Parameter
: Entity_Id
) return RPC_Target
11387 case Get_PCS_Name
is
11388 when Name_PolyORB_DSA
=>
11389 return PolyORB_Support
.Build_Stub_Target
(Loc
,
11390 Decls
, RCI_Locator
, Controlling_Parameter
);
11393 return GARLIC_Support
.Build_Stub_Target
(Loc
,
11394 Decls
, RCI_Locator
, Controlling_Parameter
);
11396 end Specific_Build_Stub_Target
;
11398 ------------------------------
11399 -- Specific_Build_Stub_Type --
11400 ------------------------------
11402 procedure Specific_Build_Stub_Type
11403 (RACW_Type
: Entity_Id
;
11404 Stub_Type
: Entity_Id
;
11405 Stub_Type_Decl
: out Node_Id
;
11406 RPC_Receiver_Decl
: out Node_Id
)
11409 case Get_PCS_Name
is
11410 when Name_PolyORB_DSA
=>
11411 PolyORB_Support
.Build_Stub_Type
(
11412 RACW_Type
, Stub_Type
,
11413 Stub_Type_Decl
, RPC_Receiver_Decl
);
11416 GARLIC_Support
.Build_Stub_Type
(
11417 RACW_Type
, Stub_Type
,
11418 Stub_Type_Decl
, RPC_Receiver_Decl
);
11420 end Specific_Build_Stub_Type
;
11422 function Specific_Build_Subprogram_Receiving_Stubs
11423 (Vis_Decl
: Node_Id
;
11424 Asynchronous
: Boolean;
11425 Dynamically_Asynchronous
: Boolean := False;
11426 Stub_Type
: Entity_Id
:= Empty
;
11427 RACW_Type
: Entity_Id
:= Empty
;
11428 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
11431 case Get_PCS_Name
is
11432 when Name_PolyORB_DSA
=>
11433 return PolyORB_Support
.Build_Subprogram_Receiving_Stubs
11436 Dynamically_Asynchronous
,
11442 return GARLIC_Support
.Build_Subprogram_Receiving_Stubs
11445 Dynamically_Asynchronous
,
11450 end Specific_Build_Subprogram_Receiving_Stubs
;
11452 -------------------------------
11453 -- Transmit_As_Unconstrained --
11454 -------------------------------
11456 function Transmit_As_Unconstrained
(Typ
: Entity_Id
) return Boolean is
11459 not (Is_Elementary_Type
(Typ
) or else Is_Constrained
(Typ
))
11460 or else (Is_Access_Type
(Typ
) and then Can_Never_Be_Null
(Typ
));
11461 end Transmit_As_Unconstrained
;
11463 --------------------------
11464 -- Underlying_RACW_Type --
11465 --------------------------
11467 function Underlying_RACW_Type
(RAS_Typ
: Entity_Id
) return Entity_Id
is
11468 Record_Type
: Entity_Id
;
11471 if Ekind
(RAS_Typ
) = E_Record_Type
then
11472 Record_Type
:= RAS_Typ
;
11474 pragma Assert
(Present
(Equivalent_Type
(RAS_Typ
)));
11475 Record_Type
:= Equivalent_Type
(RAS_Typ
);
11479 Etype
(Subtype_Indication
11480 (Component_Definition
11481 (First
(Component_Items
11484 (Declaration_Node
(Record_Type
))))))));
11485 end Underlying_RACW_Type
;