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 ------------------------------------
862 -- Local variables and structures --
863 ------------------------------------
866 -- Needs comments ???
868 Output_From_Constrained
: constant array (Boolean) of Name_Id
:=
869 (False => Name_Output
,
871 -- The attribute to choose depending on the fact that the parameter
872 -- is constrained or not. There is no such thing as Input_From_Constrained
873 -- since this require separate mechanisms ('Input is a function while
874 -- 'Read is a procedure).
876 ---------------------------------------
877 -- Add_Calling_Stubs_To_Declarations --
878 ---------------------------------------
880 procedure Add_Calling_Stubs_To_Declarations
884 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
885 -- Subprogram id 0 is reserved for calls received from
886 -- remote access-to-subprogram dereferences.
888 Current_Declaration
: Node_Id
;
889 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
890 RCI_Instantiation
: Node_Id
;
891 Subp_Stubs
: Node_Id
;
892 Subp_Str
: String_Id
;
894 pragma Warnings
(Off
, Subp_Str
);
897 -- The first thing added is an instantiation of the generic package
898 -- System.Partition_Interface.RCI_Locator with the name of this remote
899 -- package. This will act as an interface with the name server to
900 -- determine the Partition_ID and the RPC_Receiver for the receiver
903 RCI_Instantiation
:= RCI_Package_Locator
(Loc
, Pkg_Spec
);
904 RCI_Cache
:= Defining_Unit_Name
(RCI_Instantiation
);
906 Append_To
(Decls
, RCI_Instantiation
);
907 Analyze
(RCI_Instantiation
);
909 -- For each subprogram declaration visible in the spec, we do build a
910 -- body. We also increment a counter to assign a different Subprogram_Id
911 -- to each subprograms. The receiving stubs processing do use the same
912 -- mechanism and will thus assign the same Id and do the correct
915 Overload_Counter_Table
.Reset
;
916 PolyORB_Support
.Reserve_NamingContext_Methods
;
918 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
919 while Present
(Current_Declaration
) loop
920 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
921 and then Comes_From_Source
(Current_Declaration
)
923 Assign_Subprogram_Identifier
924 (Defining_Unit_Name
(Specification
(Current_Declaration
)),
925 Current_Subprogram_Number
,
929 Build_Subprogram_Calling_Stubs
(
930 Vis_Decl
=> Current_Declaration
,
932 Build_Subprogram_Id
(Loc
,
933 Defining_Unit_Name
(Specification
(Current_Declaration
))),
935 Nkind
(Specification
(Current_Declaration
)) =
936 N_Procedure_Specification
938 Is_Asynchronous
(Defining_Unit_Name
(Specification
939 (Current_Declaration
))));
941 Append_To
(Decls
, Subp_Stubs
);
942 Analyze
(Subp_Stubs
);
944 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
947 Next
(Current_Declaration
);
949 end Add_Calling_Stubs_To_Declarations
;
951 -----------------------------
952 -- Add_Parameter_To_NVList --
953 -----------------------------
955 function Add_Parameter_To_NVList
958 Parameter
: Entity_Id
;
959 Constrained
: Boolean;
960 RACW_Ctrl
: Boolean := False;
961 Any
: Entity_Id
) return Node_Id
963 Parameter_Name_String
: String_Id
;
964 Parameter_Mode
: Node_Id
;
966 function Parameter_Passing_Mode
968 Parameter
: Entity_Id
;
969 Constrained
: Boolean) return Node_Id
;
970 -- Return an expression that denotes the parameter passing mode to be
971 -- used for Parameter in distribution stubs, where Constrained is
972 -- Parameter's constrained status.
974 ----------------------------
975 -- Parameter_Passing_Mode --
976 ----------------------------
978 function Parameter_Passing_Mode
980 Parameter
: Entity_Id
;
981 Constrained
: Boolean) return Node_Id
986 if Out_Present
(Parameter
) then
987 if In_Present
(Parameter
)
988 or else not Constrained
990 -- Unconstrained formals must be translated
991 -- to 'in' or 'inout', not 'out', because
992 -- they need to be constrained by the actual.
994 Lib_RE
:= RE_Mode_Inout
;
996 Lib_RE
:= RE_Mode_Out
;
1000 Lib_RE
:= RE_Mode_In
;
1003 return New_Occurrence_Of
(RTE
(Lib_RE
), Loc
);
1004 end Parameter_Passing_Mode
;
1006 -- Start of processing for Add_Parameter_To_NVList
1009 if Nkind
(Parameter
) = N_Defining_Identifier
then
1010 Get_Name_String
(Chars
(Parameter
));
1012 Get_Name_String
(Chars
(Defining_Identifier
(Parameter
)));
1015 Parameter_Name_String
:= String_From_Name_Buffer
;
1017 if RACW_Ctrl
or else Nkind
(Parameter
) = N_Defining_Identifier
then
1019 -- When the parameter passed to Add_Parameter_To_NVList is an
1020 -- Extra_Constrained parameter, Parameter is an N_Defining_
1021 -- Identifier, instead of a complete N_Parameter_Specification.
1022 -- Thus, we explicitly set 'in' mode in this case.
1024 Parameter_Mode
:= New_Occurrence_Of
(RTE
(RE_Mode_In
), Loc
);
1028 Parameter_Passing_Mode
(Loc
, Parameter
, Constrained
);
1032 Make_Procedure_Call_Statement
(Loc
,
1035 (RTE
(RE_NVList_Add_Item
), Loc
),
1036 Parameter_Associations
=> New_List
(
1037 New_Occurrence_Of
(NVList
, Loc
),
1038 Make_Function_Call
(Loc
,
1041 (RTE
(RE_To_PolyORB_String
), Loc
),
1042 Parameter_Associations
=> New_List
(
1043 Make_String_Literal
(Loc
,
1044 Strval
=> Parameter_Name_String
))),
1045 New_Occurrence_Of
(Any
, Loc
),
1047 end Add_Parameter_To_NVList
;
1049 --------------------------------
1050 -- Add_RACW_Asynchronous_Flag --
1051 --------------------------------
1053 procedure Add_RACW_Asynchronous_Flag
1054 (Declarations
: List_Id
;
1055 RACW_Type
: Entity_Id
)
1057 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1059 Asynchronous_Flag
: constant Entity_Id
:=
1060 Make_Defining_Identifier
(Loc
,
1061 New_External_Name
(Chars
(RACW_Type
), 'A'));
1064 -- Declare the asynchronous flag. This flag will be changed to True
1065 -- whenever it is known that the RACW type is asynchronous.
1067 Append_To
(Declarations
,
1068 Make_Object_Declaration
(Loc
,
1069 Defining_Identifier
=> Asynchronous_Flag
,
1070 Constant_Present
=> True,
1071 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
1072 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
1074 Asynchronous_Flags_Table
.Set
(RACW_Type
, Asynchronous_Flag
);
1075 end Add_RACW_Asynchronous_Flag
;
1077 -----------------------
1078 -- Add_RACW_Features --
1079 -----------------------
1081 procedure Add_RACW_Features
(RACW_Type
: Entity_Id
) is
1082 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
1083 Same_Scope
: constant Boolean := Scope
(Desig
) = Scope
(RACW_Type
);
1087 Body_Decls
: List_Id
;
1089 Stub_Type
: Entity_Id
;
1090 Stub_Type_Access
: Entity_Id
;
1091 RPC_Receiver_Decl
: Node_Id
;
1094 -- True when appropriate stubs have already been generated (this is the
1095 -- case when another RACW with the same designated type has already been
1096 -- encountered), in which case we reuse the previous stubs rather than
1097 -- generating new ones.
1100 if not Expander_Active
then
1104 -- Mark the current package declaration as containing an RACW, so that
1105 -- the bodies for the calling stubs and the RACW stream subprograms
1106 -- are attached to the tree when the corresponding body is encountered.
1108 Set_Has_RACW
(Current_Scope
);
1110 -- Look for place to declare the RACW stub type and RACW operations
1116 -- Case of declaring the RACW in the same package as its designated
1117 -- type: we know that the designated type is a private type, so we
1118 -- use the private declarations list.
1120 Pkg_Spec
:= Package_Specification_Of_Scope
(Current_Scope
);
1122 if Present
(Private_Declarations
(Pkg_Spec
)) then
1123 Decls
:= Private_Declarations
(Pkg_Spec
);
1125 Decls
:= Visible_Declarations
(Pkg_Spec
);
1130 -- Case of declaring the RACW in another package than its designated
1131 -- type: use the private declarations list if present; otherwise
1132 -- use the visible declarations.
1134 Decls
:= List_Containing
(Declaration_Node
(RACW_Type
));
1138 -- If we were unable to find the declarations, that means that the
1139 -- completion of the type was missing. We can safely return and let the
1140 -- error be caught by the semantic analysis.
1147 (Designated_Type
=> Desig
,
1148 RACW_Type
=> RACW_Type
,
1150 Stub_Type
=> Stub_Type
,
1151 Stub_Type_Access
=> Stub_Type_Access
,
1152 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1153 Body_Decls
=> Body_Decls
,
1154 Existing
=> Existing
);
1156 -- If this RACW is not in the main unit, do not generate primitive or
1159 if not Entity_Is_In_Main_Unit
(RACW_Type
) then
1160 Body_Decls
:= No_List
;
1163 Add_RACW_Asynchronous_Flag
1164 (Declarations
=> Decls
,
1165 RACW_Type
=> RACW_Type
);
1167 Specific_Add_RACW_Features
1168 (RACW_Type
=> RACW_Type
,
1170 Stub_Type
=> Stub_Type
,
1171 Stub_Type_Access
=> Stub_Type_Access
,
1172 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1173 Body_Decls
=> Body_Decls
);
1175 -- If we already have stubs for this designated type, nothing to do
1181 if Is_Frozen
(Desig
) then
1182 Validate_RACW_Primitives
(RACW_Type
);
1183 Add_RACW_Primitive_Declarations_And_Bodies
1184 (Designated_Type
=> Desig
,
1185 Insertion_Node
=> RPC_Receiver_Decl
,
1186 Body_Decls
=> Body_Decls
);
1189 -- Validate_RACW_Primitives requires the list of all primitives of
1190 -- the designated type, so defer processing until Desig is frozen.
1191 -- See Exp_Ch3.Freeze_Type.
1193 Add_Access_Type_To_Process
(E
=> Desig
, A
=> RACW_Type
);
1195 end Add_RACW_Features
;
1197 ------------------------------------------------
1198 -- Add_RACW_Primitive_Declarations_And_Bodies --
1199 ------------------------------------------------
1201 procedure Add_RACW_Primitive_Declarations_And_Bodies
1202 (Designated_Type
: Entity_Id
;
1203 Insertion_Node
: Node_Id
;
1204 Body_Decls
: List_Id
)
1206 Loc
: constant Source_Ptr
:= Sloc
(Insertion_Node
);
1207 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1208 -- the declarations are recognized as belonging to the current package.
1210 Stub_Elements
: constant Stub_Structure
:=
1211 Stubs_Table
.Get
(Designated_Type
);
1213 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
1215 Is_RAS
: constant Boolean :=
1216 not Comes_From_Source
(Stub_Elements
.RACW_Type
);
1217 -- Case of the RACW generated to implement a remote access-to-
1220 Build_Bodies
: constant Boolean :=
1221 In_Extended_Main_Code_Unit
(Stub_Elements
.Stub_Type
);
1222 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1223 -- only when the main unit is the unit that contains the stub type.
1225 Current_Insertion_Node
: Node_Id
:= Insertion_Node
;
1227 RPC_Receiver
: Entity_Id
;
1228 RPC_Receiver_Statements
: List_Id
;
1229 RPC_Receiver_Case_Alternatives
: constant List_Id
:= New_List
;
1230 RPC_Receiver_Elsif_Parts
: List_Id
;
1231 RPC_Receiver_Request
: Entity_Id
;
1232 RPC_Receiver_Subp_Id
: Entity_Id
;
1233 RPC_Receiver_Subp_Index
: Entity_Id
;
1235 Subp_Str
: String_Id
;
1237 Current_Primitive_Elmt
: Elmt_Id
;
1238 Current_Primitive
: Entity_Id
;
1239 Current_Primitive_Body
: Node_Id
;
1240 Current_Primitive_Spec
: Node_Id
;
1241 Current_Primitive_Decl
: Node_Id
;
1242 Current_Primitive_Number
: Int
:= 0;
1243 Current_Primitive_Alias
: Node_Id
;
1244 Current_Receiver
: Entity_Id
;
1245 Current_Receiver_Body
: Node_Id
;
1246 RPC_Receiver_Decl
: Node_Id
;
1247 Possibly_Asynchronous
: Boolean;
1250 if not Expander_Active
then
1256 Make_Defining_Identifier
(Loc
,
1257 Chars
=> New_Internal_Name
('P'));
1259 Specific_Build_RPC_Receiver_Body
1260 (RPC_Receiver
=> RPC_Receiver
,
1261 Request
=> RPC_Receiver_Request
,
1262 Subp_Id
=> RPC_Receiver_Subp_Id
,
1263 Subp_Index
=> RPC_Receiver_Subp_Index
,
1264 Stmts
=> RPC_Receiver_Statements
,
1265 Decl
=> RPC_Receiver_Decl
);
1267 if Get_PCS_Name
= Name_PolyORB_DSA
then
1269 -- For the case of PolyORB, we need to map a textual operation
1270 -- name into a primitive index. Currently we do so using a simple
1271 -- sequence of string comparisons.
1273 RPC_Receiver_Elsif_Parts
:= New_List
;
1277 -- Build callers, receivers for every primitive operations and a RPC
1278 -- receiver for this type.
1280 if Present
(Primitive_Operations
(Designated_Type
)) then
1281 Overload_Counter_Table
.Reset
;
1283 Current_Primitive_Elmt
:=
1284 First_Elmt
(Primitive_Operations
(Designated_Type
));
1285 while Current_Primitive_Elmt
/= No_Elmt
loop
1286 Current_Primitive
:= Node
(Current_Primitive_Elmt
);
1288 -- Copy the primitive of all the parents, except predefined ones
1289 -- that are not remotely dispatching. Also omit hidden primitives
1290 -- (occurs in the case of primitives of interface progenitors
1291 -- other than immediate ancestors of the Designated_Type).
1293 if Chars
(Current_Primitive
) /= Name_uSize
1294 and then Chars
(Current_Primitive
) /= Name_uAlignment
1296 (Is_TSS
(Current_Primitive
, TSS_Deep_Finalize
) or else
1297 Is_TSS
(Current_Primitive
, TSS_Stream_Input
) or else
1298 Is_TSS
(Current_Primitive
, TSS_Stream_Output
) or else
1299 Is_TSS
(Current_Primitive
, TSS_Stream_Read
) or else
1300 Is_TSS
(Current_Primitive
, TSS_Stream_Write
))
1301 and then not Is_Hidden
(Current_Primitive
)
1303 -- The first thing to do is build an up-to-date copy of the
1304 -- spec with all the formals referencing Designated_Type
1305 -- transformed into formals referencing Stub_Type. Since this
1306 -- primitive may have been inherited, go back the alias chain
1307 -- until the real primitive has been found.
1309 Current_Primitive_Alias
:= Current_Primitive
;
1310 while Present
(Alias
(Current_Primitive_Alias
)) loop
1312 (Current_Primitive_Alias
1313 /= Alias
(Current_Primitive_Alias
));
1314 Current_Primitive_Alias
:= Alias
(Current_Primitive_Alias
);
1317 -- Copy the spec from the original declaration for the purpose
1318 -- of declaring an overriding subprogram: we need to replace
1319 -- the type of each controlling formal with Stub_Type. The
1320 -- primitive may have been declared for Designated_Type or
1321 -- inherited from some ancestor type for which we do not have
1322 -- an easily determined Entity_Id. We have no systematic way
1323 -- of knowing which type to substitute Stub_Type for. Instead,
1324 -- Copy_Specification relies on the flag Is_Controlling_Formal
1325 -- to determine which formals to change.
1327 Current_Primitive_Spec
:=
1328 Copy_Specification
(Loc
,
1329 Spec
=> Parent
(Current_Primitive_Alias
),
1330 Ctrl_Type
=> Stub_Elements
.Stub_Type
);
1332 Current_Primitive_Decl
:=
1333 Make_Subprogram_Declaration
(Loc
,
1334 Specification
=> Current_Primitive_Spec
);
1336 Insert_After_And_Analyze
(Current_Insertion_Node
,
1337 Current_Primitive_Decl
);
1338 Current_Insertion_Node
:= Current_Primitive_Decl
;
1340 Possibly_Asynchronous
:=
1341 Nkind
(Current_Primitive_Spec
) = N_Procedure_Specification
1342 and then Could_Be_Asynchronous
(Current_Primitive_Spec
);
1344 Assign_Subprogram_Identifier
(
1345 Defining_Unit_Name
(Current_Primitive_Spec
),
1346 Current_Primitive_Number
,
1349 if Build_Bodies
then
1350 Current_Primitive_Body
:=
1351 Build_Subprogram_Calling_Stubs
1352 (Vis_Decl
=> Current_Primitive_Decl
,
1354 Build_Subprogram_Id
(Loc
,
1355 Defining_Unit_Name
(Current_Primitive_Spec
)),
1356 Asynchronous
=> Possibly_Asynchronous
,
1357 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1358 Stub_Type
=> Stub_Elements
.Stub_Type
,
1359 RACW_Type
=> Stub_Elements
.RACW_Type
);
1360 Append_To
(Body_Decls
, Current_Primitive_Body
);
1362 -- Analyzing the body here would cause the Stub type to
1363 -- be frozen, thus preventing subsequent primitive
1364 -- declarations. For this reason, it will be analyzed
1365 -- later in the regular flow (and in the context of the
1366 -- appropriate unit body, see Append_RACW_Bodies).
1370 -- Build the receiver stubs
1372 if Build_Bodies
and then not Is_RAS
then
1373 Current_Receiver_Body
:=
1374 Specific_Build_Subprogram_Receiving_Stubs
1375 (Vis_Decl
=> Current_Primitive_Decl
,
1376 Asynchronous
=> Possibly_Asynchronous
,
1377 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1378 Stub_Type
=> Stub_Elements
.Stub_Type
,
1379 RACW_Type
=> Stub_Elements
.RACW_Type
,
1380 Parent_Primitive
=> Current_Primitive
);
1382 Current_Receiver
:= Defining_Unit_Name
(
1383 Specification
(Current_Receiver_Body
));
1385 Append_To
(Body_Decls
, Current_Receiver_Body
);
1387 -- Add a case alternative to the receiver
1389 if Get_PCS_Name
= Name_PolyORB_DSA
then
1390 Append_To
(RPC_Receiver_Elsif_Parts
,
1391 Make_Elsif_Part
(Loc
,
1393 Make_Function_Call
(Loc
,
1396 RTE
(RE_Caseless_String_Eq
), Loc
),
1397 Parameter_Associations
=> New_List
(
1398 New_Occurrence_Of
(RPC_Receiver_Subp_Id
, Loc
),
1399 Make_String_Literal
(Loc
, Subp_Str
))),
1401 Then_Statements
=> New_List
(
1402 Make_Assignment_Statement
(Loc
,
1403 Name
=> New_Occurrence_Of
(
1404 RPC_Receiver_Subp_Index
, Loc
),
1406 Make_Integer_Literal
(Loc
,
1407 Intval
=> Current_Primitive_Number
)))));
1410 Append_To
(RPC_Receiver_Case_Alternatives
,
1411 Make_Case_Statement_Alternative
(Loc
,
1412 Discrete_Choices
=> New_List
(
1413 Make_Integer_Literal
(Loc
, Current_Primitive_Number
)),
1415 Statements
=> New_List
(
1416 Make_Procedure_Call_Statement
(Loc
,
1418 New_Occurrence_Of
(Current_Receiver
, Loc
),
1419 Parameter_Associations
=> New_List
(
1420 New_Occurrence_Of
(RPC_Receiver_Request
, Loc
))))));
1423 -- Increment the index of current primitive
1425 Current_Primitive_Number
:= Current_Primitive_Number
+ 1;
1428 Next_Elmt
(Current_Primitive_Elmt
);
1432 -- Build the case statement and the heart of the subprogram
1434 if Build_Bodies
and then not Is_RAS
then
1435 if Get_PCS_Name
= Name_PolyORB_DSA
1436 and then Present
(First
(RPC_Receiver_Elsif_Parts
))
1438 Append_To
(RPC_Receiver_Statements
,
1439 Make_Implicit_If_Statement
(Designated_Type
,
1440 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
1441 Then_Statements
=> New_List
,
1442 Elsif_Parts
=> RPC_Receiver_Elsif_Parts
));
1445 Append_To
(RPC_Receiver_Case_Alternatives
,
1446 Make_Case_Statement_Alternative
(Loc
,
1447 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1448 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
1450 Append_To
(RPC_Receiver_Statements
,
1451 Make_Case_Statement
(Loc
,
1453 New_Occurrence_Of
(RPC_Receiver_Subp_Index
, Loc
),
1454 Alternatives
=> RPC_Receiver_Case_Alternatives
));
1456 Append_To
(Body_Decls
, RPC_Receiver_Decl
);
1457 Specific_Add_Obj_RPC_Receiver_Completion
(Loc
,
1458 Body_Decls
, RPC_Receiver
, Stub_Elements
);
1460 -- Do not analyze RPC receiver body at this stage since it references
1461 -- subprograms that have not been analyzed yet. It will be analyzed in
1462 -- the regular flow (see Append_RACW_Bodies).
1465 end Add_RACW_Primitive_Declarations_And_Bodies
;
1467 -----------------------------
1468 -- Add_RAS_Dereference_TSS --
1469 -----------------------------
1471 procedure Add_RAS_Dereference_TSS
(N
: Node_Id
) is
1472 Loc
: constant Source_Ptr
:= Sloc
(N
);
1474 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
1475 RAS_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
1476 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(RAS_Type
);
1477 RACW_Type
: constant Entity_Id
:= Underlying_RACW_Type
(RAS_Type
);
1479 RACW_Primitive_Name
: Node_Id
;
1481 Proc
: constant Entity_Id
:=
1482 Make_Defining_Identifier
(Loc
,
1483 Chars
=> Make_TSS_Name
(RAS_Type
, TSS_RAS_Dereference
));
1485 Proc_Spec
: Node_Id
;
1486 Param_Specs
: List_Id
;
1487 Param_Assoc
: constant List_Id
:= New_List
;
1488 Stmts
: constant List_Id
:= New_List
;
1490 RAS_Parameter
: constant Entity_Id
:=
1491 Make_Defining_Identifier
(Loc
,
1492 Chars
=> New_Internal_Name
('P'));
1494 Is_Function
: constant Boolean :=
1495 Nkind
(Type_Def
) = N_Access_Function_Definition
;
1497 Is_Degenerate
: Boolean;
1498 -- Set to True if the subprogram_specification for this RAS has an
1499 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1501 Spec
: constant Node_Id
:= Type_Def
;
1503 Current_Parameter
: Node_Id
;
1505 -- Start of processing for Add_RAS_Dereference_TSS
1508 -- The Dereference TSS for a remote access-to-subprogram type has the
1511 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1514 -- This is called whenever a value of a RAS type is dereferenced
1516 -- First construct a list of parameter specifications:
1518 -- The first formal is the RAS values
1520 Param_Specs
:= New_List
(
1521 Make_Parameter_Specification
(Loc
,
1522 Defining_Identifier
=> RAS_Parameter
,
1525 New_Occurrence_Of
(Fat_Type
, Loc
)));
1527 -- The following formals are copied from the type declaration
1529 Is_Degenerate
:= False;
1530 Current_Parameter
:= First
(Parameter_Specifications
(Type_Def
));
1531 Parameters
: while Present
(Current_Parameter
) loop
1532 if Nkind
(Parameter_Type
(Current_Parameter
)) =
1535 Is_Degenerate
:= True;
1538 Append_To
(Param_Specs
,
1539 Make_Parameter_Specification
(Loc
,
1540 Defining_Identifier
=>
1541 Make_Defining_Identifier
(Loc
,
1542 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))),
1543 In_Present
=> In_Present
(Current_Parameter
),
1544 Out_Present
=> Out_Present
(Current_Parameter
),
1546 New_Copy_Tree
(Parameter_Type
(Current_Parameter
)),
1548 New_Copy_Tree
(Expression
(Current_Parameter
))));
1550 Append_To
(Param_Assoc
,
1551 Make_Identifier
(Loc
,
1552 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))));
1554 Next
(Current_Parameter
);
1555 end loop Parameters
;
1557 if Is_Degenerate
then
1558 Prepend_To
(Param_Assoc
, New_Occurrence_Of
(RAS_Parameter
, Loc
));
1560 -- Generate a dummy body. This code will never actually be executed,
1561 -- because null is the only legal value for a degenerate RAS type.
1562 -- For legality's sake (in order to avoid generating a function that
1563 -- does not contain a return statement), we include a dummy recursive
1564 -- call on the TSS itself.
1567 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Explicit_Raise
));
1568 RACW_Primitive_Name
:= New_Occurrence_Of
(Proc
, Loc
);
1571 -- For a normal RAS type, we cast the RAS formal to the corresponding
1572 -- tagged type, and perform a dispatching call to its Call primitive
1575 Prepend_To
(Param_Assoc
,
1576 Unchecked_Convert_To
(RACW_Type
,
1577 New_Occurrence_Of
(RAS_Parameter
, Loc
)));
1579 RACW_Primitive_Name
:=
1580 Make_Selected_Component
(Loc
,
1581 Prefix
=> Scope
(RACW_Type
),
1582 Selector_Name
=> Name_uCall
);
1587 Make_Simple_Return_Statement
(Loc
,
1589 Make_Function_Call
(Loc
,
1590 Name
=> RACW_Primitive_Name
,
1591 Parameter_Associations
=> Param_Assoc
)));
1595 Make_Procedure_Call_Statement
(Loc
,
1596 Name
=> RACW_Primitive_Name
,
1597 Parameter_Associations
=> Param_Assoc
));
1600 -- Build the complete subprogram
1604 Make_Function_Specification
(Loc
,
1605 Defining_Unit_Name
=> Proc
,
1606 Parameter_Specifications
=> Param_Specs
,
1607 Result_Definition
=>
1609 Entity
(Result_Definition
(Spec
)), Loc
));
1611 Set_Ekind
(Proc
, E_Function
);
1613 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
1617 Make_Procedure_Specification
(Loc
,
1618 Defining_Unit_Name
=> Proc
,
1619 Parameter_Specifications
=> Param_Specs
);
1621 Set_Ekind
(Proc
, E_Procedure
);
1622 Set_Etype
(Proc
, Standard_Void_Type
);
1626 Make_Subprogram_Body
(Loc
,
1627 Specification
=> Proc_Spec
,
1628 Declarations
=> New_List
,
1629 Handled_Statement_Sequence
=>
1630 Make_Handled_Sequence_Of_Statements
(Loc
,
1631 Statements
=> Stmts
)));
1633 Set_TSS
(Fat_Type
, Proc
);
1634 end Add_RAS_Dereference_TSS
;
1636 -------------------------------
1637 -- Add_RAS_Proxy_And_Analyze --
1638 -------------------------------
1640 procedure Add_RAS_Proxy_And_Analyze
1643 All_Calls_Remote_E
: Entity_Id
;
1644 Proxy_Object_Addr
: out Entity_Id
)
1646 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
1648 Subp_Name
: constant Entity_Id
:=
1649 Defining_Unit_Name
(Specification
(Vis_Decl
));
1651 Pkg_Name
: constant Entity_Id
:=
1652 Make_Defining_Identifier
(Loc
,
1653 Chars
=> New_External_Name
(Chars
(Subp_Name
), 'P', -1));
1655 Proxy_Type
: constant Entity_Id
:=
1656 Make_Defining_Identifier
(Loc
,
1659 (Related_Id
=> Chars
(Subp_Name
),
1662 Proxy_Type_Full_View
: constant Entity_Id
:=
1663 Make_Defining_Identifier
(Loc
,
1664 Chars
(Proxy_Type
));
1666 Subp_Decl_Spec
: constant Node_Id
:=
1667 Build_RAS_Primitive_Specification
1668 (Subp_Spec
=> Specification
(Vis_Decl
),
1669 Remote_Object_Type
=> Proxy_Type
);
1671 Subp_Body_Spec
: constant Node_Id
:=
1672 Build_RAS_Primitive_Specification
1673 (Subp_Spec
=> Specification
(Vis_Decl
),
1674 Remote_Object_Type
=> Proxy_Type
);
1676 Vis_Decls
: constant List_Id
:= New_List
;
1677 Pvt_Decls
: constant List_Id
:= New_List
;
1678 Actuals
: constant List_Id
:= New_List
;
1680 Perform_Call
: Node_Id
;
1683 -- type subpP is tagged limited private;
1685 Append_To
(Vis_Decls
,
1686 Make_Private_Type_Declaration
(Loc
,
1687 Defining_Identifier
=> Proxy_Type
,
1688 Tagged_Present
=> True,
1689 Limited_Present
=> True));
1691 -- [subprogram] Call
1692 -- (Self : access subpP;
1693 -- ...other-formals...)
1696 Append_To
(Vis_Decls
,
1697 Make_Subprogram_Declaration
(Loc
,
1698 Specification
=> Subp_Decl_Spec
));
1700 -- A : constant System.Address;
1702 Proxy_Object_Addr
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1704 Append_To
(Vis_Decls
,
1705 Make_Object_Declaration
(Loc
,
1706 Defining_Identifier
=> Proxy_Object_Addr
,
1707 Constant_Present
=> True,
1708 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
1712 -- type subpP is tagged limited record
1713 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1717 Append_To
(Pvt_Decls
,
1718 Make_Full_Type_Declaration
(Loc
,
1719 Defining_Identifier
=> Proxy_Type_Full_View
,
1721 Build_Remote_Subprogram_Proxy_Type
(Loc
,
1722 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
))));
1724 -- Trick semantic analysis into swapping the public and full view when
1725 -- freezing the public view.
1727 Set_Comes_From_Source
(Proxy_Type_Full_View
, True);
1730 -- (Self : access O;
1731 -- ...other-formals...) is
1733 -- P (...other-formals...);
1737 -- (Self : access O;
1738 -- ...other-formals...)
1741 -- return F (...other-formals...);
1744 if Nkind
(Subp_Decl_Spec
) = N_Procedure_Specification
then
1746 Make_Procedure_Call_Statement
(Loc
,
1747 Name
=> New_Occurrence_Of
(Subp_Name
, Loc
),
1748 Parameter_Associations
=> Actuals
);
1751 Make_Simple_Return_Statement
(Loc
,
1753 Make_Function_Call
(Loc
,
1754 Name
=> New_Occurrence_Of
(Subp_Name
, Loc
),
1755 Parameter_Associations
=> Actuals
));
1758 Formal
:= First
(Parameter_Specifications
(Subp_Decl_Spec
));
1759 pragma Assert
(Present
(Formal
));
1762 exit when No
(Formal
);
1764 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1767 -- O : aliased subpP;
1769 Append_To
(Pvt_Decls
,
1770 Make_Object_Declaration
(Loc
,
1771 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uO
),
1772 Aliased_Present
=> True,
1773 Object_Definition
=> New_Occurrence_Of
(Proxy_Type
, Loc
)));
1775 -- A : constant System.Address := O'Address;
1777 Append_To
(Pvt_Decls
,
1778 Make_Object_Declaration
(Loc
,
1779 Defining_Identifier
=>
1780 Make_Defining_Identifier
(Loc
, Chars
(Proxy_Object_Addr
)),
1781 Constant_Present
=> True,
1782 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
1784 Make_Attribute_Reference
(Loc
,
1785 Prefix
=> New_Occurrence_Of
(
1786 Defining_Identifier
(Last
(Pvt_Decls
)), Loc
),
1787 Attribute_Name
=> Name_Address
)));
1790 Make_Package_Declaration
(Loc
,
1791 Specification
=> Make_Package_Specification
(Loc
,
1792 Defining_Unit_Name
=> Pkg_Name
,
1793 Visible_Declarations
=> Vis_Decls
,
1794 Private_Declarations
=> Pvt_Decls
,
1795 End_Label
=> Empty
)));
1796 Analyze
(Last
(Decls
));
1799 Make_Package_Body
(Loc
,
1800 Defining_Unit_Name
=>
1801 Make_Defining_Identifier
(Loc
, Chars
(Pkg_Name
)),
1802 Declarations
=> New_List
(
1803 Make_Subprogram_Body
(Loc
,
1804 Specification
=> Subp_Body_Spec
,
1805 Declarations
=> New_List
,
1806 Handled_Statement_Sequence
=>
1807 Make_Handled_Sequence_Of_Statements
(Loc
,
1808 Statements
=> New_List
(Perform_Call
))))));
1809 Analyze
(Last
(Decls
));
1810 end Add_RAS_Proxy_And_Analyze
;
1812 -----------------------
1813 -- Add_RAST_Features --
1814 -----------------------
1816 procedure Add_RAST_Features
(Vis_Decl
: Node_Id
) is
1817 RAS_Type
: constant Entity_Id
:=
1818 Equivalent_Type
(Defining_Identifier
(Vis_Decl
));
1820 pragma Assert
(No
(TSS
(RAS_Type
, TSS_RAS_Access
)));
1821 Add_RAS_Dereference_TSS
(Vis_Decl
);
1822 Specific_Add_RAST_Features
(Vis_Decl
, RAS_Type
);
1823 end Add_RAST_Features
;
1829 procedure Add_Stub_Type
1830 (Designated_Type
: Entity_Id
;
1831 RACW_Type
: Entity_Id
;
1833 Stub_Type
: out Entity_Id
;
1834 Stub_Type_Access
: out Entity_Id
;
1835 RPC_Receiver_Decl
: out Node_Id
;
1836 Body_Decls
: out List_Id
;
1837 Existing
: out Boolean)
1839 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1841 Stub_Elements
: constant Stub_Structure
:=
1842 Stubs_Table
.Get
(Designated_Type
);
1843 Stub_Type_Decl
: Node_Id
;
1844 Stub_Type_Access_Decl
: Node_Id
;
1847 if Stub_Elements
/= Empty_Stub_Structure
then
1848 Stub_Type
:= Stub_Elements
.Stub_Type
;
1849 Stub_Type_Access
:= Stub_Elements
.Stub_Type_Access
;
1850 RPC_Receiver_Decl
:= Stub_Elements
.RPC_Receiver_Decl
;
1851 Body_Decls
:= Stub_Elements
.Body_Decls
;
1858 Make_Defining_Identifier
(Loc
,
1859 Chars
=> New_Internal_Name
('S'));
1860 Set_Ekind
(Stub_Type
, E_Record_Type
);
1861 Set_Is_RACW_Stub_Type
(Stub_Type
);
1863 Make_Defining_Identifier
(Loc
,
1864 Chars
=> New_External_Name
1865 (Related_Id
=> Chars
(Stub_Type
), Suffix
=> 'A'));
1867 Specific_Build_Stub_Type
1868 (RACW_Type
, Stub_Type
,
1869 Stub_Type_Decl
, RPC_Receiver_Decl
);
1871 Stub_Type_Access_Decl
:=
1872 Make_Full_Type_Declaration
(Loc
,
1873 Defining_Identifier
=> Stub_Type_Access
,
1875 Make_Access_To_Object_Definition
(Loc
,
1876 All_Present
=> True,
1877 Subtype_Indication
=> New_Occurrence_Of
(Stub_Type
, Loc
)));
1879 Append_To
(Decls
, Stub_Type_Decl
);
1880 Analyze
(Last
(Decls
));
1881 Append_To
(Decls
, Stub_Type_Access_Decl
);
1882 Analyze
(Last
(Decls
));
1884 -- This is in no way a type derivation, but we fake it to make sure that
1885 -- the dispatching table gets built with the corresponding primitive
1886 -- operations at the right place.
1888 Derive_Subprograms
(Parent_Type
=> Designated_Type
,
1889 Derived_Type
=> Stub_Type
);
1891 if Present
(RPC_Receiver_Decl
) then
1892 Append_To
(Decls
, RPC_Receiver_Decl
);
1894 RPC_Receiver_Decl
:= Last
(Decls
);
1897 Body_Decls
:= New_List
;
1899 Stubs_Table
.Set
(Designated_Type
,
1900 (Stub_Type
=> Stub_Type
,
1901 Stub_Type_Access
=> Stub_Type_Access
,
1902 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1903 Body_Decls
=> Body_Decls
,
1904 RACW_Type
=> RACW_Type
));
1907 ------------------------
1908 -- Append_RACW_Bodies --
1909 ------------------------
1911 procedure Append_RACW_Bodies
(Decls
: List_Id
; Spec_Id
: Entity_Id
) is
1914 E
:= First_Entity
(Spec_Id
);
1915 while Present
(E
) loop
1916 if Is_Remote_Access_To_Class_Wide_Type
(E
) then
1917 Append_List_To
(Decls
, Get_And_Reset_RACW_Bodies
(E
));
1922 end Append_RACW_Bodies
;
1924 ----------------------------------
1925 -- Assign_Subprogram_Identifier --
1926 ----------------------------------
1928 procedure Assign_Subprogram_Identifier
1933 N
: constant Name_Id
:= Chars
(Def
);
1935 Overload_Order
: constant Int
:=
1936 Overload_Counter_Table
.Get
(N
) + 1;
1939 Overload_Counter_Table
.Set
(N
, Overload_Order
);
1941 Get_Name_String
(N
);
1943 -- Homonym handling: as in Exp_Dbug, but much simpler,
1944 -- because the only entities for which we have to generate
1945 -- names here need only to be disambiguated within their
1948 if Overload_Order
> 1 then
1949 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 2) := "__";
1950 Name_Len
:= Name_Len
+ 2;
1951 Add_Nat_To_Name_Buffer
(Overload_Order
);
1954 Id
:= String_From_Name_Buffer
;
1955 Subprogram_Identifier_Table
.Set
(Def
,
1956 Subprogram_Identifiers
'(Str_Identifier => Id, Int_Identifier => Spn));
1957 end Assign_Subprogram_Identifier;
1959 -------------------------------------
1960 -- Build_Actual_Object_Declaration --
1961 -------------------------------------
1963 procedure Build_Actual_Object_Declaration
1964 (Object : Entity_Id;
1970 Loc : constant Source_Ptr := Sloc (Object);
1972 -- Declare a temporary object for the actual, possibly initialized with
1973 -- a 'Input
/From_Any call
.
1975 -- Complication arises in the case of limited types, for which such a
1976 -- declaration is illegal in Ada 95. In that case, we first generate a
1977 -- renaming declaration of the 'Input call, and then if needed we
1978 -- generate an overlaid non-constant view.
1980 if Ada_Version
<= Ada_95
1981 and then Is_Limited_Type
(Etyp
)
1982 and then Present
(Expr
)
1985 -- Object : Etyp renames <func-call>
1988 Make_Object_Renaming_Declaration
(Loc
,
1989 Defining_Identifier
=> Object
,
1990 Subtype_Mark
=> New_Occurrence_Of
(Etyp
, Loc
),
1995 -- The name defined by the renaming declaration denotes a
1996 -- constant view; create a non-constant object at the same address
1997 -- to be used as the actual.
2000 Constant_Object
: constant Entity_Id
:=
2001 Make_Defining_Identifier
(Loc
,
2002 New_Internal_Name
('P'));
2004 Set_Defining_Identifier
2005 (Last
(Decls
), Constant_Object
);
2007 -- We have an unconstrained Etyp: build the actual constrained
2008 -- subtype for the value we just read from the stream.
2010 -- subtype S is <actual subtype of Constant_Object>;
2013 Build_Actual_Subtype
(Etyp
,
2014 New_Occurrence_Of
(Constant_Object
, Loc
)));
2019 Make_Object_Declaration
(Loc
,
2020 Defining_Identifier
=> Object
,
2021 Object_Definition
=>
2023 (Defining_Identifier
(Last
(Decls
)), Loc
)));
2024 Set_Ekind
(Object
, E_Variable
);
2026 -- Suppress default initialization:
2027 -- pragma Import (Ada, Object);
2031 Chars
=> Name_Import
,
2032 Pragma_Argument_Associations
=> New_List
(
2033 Make_Pragma_Argument_Association
(Loc
,
2034 Chars
=> Name_Convention
,
2035 Expression
=> Make_Identifier
(Loc
, Name_Ada
)),
2036 Make_Pragma_Argument_Association
(Loc
,
2037 Chars
=> Name_Entity
,
2038 Expression
=> New_Occurrence_Of
(Object
, Loc
)))));
2040 -- for Object'Address use Constant_Object'Address;
2043 Make_Attribute_Definition_Clause
(Loc
,
2044 Name
=> New_Occurrence_Of
(Object
, Loc
),
2045 Chars
=> Name_Address
,
2047 Make_Attribute_Reference
(Loc
,
2048 Prefix
=> New_Occurrence_Of
(Constant_Object
, Loc
),
2049 Attribute_Name
=> Name_Address
)));
2055 -- General case of a regular object declaration. Object is flagged
2056 -- constant unless it has mode out or in out, to allow the backend
2057 -- to optimize where possible.
2059 -- Object : [constant] Etyp [:= <expr>];
2062 Make_Object_Declaration
(Loc
,
2063 Defining_Identifier
=> Object
,
2064 Constant_Present
=> Present
(Expr
) and then not Variable
,
2065 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
2066 Expression
=> Expr
));
2068 if Constant_Present
(Last
(Decls
)) then
2069 Set_Ekind
(Object
, E_Constant
);
2071 Set_Ekind
(Object
, E_Variable
);
2074 end Build_Actual_Object_Declaration
;
2076 ------------------------------
2077 -- Build_Get_Unique_RP_Call --
2078 ------------------------------
2080 function Build_Get_Unique_RP_Call
2082 Pointer
: Entity_Id
;
2083 Stub_Type
: Entity_Id
) return List_Id
2087 Make_Procedure_Call_Statement
(Loc
,
2089 New_Occurrence_Of
(RTE
(RE_Get_Unique_Remote_Pointer
), Loc
),
2090 Parameter_Associations
=> New_List
(
2091 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2092 New_Occurrence_Of
(Pointer
, Loc
)))),
2094 Make_Assignment_Statement
(Loc
,
2096 Make_Selected_Component
(Loc
,
2097 Prefix
=> New_Occurrence_Of
(Pointer
, Loc
),
2099 New_Occurrence_Of
(First_Tag_Component
2100 (Designated_Type
(Etype
(Pointer
))), Loc
)),
2102 Make_Attribute_Reference
(Loc
,
2103 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
2104 Attribute_Name
=> Name_Tag
)));
2106 -- Note: The assignment to Pointer._Tag is safe here because
2107 -- we carefully ensured that Stub_Type has exactly the same layout
2108 -- as System.Partition_Interface.RACW_Stub_Type.
2110 end Build_Get_Unique_RP_Call
;
2112 -----------------------------------
2113 -- Build_Ordered_Parameters_List --
2114 -----------------------------------
2116 function Build_Ordered_Parameters_List
(Spec
: Node_Id
) return List_Id
is
2117 Constrained_List
: List_Id
;
2118 Unconstrained_List
: List_Id
;
2119 Current_Parameter
: Node_Id
;
2122 First_Parameter
: Node_Id
;
2123 For_RAS
: Boolean := False;
2126 if No
(Parameter_Specifications
(Spec
)) then
2130 Constrained_List
:= New_List
;
2131 Unconstrained_List
:= New_List
;
2132 First_Parameter
:= First
(Parameter_Specifications
(Spec
));
2134 if Nkind
(Parameter_Type
(First_Parameter
)) = N_Access_Definition
2135 and then Chars
(Defining_Identifier
(First_Parameter
)) = Name_uS
2140 -- Loop through the parameters and add them to the right list. Note that
2141 -- we treat a parameter of a null-excluding access type as unconstrained
2142 -- because we can't declare an object of such a type with default
2145 Current_Parameter
:= First_Parameter
;
2146 while Present
(Current_Parameter
) loop
2147 Ptyp
:= Parameter_Type
(Current_Parameter
);
2149 if (Nkind
(Ptyp
) = N_Access_Definition
2150 or else not Transmit_As_Unconstrained
(Etype
(Ptyp
)))
2151 and then not (For_RAS
and then Current_Parameter
= First_Parameter
)
2153 Append_To
(Constrained_List
, New_Copy
(Current_Parameter
));
2155 Append_To
(Unconstrained_List
, New_Copy
(Current_Parameter
));
2158 Next
(Current_Parameter
);
2161 -- Unconstrained parameters are returned first
2163 Append_List_To
(Unconstrained_List
, Constrained_List
);
2165 return Unconstrained_List
;
2166 end Build_Ordered_Parameters_List
;
2168 ----------------------------------
2169 -- Build_Passive_Partition_Stub --
2170 ----------------------------------
2172 procedure Build_Passive_Partition_Stub
(U
: Node_Id
) is
2174 Pkg_Name
: String_Id
;
2177 Loc
: constant Source_Ptr
:= Sloc
(U
);
2180 -- Verify that the implementation supports distribution, by accessing
2181 -- a type defined in the proper version of system.rpc
2184 Dist_OK
: Entity_Id
;
2185 pragma Warnings
(Off
, Dist_OK
);
2187 Dist_OK
:= RTE
(RE_Params_Stream_Type
);
2190 -- Use body if present, spec otherwise
2192 if Nkind
(U
) = N_Package_Declaration
then
2193 Pkg_Spec
:= Specification
(U
);
2194 L
:= Visible_Declarations
(Pkg_Spec
);
2196 Pkg_Spec
:= Parent
(Corresponding_Spec
(U
));
2197 L
:= Declarations
(U
);
2200 Get_Library_Unit_Name_String
(Pkg_Spec
);
2201 Pkg_Name
:= String_From_Name_Buffer
;
2203 Make_Procedure_Call_Statement
(Loc
,
2205 New_Occurrence_Of
(RTE
(RE_Register_Passive_Package
), Loc
),
2206 Parameter_Associations
=> New_List
(
2207 Make_String_Literal
(Loc
, Pkg_Name
),
2208 Make_Attribute_Reference
(Loc
,
2210 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
2211 Attribute_Name
=> Name_Version
)));
2214 end Build_Passive_Partition_Stub
;
2216 --------------------------------------
2217 -- Build_RPC_Receiver_Specification --
2218 --------------------------------------
2220 function Build_RPC_Receiver_Specification
2221 (RPC_Receiver
: Entity_Id
;
2222 Request_Parameter
: Entity_Id
) return Node_Id
2224 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
2227 Make_Procedure_Specification
(Loc
,
2228 Defining_Unit_Name
=> RPC_Receiver
,
2229 Parameter_Specifications
=> New_List
(
2230 Make_Parameter_Specification
(Loc
,
2231 Defining_Identifier
=> Request_Parameter
,
2233 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
2234 end Build_RPC_Receiver_Specification
;
2236 ----------------------------------------
2237 -- Build_Remote_Subprogram_Proxy_Type --
2238 ----------------------------------------
2240 function Build_Remote_Subprogram_Proxy_Type
2242 ACR_Expression
: Node_Id
) return Node_Id
2246 Make_Record_Definition
(Loc
,
2247 Tagged_Present
=> True,
2248 Limited_Present
=> True,
2250 Make_Component_List
(Loc
,
2252 Component_Items
=> New_List
(
2253 Make_Component_Declaration
(Loc
,
2254 Defining_Identifier
=>
2255 Make_Defining_Identifier
(Loc
,
2256 Name_All_Calls_Remote
),
2257 Component_Definition
=>
2258 Make_Component_Definition
(Loc
,
2259 Subtype_Indication
=>
2260 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
2264 Make_Component_Declaration
(Loc
,
2265 Defining_Identifier
=>
2266 Make_Defining_Identifier
(Loc
,
2268 Component_Definition
=>
2269 Make_Component_Definition
(Loc
,
2270 Subtype_Indication
=>
2271 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2273 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)),
2275 Make_Component_Declaration
(Loc
,
2276 Defining_Identifier
=>
2277 Make_Defining_Identifier
(Loc
,
2279 Component_Definition
=>
2280 Make_Component_Definition
(Loc
,
2281 Subtype_Indication
=>
2282 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))))));
2283 end Build_Remote_Subprogram_Proxy_Type
;
2285 --------------------
2286 -- Build_Stub_Tag --
2287 --------------------
2289 function Build_Stub_Tag
2291 RACW_Type
: Entity_Id
) return Node_Id
2293 Stub_Type
: constant Entity_Id
:= Corresponding_Stub_Type
(RACW_Type
);
2296 Make_Attribute_Reference
(Loc
,
2297 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
2298 Attribute_Name
=> Name_Tag
);
2301 ------------------------------------
2302 -- Build_Subprogram_Calling_Stubs --
2303 ------------------------------------
2305 function Build_Subprogram_Calling_Stubs
2306 (Vis_Decl
: Node_Id
;
2308 Asynchronous
: Boolean;
2309 Dynamically_Asynchronous
: Boolean := False;
2310 Stub_Type
: Entity_Id
:= Empty
;
2311 RACW_Type
: Entity_Id
:= Empty
;
2312 Locator
: Entity_Id
:= Empty
;
2313 New_Name
: Name_Id
:= No_Name
) return Node_Id
2315 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
2317 Decls
: constant List_Id
:= New_List
;
2318 Statements
: constant List_Id
:= New_List
;
2320 Subp_Spec
: Node_Id
;
2321 -- The specification of the body
2323 Controlling_Parameter
: Entity_Id
:= Empty
;
2325 Asynchronous_Expr
: Node_Id
:= Empty
;
2327 RCI_Locator
: Entity_Id
;
2329 Spec_To_Use
: Node_Id
;
2331 procedure Insert_Partition_Check
(Parameter
: Node_Id
);
2332 -- Check that the parameter has been elaborated on the same partition
2333 -- than the controlling parameter (E.4(19)).
2335 ----------------------------
2336 -- Insert_Partition_Check --
2337 ----------------------------
2339 procedure Insert_Partition_Check
(Parameter
: Node_Id
) is
2340 Parameter_Entity
: constant Entity_Id
:=
2341 Defining_Identifier
(Parameter
);
2343 -- The expression that will be built is of the form:
2345 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2346 -- raise Constraint_Error;
2349 -- We do not check that Parameter is in Stub_Type since such a check
2350 -- has been inserted at the point of call already (a tag check since
2351 -- we have multiple controlling operands).
2354 Make_Raise_Constraint_Error
(Loc
,
2358 Make_Function_Call
(Loc
,
2360 New_Occurrence_Of
(RTE
(RE_Same_Partition
), Loc
),
2361 Parameter_Associations
=>
2363 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2364 New_Occurrence_Of
(Parameter_Entity
, Loc
)),
2365 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2366 New_Occurrence_Of
(Controlling_Parameter
, Loc
))))),
2367 Reason
=> CE_Partition_Check_Failed
));
2368 end Insert_Partition_Check
;
2370 -- Start of processing for Build_Subprogram_Calling_Stubs
2373 Subp_Spec
:= Copy_Specification
(Loc
,
2374 Spec
=> Specification
(Vis_Decl
),
2375 New_Name
=> New_Name
);
2377 if Locator
= Empty
then
2378 RCI_Locator
:= RCI_Cache
;
2379 Spec_To_Use
:= Specification
(Vis_Decl
);
2381 RCI_Locator
:= Locator
;
2382 Spec_To_Use
:= Subp_Spec
;
2385 -- Find a controlling argument if we have a stub type. Also check
2386 -- if this subprogram can be made asynchronous.
2388 if Present
(Stub_Type
)
2389 and then Present
(Parameter_Specifications
(Spec_To_Use
))
2392 Current_Parameter
: Node_Id
:=
2393 First
(Parameter_Specifications
2396 while Present
(Current_Parameter
) loop
2398 Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
)
2400 if Controlling_Parameter
= Empty
then
2401 Controlling_Parameter
:=
2402 Defining_Identifier
(Current_Parameter
);
2404 Insert_Partition_Check
(Current_Parameter
);
2408 Next
(Current_Parameter
);
2413 pragma Assert
(No
(Stub_Type
) or else Present
(Controlling_Parameter
));
2415 if Dynamically_Asynchronous
then
2416 Asynchronous_Expr
:= Make_Selected_Component
(Loc
,
2417 Prefix
=> Controlling_Parameter
,
2418 Selector_Name
=> Name_Asynchronous
);
2421 Specific_Build_General_Calling_Stubs
2423 Statements
=> Statements
,
2424 Target
=> Specific_Build_Stub_Target
(Loc
,
2425 Decls
, RCI_Locator
, Controlling_Parameter
),
2426 Subprogram_Id
=> Subp_Id
,
2427 Asynchronous
=> Asynchronous_Expr
,
2428 Is_Known_Asynchronous
=> Asynchronous
2429 and then not Dynamically_Asynchronous
,
2430 Is_Known_Non_Asynchronous
2432 and then not Dynamically_Asynchronous
,
2433 Is_Function
=> Nkind
(Spec_To_Use
) =
2434 N_Function_Specification
,
2435 Spec
=> Spec_To_Use
,
2436 Stub_Type
=> Stub_Type
,
2437 RACW_Type
=> RACW_Type
,
2440 RCI_Calling_Stubs_Table
.Set
2441 (Defining_Unit_Name
(Specification
(Vis_Decl
)),
2442 Defining_Unit_Name
(Spec_To_Use
));
2445 Make_Subprogram_Body
(Loc
,
2446 Specification
=> Subp_Spec
,
2447 Declarations
=> Decls
,
2448 Handled_Statement_Sequence
=>
2449 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
));
2450 end Build_Subprogram_Calling_Stubs
;
2452 -------------------------
2453 -- Build_Subprogram_Id --
2454 -------------------------
2456 function Build_Subprogram_Id
2458 E
: Entity_Id
) return Node_Id
2461 if Get_Subprogram_Ids
(E
).Str_Identifier
= No_String
then
2463 Current_Declaration
: Node_Id
;
2464 Current_Subp
: Entity_Id
;
2465 Current_Subp_Str
: String_Id
;
2466 Current_Subp_Number
: Int
:= First_RCI_Subprogram_Id
;
2468 pragma Warnings
(Off
, Current_Subp_Str
);
2471 -- Build_Subprogram_Id is called outside of the context of
2472 -- generating calling or receiving stubs. Hence we are processing
2473 -- an 'Access attribute_reference for an RCI subprogram, for the
2474 -- purpose of obtaining a RAS value.
2477 (Is_Remote_Call_Interface
(Scope
(E
))
2479 (Nkind
(Parent
(E
)) = N_Procedure_Specification
2481 Nkind
(Parent
(E
)) = N_Function_Specification
));
2483 Current_Declaration
:=
2484 First
(Visible_Declarations
2485 (Package_Specification_Of_Scope
(Scope
(E
))));
2486 while Present
(Current_Declaration
) loop
2487 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
2488 and then Comes_From_Source
(Current_Declaration
)
2490 Current_Subp
:= Defining_Unit_Name
(Specification
(
2491 Current_Declaration
));
2493 Assign_Subprogram_Identifier
2494 (Current_Subp
, Current_Subp_Number
, Current_Subp_Str
);
2496 Current_Subp_Number
:= Current_Subp_Number
+ 1;
2499 Next
(Current_Declaration
);
2504 case Get_PCS_Name
is
2505 when Name_PolyORB_DSA
=>
2506 return Make_String_Literal
(Loc
, Get_Subprogram_Id
(E
));
2508 return Make_Integer_Literal
(Loc
, Get_Subprogram_Id
(E
));
2510 end Build_Subprogram_Id
;
2512 ------------------------
2513 -- Copy_Specification --
2514 ------------------------
2516 function Copy_Specification
2519 Ctrl_Type
: Entity_Id
:= Empty
;
2520 New_Name
: Name_Id
:= No_Name
) return Node_Id
2522 Parameters
: List_Id
:= No_List
;
2524 Current_Parameter
: Node_Id
;
2525 Current_Identifier
: Entity_Id
;
2526 Current_Type
: Node_Id
;
2528 Name_For_New_Spec
: Name_Id
;
2530 New_Identifier
: Entity_Id
;
2532 -- Comments needed in body below ???
2535 if New_Name
= No_Name
then
2536 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
2537 or else Nkind
(Spec
) = N_Procedure_Specification
);
2539 Name_For_New_Spec
:= Chars
(Defining_Unit_Name
(Spec
));
2541 Name_For_New_Spec
:= New_Name
;
2544 if Present
(Parameter_Specifications
(Spec
)) then
2545 Parameters
:= New_List
;
2546 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2547 while Present
(Current_Parameter
) loop
2548 Current_Identifier
:= Defining_Identifier
(Current_Parameter
);
2549 Current_Type
:= Parameter_Type
(Current_Parameter
);
2551 if Nkind
(Current_Type
) = N_Access_Definition
then
2552 if Present
(Ctrl_Type
) then
2553 pragma Assert
(Is_Controlling_Formal
(Current_Identifier
));
2555 Make_Access_Definition
(Loc
,
2556 Subtype_Mark
=> New_Occurrence_Of
(Ctrl_Type
, Loc
),
2557 Null_Exclusion_Present
=>
2558 Null_Exclusion_Present
(Current_Type
));
2562 Make_Access_Definition
(Loc
,
2564 New_Copy_Tree
(Subtype_Mark
(Current_Type
)),
2565 Null_Exclusion_Present
=>
2566 Null_Exclusion_Present
(Current_Type
));
2570 if Present
(Ctrl_Type
)
2571 and then Is_Controlling_Formal
(Current_Identifier
)
2573 Current_Type
:= New_Occurrence_Of
(Ctrl_Type
, Loc
);
2575 Current_Type
:= New_Copy_Tree
(Current_Type
);
2579 New_Identifier
:= Make_Defining_Identifier
(Loc
,
2580 Chars
(Current_Identifier
));
2582 Append_To
(Parameters
,
2583 Make_Parameter_Specification
(Loc
,
2584 Defining_Identifier
=> New_Identifier
,
2585 Parameter_Type
=> Current_Type
,
2586 In_Present
=> In_Present
(Current_Parameter
),
2587 Out_Present
=> Out_Present
(Current_Parameter
),
2589 New_Copy_Tree
(Expression
(Current_Parameter
))));
2591 -- For a regular formal parameter (that needs to be marshalled
2592 -- in the context of remote calls), set the Etype now, because
2593 -- marshalling processing might need it.
2595 if Is_Entity_Name
(Current_Type
) then
2596 Set_Etype
(New_Identifier
, Entity
(Current_Type
));
2598 -- Current_Type is an access definition, special processing
2599 -- (not requiring etype) will occur for marshalling.
2605 Next
(Current_Parameter
);
2609 case Nkind
(Spec
) is
2611 when N_Function_Specification | N_Access_Function_Definition
=>
2613 Make_Function_Specification
(Loc
,
2614 Defining_Unit_Name
=>
2615 Make_Defining_Identifier
(Loc
,
2616 Chars
=> Name_For_New_Spec
),
2617 Parameter_Specifications
=> Parameters
,
2618 Result_Definition
=>
2619 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
2621 when N_Procedure_Specification | N_Access_Procedure_Definition
=>
2623 Make_Procedure_Specification
(Loc
,
2624 Defining_Unit_Name
=>
2625 Make_Defining_Identifier
(Loc
,
2626 Chars
=> Name_For_New_Spec
),
2627 Parameter_Specifications
=> Parameters
);
2630 raise Program_Error
;
2632 end Copy_Specification
;
2634 -----------------------------
2635 -- Corresponding_Stub_Type --
2636 -----------------------------
2638 function Corresponding_Stub_Type
(RACW_Type
: Entity_Id
) return Entity_Id
is
2639 Desig
: constant Entity_Id
:=
2640 Etype
(Designated_Type
(RACW_Type
));
2641 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
2643 return Stub_Elements
.Stub_Type
;
2644 end Corresponding_Stub_Type
;
2646 ---------------------------
2647 -- Could_Be_Asynchronous --
2648 ---------------------------
2650 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean is
2651 Current_Parameter
: Node_Id
;
2654 if Present
(Parameter_Specifications
(Spec
)) then
2655 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2656 while Present
(Current_Parameter
) loop
2657 if Out_Present
(Current_Parameter
) then
2661 Next
(Current_Parameter
);
2666 end Could_Be_Asynchronous
;
2668 ---------------------------
2669 -- Declare_Create_NVList --
2670 ---------------------------
2672 procedure Declare_Create_NVList
2680 Make_Object_Declaration
(Loc
,
2681 Defining_Identifier
=> NVList
,
2682 Aliased_Present
=> False,
2683 Object_Definition
=>
2684 New_Occurrence_Of
(RTE
(RE_NVList_Ref
), Loc
)));
2687 Make_Procedure_Call_Statement
(Loc
,
2688 Name
=> New_Occurrence_Of
(RTE
(RE_NVList_Create
), Loc
),
2689 Parameter_Associations
=> New_List
(
2690 New_Occurrence_Of
(NVList
, Loc
))));
2691 end Declare_Create_NVList
;
2693 ---------------------------------------------
2694 -- Expand_All_Calls_Remote_Subprogram_Call --
2695 ---------------------------------------------
2697 procedure Expand_All_Calls_Remote_Subprogram_Call
(N
: Node_Id
) is
2698 Called_Subprogram
: constant Entity_Id
:= Entity
(Name
(N
));
2699 RCI_Package
: constant Entity_Id
:= Scope
(Called_Subprogram
);
2700 Loc
: constant Source_Ptr
:= Sloc
(N
);
2701 RCI_Locator
: Node_Id
;
2702 RCI_Cache
: Entity_Id
;
2703 Calling_Stubs
: Node_Id
;
2704 E_Calling_Stubs
: Entity_Id
;
2707 E_Calling_Stubs
:= RCI_Calling_Stubs_Table
.Get
(Called_Subprogram
);
2709 if E_Calling_Stubs
= Empty
then
2710 RCI_Cache
:= RCI_Locator_Table
.Get
(RCI_Package
);
2712 if RCI_Cache
= Empty
then
2715 (Loc
, Specification
(Unit_Declaration_Node
(RCI_Package
)));
2716 Prepend_To
(Current_Sem_Unit_Declarations
, RCI_Locator
);
2718 -- The RCI_Locator package is inserted at the top level in the
2719 -- current unit, and must appear in the proper scope, so that it
2720 -- is not prematurely removed by the GCC back-end.
2723 Scop
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
2726 if Ekind
(Scop
) = E_Package_Body
then
2727 Push_Scope
(Spec_Entity
(Scop
));
2729 elsif Ekind
(Scop
) = E_Subprogram_Body
then
2731 (Corresponding_Spec
(Unit_Declaration_Node
(Scop
)));
2737 Analyze
(RCI_Locator
);
2741 RCI_Cache
:= Defining_Unit_Name
(RCI_Locator
);
2744 RCI_Locator
:= Parent
(RCI_Cache
);
2747 Calling_Stubs
:= Build_Subprogram_Calling_Stubs
2748 (Vis_Decl
=> Parent
(Parent
(Called_Subprogram
)),
2750 Build_Subprogram_Id
(Loc
, Called_Subprogram
),
2751 Asynchronous
=> Nkind
(N
) = N_Procedure_Call_Statement
2753 Is_Asynchronous
(Called_Subprogram
),
2754 Locator
=> RCI_Cache
,
2755 New_Name
=> New_Internal_Name
('S'));
2756 Insert_After
(RCI_Locator
, Calling_Stubs
);
2757 Analyze
(Calling_Stubs
);
2758 E_Calling_Stubs
:= Defining_Unit_Name
(Specification
(Calling_Stubs
));
2761 Rewrite
(Name
(N
), New_Occurrence_Of
(E_Calling_Stubs
, Loc
));
2762 end Expand_All_Calls_Remote_Subprogram_Call
;
2764 ---------------------------------
2765 -- Expand_Calling_Stubs_Bodies --
2766 ---------------------------------
2768 procedure Expand_Calling_Stubs_Bodies
(Unit_Node
: Node_Id
) is
2769 Spec
: constant Node_Id
:= Specification
(Unit_Node
);
2770 Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
2772 Push_Scope
(Scope_Of_Spec
(Spec
));
2773 Add_Calling_Stubs_To_Declarations
2774 (Specification
(Unit_Node
), Decls
);
2776 end Expand_Calling_Stubs_Bodies
;
2778 -----------------------------------
2779 -- Expand_Receiving_Stubs_Bodies --
2780 -----------------------------------
2782 procedure Expand_Receiving_Stubs_Bodies
(Unit_Node
: Node_Id
) is
2785 Stubs_Decls
: List_Id
;
2786 Stubs_Stmts
: List_Id
;
2789 if Nkind
(Unit_Node
) = N_Package_Declaration
then
2790 Spec
:= Specification
(Unit_Node
);
2791 Decls
:= Private_Declarations
(Spec
);
2794 Decls
:= Visible_Declarations
(Spec
);
2797 Push_Scope
(Scope_Of_Spec
(Spec
));
2798 Specific_Add_Receiving_Stubs_To_Declarations
(Spec
, Decls
, Decls
);
2802 Package_Specification_Of_Scope
(Corresponding_Spec
(Unit_Node
));
2803 Decls
:= Declarations
(Unit_Node
);
2805 Push_Scope
(Scope_Of_Spec
(Unit_Node
));
2806 Stubs_Decls
:= New_List
;
2807 Stubs_Stmts
:= New_List
;
2808 Specific_Add_Receiving_Stubs_To_Declarations
2809 (Spec
, Stubs_Decls
, Stubs_Stmts
);
2811 Insert_List_Before
(First
(Decls
), Stubs_Decls
);
2814 HSS_Stmts
: constant List_Id
:=
2815 Statements
(Handled_Statement_Sequence
(Unit_Node
));
2817 First_HSS_Stmt
: constant Node_Id
:= First
(HSS_Stmts
);
2820 if No
(First_HSS_Stmt
) then
2821 Append_List_To
(HSS_Stmts
, Stubs_Stmts
);
2823 Insert_List_Before
(First_HSS_Stmt
, Stubs_Stmts
);
2829 end Expand_Receiving_Stubs_Bodies
;
2831 --------------------
2832 -- GARLIC_Support --
2833 --------------------
2835 package body GARLIC_Support
is
2837 -- Local subprograms
2839 procedure Add_RACW_Read_Attribute
2840 (RACW_Type
: Entity_Id
;
2841 Stub_Type
: Entity_Id
;
2842 Stub_Type_Access
: Entity_Id
;
2843 Body_Decls
: List_Id
);
2844 -- Add Read attribute for the RACW type. The declaration and attribute
2845 -- definition clauses are inserted right after the declaration of
2846 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2847 -- appended to it (case where the RACW declaration is in the main unit).
2849 procedure Add_RACW_Write_Attribute
2850 (RACW_Type
: Entity_Id
;
2851 Stub_Type
: Entity_Id
;
2852 Stub_Type_Access
: Entity_Id
;
2853 RPC_Receiver
: Node_Id
;
2854 Body_Decls
: List_Id
);
2855 -- Same as above for the Write attribute
2857 function Stream_Parameter
return Node_Id
;
2858 function Result
return Node_Id
;
2859 function Object
return Node_Id
renames Result
;
2860 -- Functions to create occurrences of the formal parameter names of the
2861 -- 'Read and 'Write attributes.
2864 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2865 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2867 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
2868 -- Add a subprogram body for RAS Access TSS
2870 -------------------------------------
2871 -- Add_Obj_RPC_Receiver_Completion --
2872 -------------------------------------
2874 procedure Add_Obj_RPC_Receiver_Completion
2877 RPC_Receiver
: Entity_Id
;
2878 Stub_Elements
: Stub_Structure
)
2881 -- The RPC receiver body should not be the completion of the
2882 -- declaration recorded in the stub structure, because then the
2883 -- occurrences of the formal parameters within the body should refer
2884 -- to the entities from the declaration, not from the completion, to
2885 -- which we do not have easy access. Instead, the RPC receiver body
2886 -- acts as its own declaration, and the RPC receiver declaration is
2887 -- completed by a renaming-as-body.
2890 Make_Subprogram_Renaming_Declaration
(Loc
,
2892 Copy_Specification
(Loc
,
2893 Specification
(Stub_Elements
.RPC_Receiver_Decl
)),
2894 Name
=> New_Occurrence_Of
(RPC_Receiver
, Loc
)));
2895 end Add_Obj_RPC_Receiver_Completion
;
2897 -----------------------
2898 -- Add_RACW_Features --
2899 -----------------------
2901 procedure Add_RACW_Features
2902 (RACW_Type
: Entity_Id
;
2903 Stub_Type
: Entity_Id
;
2904 Stub_Type_Access
: Entity_Id
;
2905 RPC_Receiver_Decl
: Node_Id
;
2906 Body_Decls
: List_Id
)
2908 RPC_Receiver
: Node_Id
;
2909 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
2912 Loc
:= Sloc
(RACW_Type
);
2916 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2917 -- of the corresponding distributed object type. We retrieve its
2918 -- address from the local proxy object.
2920 RPC_Receiver
:= Make_Selected_Component
(Loc
,
2922 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
), Object
),
2923 Selector_Name
=> Make_Identifier
(Loc
, Name_Receiver
));
2926 RPC_Receiver
:= Make_Attribute_Reference
(Loc
,
2927 Prefix
=> New_Occurrence_Of
(
2928 Defining_Unit_Name
(Specification
(RPC_Receiver_Decl
)), Loc
),
2929 Attribute_Name
=> Name_Address
);
2932 Add_RACW_Write_Attribute
2939 Add_RACW_Read_Attribute
2944 end Add_RACW_Features
;
2946 -----------------------------
2947 -- Add_RACW_Read_Attribute --
2948 -----------------------------
2950 procedure Add_RACW_Read_Attribute
2951 (RACW_Type
: Entity_Id
;
2952 Stub_Type
: Entity_Id
;
2953 Stub_Type_Access
: Entity_Id
;
2954 Body_Decls
: List_Id
)
2956 Proc_Decl
: Node_Id
;
2957 Attr_Decl
: Node_Id
;
2959 Body_Node
: Node_Id
;
2961 Statements
: constant List_Id
:= New_List
;
2963 Local_Statements
: List_Id
;
2964 Remote_Statements
: List_Id
;
2965 -- Various parts of the procedure
2967 Pnam
: constant Entity_Id
:=
2968 Make_Defining_Identifier
2969 (Loc
, New_Internal_Name
('R'));
2970 Asynchronous_Flag
: constant Entity_Id
:=
2971 Asynchronous_Flags_Table
.Get
(RACW_Type
);
2972 pragma Assert
(Present
(Asynchronous_Flag
));
2974 -- Prepare local identifiers
2976 Source_Partition
: Entity_Id
;
2977 Source_Receiver
: Entity_Id
;
2978 Source_Address
: Entity_Id
;
2979 Local_Stub
: Entity_Id
;
2980 Stubbed_Result
: Entity_Id
;
2982 -- Start of processing for Add_RACW_Read_Attribute
2985 Build_Stream_Procedure
(Loc
,
2986 RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> True);
2987 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
2988 Copy_Specification
(Loc
, Specification
(Body_Node
)));
2991 Make_Attribute_Definition_Clause
(Loc
,
2992 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
2996 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
2998 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
2999 Insert_After
(Proc_Decl
, Attr_Decl
);
3001 if No
(Body_Decls
) then
3003 -- Case of processing an RACW type from another unit than the
3004 -- main one: do not generate a body.
3009 -- Prepare local identifiers
3012 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
3014 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
3016 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
3018 Make_Defining_Identifier
(Loc
, New_Internal_Name
('L'));
3020 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
3022 -- Generate object declarations
3025 Make_Object_Declaration
(Loc
,
3026 Defining_Identifier
=> Source_Partition
,
3027 Object_Definition
=>
3028 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
)),
3030 Make_Object_Declaration
(Loc
,
3031 Defining_Identifier
=> Source_Receiver
,
3032 Object_Definition
=>
3033 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3035 Make_Object_Declaration
(Loc
,
3036 Defining_Identifier
=> Source_Address
,
3037 Object_Definition
=>
3038 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3040 Make_Object_Declaration
(Loc
,
3041 Defining_Identifier
=> Local_Stub
,
3042 Aliased_Present
=> True,
3043 Object_Definition
=> New_Occurrence_Of
(Stub_Type
, Loc
)),
3045 Make_Object_Declaration
(Loc
,
3046 Defining_Identifier
=> Stubbed_Result
,
3047 Object_Definition
=>
3048 New_Occurrence_Of
(Stub_Type_Access
, Loc
),
3050 Make_Attribute_Reference
(Loc
,
3052 New_Occurrence_Of
(Local_Stub
, Loc
),
3054 Name_Unchecked_Access
)));
3056 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3058 Append_List_To
(Statements
, New_List
(
3059 Make_Attribute_Reference
(Loc
,
3061 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3062 Attribute_Name
=> Name_Read
,
3063 Expressions
=> New_List
(
3065 New_Occurrence_Of
(Source_Partition
, Loc
))),
3067 Make_Attribute_Reference
(Loc
,
3069 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3072 Expressions
=> New_List
(
3074 New_Occurrence_Of
(Source_Receiver
, Loc
))),
3076 Make_Attribute_Reference
(Loc
,
3078 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3081 Expressions
=> New_List
(
3083 New_Occurrence_Of
(Source_Address
, Loc
)))));
3085 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3087 Set_Etype
(Stubbed_Result
, Stub_Type_Access
);
3089 -- If the Address is Null_Address, then return a null object, unless
3090 -- RACW_Type is null-excluding, in which case inconditionally raise
3091 -- CONSTRAINT_ERROR instead.
3094 Zero_Statements
: List_Id
;
3095 -- Statements executed when a zero value is received
3098 if Can_Never_Be_Null
(RACW_Type
) then
3099 Zero_Statements
:= New_List
(
3100 Make_Raise_Constraint_Error
(Loc
,
3101 Reason
=> CE_Null_Not_Allowed
));
3103 Zero_Statements
:= New_List
(
3104 Make_Assignment_Statement
(Loc
,
3106 Expression
=> Make_Null
(Loc
)),
3107 Make_Simple_Return_Statement
(Loc
));
3110 Append_To
(Statements
,
3111 Make_Implicit_If_Statement
(RACW_Type
,
3114 Left_Opnd
=> New_Occurrence_Of
(Source_Address
, Loc
),
3115 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
3116 Then_Statements
=> Zero_Statements
));
3119 -- If the RACW denotes an object created on the current partition,
3120 -- Local_Statements will be executed. The real object will be used.
3122 Local_Statements
:= New_List
(
3123 Make_Assignment_Statement
(Loc
,
3126 Unchecked_Convert_To
(RACW_Type
,
3127 OK_Convert_To
(RTE
(RE_Address
),
3128 New_Occurrence_Of
(Source_Address
, Loc
)))));
3130 -- If the object is located on another partition, then a stub object
3131 -- will be created with all the information needed to rebuild the
3132 -- real object at the other end.
3134 Remote_Statements
:= New_List
(
3136 Make_Assignment_Statement
(Loc
,
3137 Name
=> Make_Selected_Component
(Loc
,
3138 Prefix
=> Stubbed_Result
,
3139 Selector_Name
=> Name_Origin
),
3141 New_Occurrence_Of
(Source_Partition
, Loc
)),
3143 Make_Assignment_Statement
(Loc
,
3144 Name
=> Make_Selected_Component
(Loc
,
3145 Prefix
=> Stubbed_Result
,
3146 Selector_Name
=> Name_Receiver
),
3148 New_Occurrence_Of
(Source_Receiver
, Loc
)),
3150 Make_Assignment_Statement
(Loc
,
3151 Name
=> Make_Selected_Component
(Loc
,
3152 Prefix
=> Stubbed_Result
,
3153 Selector_Name
=> Name_Addr
),
3155 New_Occurrence_Of
(Source_Address
, Loc
)));
3157 Append_To
(Remote_Statements
,
3158 Make_Assignment_Statement
(Loc
,
3159 Name
=> Make_Selected_Component
(Loc
,
3160 Prefix
=> Stubbed_Result
,
3161 Selector_Name
=> Name_Asynchronous
),
3163 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)));
3165 Append_List_To
(Remote_Statements
,
3166 Build_Get_Unique_RP_Call
(Loc
, Stubbed_Result
, Stub_Type
));
3167 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3168 -- set on the stub type if, and only if, the RACW type has a pragma
3169 -- Asynchronous. This is incorrect for RACWs that implement RAS
3170 -- types, because in that case the /designated subprogram/ (not the
3171 -- type) might be asynchronous, and that causes the stub to need to
3172 -- be asynchronous too. A solution is to transport a RAS as a struct
3173 -- containing a RACW and an asynchronous flag, and to properly alter
3174 -- the Asynchronous component in the stub type in the RAS's Input
3177 Append_To
(Remote_Statements
,
3178 Make_Assignment_Statement
(Loc
,
3180 Expression
=> Unchecked_Convert_To
(RACW_Type
,
3181 New_Occurrence_Of
(Stubbed_Result
, Loc
))));
3183 -- Distinguish between the local and remote cases, and execute the
3184 -- appropriate piece of code.
3186 Append_To
(Statements
,
3187 Make_Implicit_If_Statement
(RACW_Type
,
3191 Make_Function_Call
(Loc
,
3192 Name
=> New_Occurrence_Of
(
3193 RTE
(RE_Get_Local_Partition_Id
), Loc
)),
3194 Right_Opnd
=> New_Occurrence_Of
(Source_Partition
, Loc
)),
3195 Then_Statements
=> Local_Statements
,
3196 Else_Statements
=> Remote_Statements
));
3198 Set_Declarations
(Body_Node
, Decls
);
3199 Append_To
(Body_Decls
, Body_Node
);
3200 end Add_RACW_Read_Attribute
;
3202 ------------------------------
3203 -- Add_RACW_Write_Attribute --
3204 ------------------------------
3206 procedure Add_RACW_Write_Attribute
3207 (RACW_Type
: Entity_Id
;
3208 Stub_Type
: Entity_Id
;
3209 Stub_Type_Access
: Entity_Id
;
3210 RPC_Receiver
: Node_Id
;
3211 Body_Decls
: List_Id
)
3213 Body_Node
: Node_Id
;
3214 Proc_Decl
: Node_Id
;
3215 Attr_Decl
: Node_Id
;
3217 Statements
: constant List_Id
:= New_List
;
3218 Local_Statements
: List_Id
;
3219 Remote_Statements
: List_Id
;
3220 Null_Statements
: List_Id
;
3222 Pnam
: constant Entity_Id
:=
3223 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
3226 Build_Stream_Procedure
3227 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> False);
3229 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
3230 Copy_Specification
(Loc
, Specification
(Body_Node
)));
3233 Make_Attribute_Definition_Clause
(Loc
,
3234 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
3235 Chars
=> Name_Write
,
3238 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
3240 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
3241 Insert_After
(Proc_Decl
, Attr_Decl
);
3243 if No
(Body_Decls
) then
3247 -- Build the code fragment corresponding to the marshalling of a
3250 Local_Statements
:= New_List
(
3252 Pack_Entity_Into_Stream_Access
(Loc
,
3253 Stream
=> Stream_Parameter
,
3254 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
3256 Pack_Node_Into_Stream_Access
(Loc
,
3257 Stream
=> Stream_Parameter
,
3258 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
), RPC_Receiver
),
3259 Etyp
=> RTE
(RE_Unsigned_64
)),
3261 Pack_Node_Into_Stream_Access
(Loc
,
3262 Stream
=> Stream_Parameter
,
3263 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
),
3264 Make_Attribute_Reference
(Loc
,
3266 Make_Explicit_Dereference
(Loc
,
3268 Attribute_Name
=> Name_Address
)),
3269 Etyp
=> RTE
(RE_Unsigned_64
)));
3271 -- Build the code fragment corresponding to the marshalling of
3274 Remote_Statements
:= New_List
(
3275 Pack_Node_Into_Stream_Access
(Loc
,
3276 Stream
=> Stream_Parameter
,
3278 Make_Selected_Component
(Loc
,
3280 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3281 Selector_Name
=> Make_Identifier
(Loc
, Name_Origin
)),
3282 Etyp
=> RTE
(RE_Partition_ID
)),
3284 Pack_Node_Into_Stream_Access
(Loc
,
3285 Stream
=> Stream_Parameter
,
3287 Make_Selected_Component
(Loc
,
3289 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3290 Selector_Name
=> Make_Identifier
(Loc
, Name_Receiver
)),
3291 Etyp
=> RTE
(RE_Unsigned_64
)),
3293 Pack_Node_Into_Stream_Access
(Loc
,
3294 Stream
=> Stream_Parameter
,
3296 Make_Selected_Component
(Loc
,
3298 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3299 Selector_Name
=> Make_Identifier
(Loc
, Name_Addr
)),
3300 Etyp
=> RTE
(RE_Unsigned_64
)));
3302 -- Build code fragment corresponding to marshalling of a null object
3304 Null_Statements
:= New_List
(
3306 Pack_Entity_Into_Stream_Access
(Loc
,
3307 Stream
=> Stream_Parameter
,
3308 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
3310 Pack_Node_Into_Stream_Access
(Loc
,
3311 Stream
=> Stream_Parameter
,
3312 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
), RPC_Receiver
),
3313 Etyp
=> RTE
(RE_Unsigned_64
)),
3315 Pack_Node_Into_Stream_Access
(Loc
,
3316 Stream
=> Stream_Parameter
,
3317 Object
=> Make_Integer_Literal
(Loc
, Uint_0
),
3318 Etyp
=> RTE
(RE_Unsigned_64
)));
3320 Append_To
(Statements
,
3321 Make_Implicit_If_Statement
(RACW_Type
,
3324 Left_Opnd
=> Object
,
3325 Right_Opnd
=> Make_Null
(Loc
)),
3327 Then_Statements
=> Null_Statements
,
3329 Elsif_Parts
=> New_List
(
3330 Make_Elsif_Part
(Loc
,
3334 Make_Attribute_Reference
(Loc
,
3336 Attribute_Name
=> Name_Tag
),
3339 Make_Attribute_Reference
(Loc
,
3340 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
3341 Attribute_Name
=> Name_Tag
)),
3342 Then_Statements
=> Remote_Statements
)),
3343 Else_Statements
=> Local_Statements
));
3345 Append_To
(Body_Decls
, Body_Node
);
3346 end Add_RACW_Write_Attribute
;
3348 ------------------------
3349 -- Add_RAS_Access_TSS --
3350 ------------------------
3352 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
3353 Loc
: constant Source_Ptr
:= Sloc
(N
);
3355 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
3356 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
3357 -- Ras_Type is the access to subprogram type while Fat_Type is the
3358 -- corresponding record type.
3360 RACW_Type
: constant Entity_Id
:=
3361 Underlying_RACW_Type
(Ras_Type
);
3362 Desig
: constant Entity_Id
:=
3363 Etype
(Designated_Type
(RACW_Type
));
3365 Stub_Elements
: constant Stub_Structure
:=
3366 Stubs_Table
.Get
(Desig
);
3367 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
3369 Proc
: constant Entity_Id
:=
3370 Make_Defining_Identifier
(Loc
,
3371 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
3373 Proc_Spec
: Node_Id
;
3375 -- Formal parameters
3377 Package_Name
: constant Entity_Id
:=
3378 Make_Defining_Identifier
(Loc
,
3382 Subp_Id
: constant Entity_Id
:=
3383 Make_Defining_Identifier
(Loc
,
3385 -- Target subprogram
3387 Asynch_P
: constant Entity_Id
:=
3388 Make_Defining_Identifier
(Loc
,
3389 Chars
=> Name_Asynchronous
);
3390 -- Is the procedure to which the 'Access applies asynchronous?
3392 All_Calls_Remote
: constant Entity_Id
:=
3393 Make_Defining_Identifier
(Loc
,
3394 Chars
=> Name_All_Calls_Remote
);
3395 -- True if an All_Calls_Remote pragma applies to the RCI unit
3396 -- that contains the subprogram.
3398 -- Common local variables
3400 Proc_Decls
: List_Id
;
3401 Proc_Statements
: List_Id
;
3403 Origin
: constant Entity_Id
:=
3404 Make_Defining_Identifier
(Loc
,
3405 Chars
=> New_Internal_Name
('P'));
3407 -- Additional local variables for the local case
3409 Proxy_Addr
: constant Entity_Id
:=
3410 Make_Defining_Identifier
(Loc
,
3411 Chars
=> New_Internal_Name
('P'));
3413 -- Additional local variables for the remote case
3415 Local_Stub
: constant Entity_Id
:=
3416 Make_Defining_Identifier
(Loc
,
3417 Chars
=> New_Internal_Name
('L'));
3419 Stub_Ptr
: constant Entity_Id
:=
3420 Make_Defining_Identifier
(Loc
,
3421 Chars
=> New_Internal_Name
('S'));
3424 (Field_Name
: Name_Id
;
3425 Value
: Node_Id
) return Node_Id
;
3426 -- Construct an assignment that sets the named component in the
3434 (Field_Name
: Name_Id
;
3435 Value
: Node_Id
) return Node_Id
3439 Make_Assignment_Statement
(Loc
,
3441 Make_Selected_Component
(Loc
,
3443 Selector_Name
=> Field_Name
),
3444 Expression
=> Value
);
3447 -- Start of processing for Add_RAS_Access_TSS
3450 Proc_Decls
:= New_List
(
3452 -- Common declarations
3454 Make_Object_Declaration
(Loc
,
3455 Defining_Identifier
=> Origin
,
3456 Constant_Present
=> True,
3457 Object_Definition
=>
3458 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3460 Make_Function_Call
(Loc
,
3462 New_Occurrence_Of
(RTE
(RE_Get_Active_Partition_Id
), Loc
),
3463 Parameter_Associations
=> New_List
(
3464 New_Occurrence_Of
(Package_Name
, Loc
)))),
3466 -- Declaration use only in the local case: proxy address
3468 Make_Object_Declaration
(Loc
,
3469 Defining_Identifier
=> Proxy_Addr
,
3470 Object_Definition
=>
3471 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3473 -- Declarations used only in the remote case: stub object and
3476 Make_Object_Declaration
(Loc
,
3477 Defining_Identifier
=> Local_Stub
,
3478 Aliased_Present
=> True,
3479 Object_Definition
=>
3480 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
3482 Make_Object_Declaration
(Loc
,
3483 Defining_Identifier
=>
3485 Object_Definition
=>
3486 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
3488 Make_Attribute_Reference
(Loc
,
3489 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
3490 Attribute_Name
=> Name_Unchecked_Access
)));
3492 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
3494 -- Build_Get_Unique_RP_Call needs above information
3496 -- Note: Here we assume that the Fat_Type is a record
3497 -- containing just a pointer to a proxy or stub object.
3499 Proc_Statements
:= New_List
(
3503 -- Get_RAS_Info (Pkg, Subp, PA);
3504 -- if Origin = Local_Partition_Id
3505 -- and then not All_Calls_Remote
3507 -- return Fat_Type!(PA);
3510 Make_Procedure_Call_Statement
(Loc
,
3511 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
3512 Parameter_Associations
=> New_List
(
3513 New_Occurrence_Of
(Package_Name
, Loc
),
3514 New_Occurrence_Of
(Subp_Id
, Loc
),
3515 New_Occurrence_Of
(Proxy_Addr
, Loc
))),
3517 Make_Implicit_If_Statement
(N
,
3523 New_Occurrence_Of
(Origin
, Loc
),
3525 Make_Function_Call
(Loc
,
3527 RTE
(RE_Get_Local_Partition_Id
), Loc
))),
3531 New_Occurrence_Of
(All_Calls_Remote
, Loc
))),
3533 Then_Statements
=> New_List
(
3534 Make_Simple_Return_Statement
(Loc
,
3535 Unchecked_Convert_To
(Fat_Type
,
3536 OK_Convert_To
(RTE
(RE_Address
),
3537 New_Occurrence_Of
(Proxy_Addr
, Loc
)))))),
3539 Set_Field
(Name_Origin
,
3540 New_Occurrence_Of
(Origin
, Loc
)),
3542 Set_Field
(Name_Receiver
,
3543 Make_Function_Call
(Loc
,
3545 New_Occurrence_Of
(RTE
(RE_Get_RCI_Package_Receiver
), Loc
),
3546 Parameter_Associations
=> New_List
(
3547 New_Occurrence_Of
(Package_Name
, Loc
)))),
3549 Set_Field
(Name_Addr
, New_Occurrence_Of
(Proxy_Addr
, Loc
)),
3551 -- E.4.1(9) A remote call is asynchronous if it is a call to
3552 -- a procedure or a call through a value of an access-to-procedure
3553 -- type to which a pragma Asynchronous applies.
3555 -- Asynch_P is true when the procedure is asynchronous;
3556 -- Asynch_T is true when the type is asynchronous.
3558 Set_Field
(Name_Asynchronous
,
3560 New_Occurrence_Of
(Asynch_P
, Loc
),
3561 New_Occurrence_Of
(Boolean_Literals
(
3562 Is_Asynchronous
(Ras_Type
)), Loc
))));
3564 Append_List_To
(Proc_Statements
,
3565 Build_Get_Unique_RP_Call
3566 (Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
3568 -- Return the newly created value
3570 Append_To
(Proc_Statements
,
3571 Make_Simple_Return_Statement
(Loc
,
3573 Unchecked_Convert_To
(Fat_Type
,
3574 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
3577 Make_Function_Specification
(Loc
,
3578 Defining_Unit_Name
=> Proc
,
3579 Parameter_Specifications
=> New_List
(
3580 Make_Parameter_Specification
(Loc
,
3581 Defining_Identifier
=> Package_Name
,
3583 New_Occurrence_Of
(Standard_String
, Loc
)),
3585 Make_Parameter_Specification
(Loc
,
3586 Defining_Identifier
=> Subp_Id
,
3588 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
)),
3590 Make_Parameter_Specification
(Loc
,
3591 Defining_Identifier
=> Asynch_P
,
3593 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3595 Make_Parameter_Specification
(Loc
,
3596 Defining_Identifier
=> All_Calls_Remote
,
3598 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
3600 Result_Definition
=>
3601 New_Occurrence_Of
(Fat_Type
, Loc
));
3603 -- Set the kind and return type of the function to prevent
3604 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3606 Set_Ekind
(Proc
, E_Function
);
3607 Set_Etype
(Proc
, Fat_Type
);
3610 Make_Subprogram_Body
(Loc
,
3611 Specification
=> Proc_Spec
,
3612 Declarations
=> Proc_Decls
,
3613 Handled_Statement_Sequence
=>
3614 Make_Handled_Sequence_Of_Statements
(Loc
,
3615 Statements
=> Proc_Statements
)));
3617 Set_TSS
(Fat_Type
, Proc
);
3618 end Add_RAS_Access_TSS
;
3620 -----------------------
3621 -- Add_RAST_Features --
3622 -----------------------
3624 procedure Add_RAST_Features
3625 (Vis_Decl
: Node_Id
;
3626 RAS_Type
: Entity_Id
)
3628 pragma Warnings
(Off
);
3629 pragma Unreferenced
(RAS_Type
);
3630 pragma Warnings
(On
);
3632 Add_RAS_Access_TSS
(Vis_Decl
);
3633 end Add_RAST_Features
;
3635 -----------------------------------------
3636 -- Add_Receiving_Stubs_To_Declarations --
3637 -----------------------------------------
3639 procedure Add_Receiving_Stubs_To_Declarations
3640 (Pkg_Spec
: Node_Id
;
3644 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
3646 Request_Parameter
: Node_Id
;
3648 Pkg_RPC_Receiver
: constant Entity_Id
:=
3649 Make_Defining_Identifier
(Loc
,
3650 New_Internal_Name
('H'));
3651 Pkg_RPC_Receiver_Statements
: List_Id
;
3652 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
3653 Pkg_RPC_Receiver_Body
: Node_Id
;
3654 -- A Pkg_RPC_Receiver is built to decode the request
3656 Lookup_RAS_Info
: constant Entity_Id
:=
3657 Make_Defining_Identifier
(Loc
,
3658 Chars
=> New_Internal_Name
('R'));
3659 -- A remote subprogram is created to allow peers to look up
3660 -- RAS information using subprogram ids.
3662 Subp_Id
: Entity_Id
;
3663 Subp_Index
: Entity_Id
;
3664 -- Subprogram_Id as read from the incoming stream
3666 Current_Declaration
: Node_Id
;
3667 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
3668 Current_Stubs
: Node_Id
;
3670 Subp_Info_Array
: constant Entity_Id
:=
3671 Make_Defining_Identifier
(Loc
,
3672 Chars
=> New_Internal_Name
('I'));
3674 Subp_Info_List
: constant List_Id
:= New_List
;
3676 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
3678 All_Calls_Remote_E
: Entity_Id
;
3679 Proxy_Object_Addr
: Entity_Id
;
3681 procedure Append_Stubs_To
3682 (RPC_Receiver_Cases
: List_Id
;
3684 Subprogram_Number
: Int
);
3685 -- Add one case to the specified RPC receiver case list
3686 -- associating Subprogram_Number with the subprogram declared
3687 -- by Declaration, for which we have receiving stubs in Stubs.
3689 ---------------------
3690 -- Append_Stubs_To --
3691 ---------------------
3693 procedure Append_Stubs_To
3694 (RPC_Receiver_Cases
: List_Id
;
3696 Subprogram_Number
: Int
)
3699 Append_To
(RPC_Receiver_Cases
,
3700 Make_Case_Statement_Alternative
(Loc
,
3702 New_List
(Make_Integer_Literal
(Loc
, Subprogram_Number
)),
3705 Make_Procedure_Call_Statement
(Loc
,
3707 New_Occurrence_Of
(Defining_Entity
(Stubs
), Loc
),
3708 Parameter_Associations
=> New_List
(
3709 New_Occurrence_Of
(Request_Parameter
, Loc
))))));
3710 end Append_Stubs_To
;
3712 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3715 -- Building receiving stubs consist in several operations:
3717 -- - a package RPC receiver must be built. This subprogram
3718 -- will get a Subprogram_Id from the incoming stream
3719 -- and will dispatch the call to the right subprogram;
3721 -- - a receiving stub for each subprogram visible in the package
3722 -- spec. This stub will read all the parameters from the stream,
3723 -- and put the result as well as the exception occurrence in the
3726 -- - a dummy package with an empty spec and a body made of an
3727 -- elaboration part, whose job is to register the receiving
3728 -- part of this RCI package on the name server. This is done
3729 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3731 Build_RPC_Receiver_Body
(
3732 RPC_Receiver
=> Pkg_RPC_Receiver
,
3733 Request
=> Request_Parameter
,
3735 Subp_Index
=> Subp_Index
,
3736 Stmts
=> Pkg_RPC_Receiver_Statements
,
3737 Decl
=> Pkg_RPC_Receiver_Body
);
3738 pragma Assert
(Subp_Id
= Subp_Index
);
3740 -- A null subp_id denotes a call through a RAS, in which case the
3741 -- next Uint_64 element in the stream is the address of the local
3742 -- proxy object, from which we can retrieve the actual subprogram id.
3744 Append_To
(Pkg_RPC_Receiver_Statements
,
3745 Make_Implicit_If_Statement
(Pkg_Spec
,
3748 New_Occurrence_Of
(Subp_Id
, Loc
),
3749 Make_Integer_Literal
(Loc
, 0)),
3751 Then_Statements
=> New_List
(
3752 Make_Assignment_Statement
(Loc
,
3754 New_Occurrence_Of
(Subp_Id
, Loc
),
3757 Make_Selected_Component
(Loc
,
3759 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
3760 OK_Convert_To
(RTE
(RE_Address
),
3761 Make_Attribute_Reference
(Loc
,
3763 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3766 Expressions
=> New_List
(
3767 Make_Selected_Component
(Loc
,
3768 Prefix
=> Request_Parameter
,
3769 Selector_Name
=> Name_Params
))))),
3772 Make_Identifier
(Loc
, Name_Subp_Id
))))));
3774 -- Build a subprogram for RAS information lookups
3776 Current_Declaration
:=
3777 Make_Subprogram_Declaration
(Loc
,
3779 Make_Function_Specification
(Loc
,
3780 Defining_Unit_Name
=>
3782 Parameter_Specifications
=> New_List
(
3783 Make_Parameter_Specification
(Loc
,
3784 Defining_Identifier
=>
3785 Make_Defining_Identifier
(Loc
, Name_Subp_Id
),
3789 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))),
3790 Result_Definition
=>
3791 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)));
3793 Append_To
(Decls
, Current_Declaration
);
3794 Analyze
(Current_Declaration
);
3796 Current_Stubs
:= Build_Subprogram_Receiving_Stubs
3797 (Vis_Decl
=> Current_Declaration
,
3798 Asynchronous
=> False);
3799 Append_To
(Decls
, Current_Stubs
);
3800 Analyze
(Current_Stubs
);
3802 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3805 Subprogram_Number
=> 1);
3807 -- For each subprogram, the receiving stub will be built and a
3808 -- case statement will be made on the Subprogram_Id to dispatch
3809 -- to the right subprogram.
3811 All_Calls_Remote_E
:=
3813 (Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
3815 Overload_Counter_Table
.Reset
;
3817 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
3818 while Present
(Current_Declaration
) loop
3819 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
3820 and then Comes_From_Source
(Current_Declaration
)
3823 Loc
: constant Source_Ptr
:= Sloc
(Current_Declaration
);
3824 -- While specifically processing Current_Declaration, use
3825 -- its Sloc as the location of all generated nodes.
3827 Subp_Def
: constant Entity_Id
:=
3829 (Specification
(Current_Declaration
));
3831 Subp_Val
: String_Id
;
3832 pragma Warnings
(Off
, Subp_Val
);
3835 -- Build receiving stub
3838 Build_Subprogram_Receiving_Stubs
3839 (Vis_Decl
=> Current_Declaration
,
3841 Nkind
(Specification
(Current_Declaration
)) =
3842 N_Procedure_Specification
3843 and then Is_Asynchronous
(Subp_Def
));
3845 Append_To
(Decls
, Current_Stubs
);
3846 Analyze
(Current_Stubs
);
3850 Add_RAS_Proxy_And_Analyze
(Decls
,
3851 Vis_Decl
=> Current_Declaration
,
3852 All_Calls_Remote_E
=> All_Calls_Remote_E
,
3853 Proxy_Object_Addr
=> Proxy_Object_Addr
);
3855 -- Compute distribution identifier
3857 Assign_Subprogram_Identifier
3859 Current_Subprogram_Number
,
3863 (Current_Subprogram_Number
= Get_Subprogram_Id
(Subp_Def
));
3865 -- Add subprogram descriptor (RCI_Subp_Info) to the
3866 -- subprograms table for this receiver. The aggregate
3867 -- below must be kept consistent with the declaration
3868 -- of type RCI_Subp_Info in System.Partition_Interface.
3870 Append_To
(Subp_Info_List
,
3871 Make_Component_Association
(Loc
,
3872 Choices
=> New_List
(
3873 Make_Integer_Literal
(Loc
,
3874 Current_Subprogram_Number
)),
3877 Make_Aggregate
(Loc
,
3878 Component_Associations
=> New_List
(
3879 Make_Component_Association
(Loc
,
3880 Choices
=> New_List
(
3881 Make_Identifier
(Loc
, Name_Addr
)),
3884 Proxy_Object_Addr
, Loc
))))));
3886 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3887 Stubs
=> Current_Stubs
,
3888 Subprogram_Number
=> Current_Subprogram_Number
);
3891 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
3894 Next
(Current_Declaration
);
3897 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3898 -- rather than raising an exception since we do not want someone
3899 -- to crash a remote partition by sending invalid subprogram ids.
3900 -- This is consistent with the other parts of the case statement
3901 -- since even in presence of incorrect parameters in the stream,
3902 -- every exception will be caught and (if the subprogram is not an
3903 -- APC) put into the result stream and sent away.
3905 Append_To
(Pkg_RPC_Receiver_Cases
,
3906 Make_Case_Statement_Alternative
(Loc
,
3907 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
3908 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
3910 Append_To
(Pkg_RPC_Receiver_Statements
,
3911 Make_Case_Statement
(Loc
,
3912 Expression
=> New_Occurrence_Of
(Subp_Id
, Loc
),
3913 Alternatives
=> Pkg_RPC_Receiver_Cases
));
3916 Make_Object_Declaration
(Loc
,
3917 Defining_Identifier
=> Subp_Info_Array
,
3918 Constant_Present
=> True,
3919 Aliased_Present
=> True,
3920 Object_Definition
=>
3921 Make_Subtype_Indication
(Loc
,
3923 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
3925 Make_Index_Or_Discriminant_Constraint
(Loc
,
3928 Low_Bound
=> Make_Integer_Literal
(Loc
,
3929 First_RCI_Subprogram_Id
),
3931 Make_Integer_Literal
(Loc
,
3933 First_RCI_Subprogram_Id
3934 + List_Length
(Subp_Info_List
) - 1)))))));
3936 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
3937 -- has zero length, and the declaration is for an empty array, in
3938 -- which case no initialization aggregate must be generated.
3940 if Present
(First
(Subp_Info_List
)) then
3941 Set_Expression
(Last
(Decls
),
3942 Make_Aggregate
(Loc
,
3943 Component_Associations
=> Subp_Info_List
));
3945 -- No initialization provided: remove CONSTANT so that the
3946 -- declaration is not an incomplete deferred constant.
3949 Set_Constant_Present
(Last
(Decls
), False);
3952 Analyze
(Last
(Decls
));
3955 Subp_Info_Addr
: Node_Id
;
3956 -- Return statement for Lookup_RAS_Info: address of the subprogram
3957 -- information record for the requested subprogram id.
3960 if Present
(First
(Subp_Info_List
)) then
3962 Make_Selected_Component
(Loc
,
3964 Make_Indexed_Component
(Loc
,
3965 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3966 Expressions
=> New_List
(
3967 Convert_To
(Standard_Integer
,
3968 Make_Identifier
(Loc
, Name_Subp_Id
)))),
3969 Selector_Name
=> Make_Identifier
(Loc
, Name_Addr
));
3971 -- Case of no visible subprogram: just raise Constraint_Error, we
3972 -- know for sure we got junk from a remote partition.
3976 Make_Raise_Constraint_Error
(Loc
,
3977 Reason
=> CE_Range_Check_Failed
);
3978 Set_Etype
(Subp_Info_Addr
, RTE
(RE_Unsigned_64
));
3982 Make_Subprogram_Body
(Loc
,
3984 Copy_Specification
(Loc
, Parent
(Lookup_RAS_Info
)),
3985 Declarations
=> No_List
,
3986 Handled_Statement_Sequence
=>
3987 Make_Handled_Sequence_Of_Statements
(Loc
,
3988 Statements
=> New_List
(
3989 Make_Simple_Return_Statement
(Loc
,
3992 (RTE
(RE_Unsigned_64
), Subp_Info_Addr
))))));
3995 Analyze
(Last
(Decls
));
3997 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
3998 Analyze
(Last
(Decls
));
4000 Get_Library_Unit_Name_String
(Pkg_Spec
);
4004 Append_To
(Register_Pkg_Actuals
,
4005 Make_String_Literal
(Loc
,
4006 Strval
=> String_From_Name_Buffer
));
4010 Append_To
(Register_Pkg_Actuals
,
4011 Make_Attribute_Reference
(Loc
,
4012 Prefix
=> New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
4013 Attribute_Name
=> Name_Unrestricted_Access
));
4017 Append_To
(Register_Pkg_Actuals
,
4018 Make_Attribute_Reference
(Loc
,
4020 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
4021 Attribute_Name
=> Name_Version
));
4025 Append_To
(Register_Pkg_Actuals
,
4026 Make_Attribute_Reference
(Loc
,
4027 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
4028 Attribute_Name
=> Name_Address
));
4032 Append_To
(Register_Pkg_Actuals
,
4033 Make_Attribute_Reference
(Loc
,
4034 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
4035 Attribute_Name
=> Name_Length
));
4037 -- Generate the call
4040 Make_Procedure_Call_Statement
(Loc
,
4042 New_Occurrence_Of
(RTE
(RE_Register_Receiving_Stub
), Loc
),
4043 Parameter_Associations
=> Register_Pkg_Actuals
));
4044 Analyze
(Last
(Stmts
));
4045 end Add_Receiving_Stubs_To_Declarations
;
4047 ---------------------------------
4048 -- Build_General_Calling_Stubs --
4049 ---------------------------------
4051 procedure Build_General_Calling_Stubs
4053 Statements
: List_Id
;
4054 Target_Partition
: Entity_Id
;
4055 Target_RPC_Receiver
: Node_Id
;
4056 Subprogram_Id
: Node_Id
;
4057 Asynchronous
: Node_Id
:= Empty
;
4058 Is_Known_Asynchronous
: Boolean := False;
4059 Is_Known_Non_Asynchronous
: Boolean := False;
4060 Is_Function
: Boolean;
4062 Stub_Type
: Entity_Id
:= Empty
;
4063 RACW_Type
: Entity_Id
:= Empty
;
4066 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
4068 Stream_Parameter
: Node_Id
;
4069 -- Name of the stream used to transmit parameters to the
4072 Result_Parameter
: Node_Id
;
4073 -- Name of the result parameter (in non-APC cases) which get the
4074 -- result of the remote subprogram.
4076 Exception_Return_Parameter
: Node_Id
;
4077 -- Name of the parameter which will hold the exception sent by the
4078 -- remote subprogram.
4080 Current_Parameter
: Node_Id
;
4081 -- Current parameter being handled
4083 Ordered_Parameters_List
: constant List_Id
:=
4084 Build_Ordered_Parameters_List
(Spec
);
4086 Asynchronous_Statements
: List_Id
:= No_List
;
4087 Non_Asynchronous_Statements
: List_Id
:= No_List
;
4088 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4090 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4091 -- List of statements for extra formal parameters. It will appear
4092 -- after the regular statements for writing out parameters.
4094 pragma Warnings
(Off
);
4095 pragma Unreferenced
(RACW_Type
);
4096 -- Used only for the PolyORB case
4097 pragma Warnings
(On
);
4100 -- The general form of a calling stub for a given subprogram is:
4102 -- procedure X (...) is P : constant Partition_ID :=
4103 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4104 -- System.RPC.Params_Stream_Type (0); begin
4105 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4106 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4107 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4108 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4110 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4112 -- There are some variations: Do_APC is called for an asynchronous
4113 -- procedure and the part after the call is completely ommitted as
4114 -- well as the declaration of Result. For a function call, 'Input is
4115 -- always used to read the result even if it is constrained.
4118 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
4121 Make_Object_Declaration
(Loc
,
4122 Defining_Identifier
=> Stream_Parameter
,
4123 Aliased_Present
=> True,
4124 Object_Definition
=>
4125 Make_Subtype_Indication
(Loc
,
4127 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
4129 Make_Index_Or_Discriminant_Constraint
(Loc
,
4131 New_List
(Make_Integer_Literal
(Loc
, 0))))));
4133 if not Is_Known_Asynchronous
then
4135 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4138 Make_Object_Declaration
(Loc
,
4139 Defining_Identifier
=> Result_Parameter
,
4140 Aliased_Present
=> True,
4141 Object_Definition
=>
4142 Make_Subtype_Indication
(Loc
,
4144 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
4146 Make_Index_Or_Discriminant_Constraint
(Loc
,
4148 New_List
(Make_Integer_Literal
(Loc
, 0))))));
4150 Exception_Return_Parameter
:=
4151 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
4154 Make_Object_Declaration
(Loc
,
4155 Defining_Identifier
=> Exception_Return_Parameter
,
4156 Object_Definition
=>
4157 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
4160 Result_Parameter
:= Empty
;
4161 Exception_Return_Parameter
:= Empty
;
4164 -- Put first the RPC receiver corresponding to the remote package
4166 Append_To
(Statements
,
4167 Make_Attribute_Reference
(Loc
,
4169 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
4170 Attribute_Name
=> Name_Write
,
4171 Expressions
=> New_List
(
4172 Make_Attribute_Reference
(Loc
,
4173 Prefix
=> New_Occurrence_Of
(Stream_Parameter
, Loc
),
4174 Attribute_Name
=> Name_Access
),
4175 Target_RPC_Receiver
)));
4177 -- Then put the Subprogram_Id of the subprogram we want to call in
4180 Append_To
(Statements
,
4181 Make_Attribute_Reference
(Loc
,
4182 Prefix
=> New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4183 Attribute_Name
=> Name_Write
,
4184 Expressions
=> New_List
(
4185 Make_Attribute_Reference
(Loc
,
4186 Prefix
=> New_Occurrence_Of
(Stream_Parameter
, Loc
),
4187 Attribute_Name
=> Name_Access
),
4190 Current_Parameter
:= First
(Ordered_Parameters_List
);
4191 while Present
(Current_Parameter
) loop
4193 Typ
: constant Node_Id
:=
4194 Parameter_Type
(Current_Parameter
);
4196 Constrained
: Boolean;
4198 Extra_Parameter
: Entity_Id
;
4201 if Is_RACW_Controlling_Formal
4202 (Current_Parameter
, Stub_Type
)
4204 -- In the case of a controlling formal argument, we marshall
4205 -- its addr field rather than the local stub.
4207 Append_To
(Statements
,
4208 Pack_Node_Into_Stream
(Loc
,
4209 Stream
=> Stream_Parameter
,
4211 Make_Selected_Component
(Loc
,
4213 Defining_Identifier
(Current_Parameter
),
4214 Selector_Name
=> Name_Addr
),
4215 Etyp
=> RTE
(RE_Unsigned_64
)));
4220 (Defining_Identifier
(Current_Parameter
), Loc
);
4222 -- Access type parameters are transmitted as in out
4223 -- parameters. However, a dereference is needed so that
4224 -- we marshall the designated object.
4226 if Nkind
(Typ
) = N_Access_Definition
then
4227 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4228 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4230 Etyp
:= Etype
(Typ
);
4233 Constrained
:= not Transmit_As_Unconstrained
(Etyp
);
4235 -- Any parameter but unconstrained out parameters are
4236 -- transmitted to the peer.
4238 if In_Present
(Current_Parameter
)
4239 or else not Out_Present
(Current_Parameter
)
4240 or else not Constrained
4242 Append_To
(Statements
,
4243 Make_Attribute_Reference
(Loc
,
4244 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4246 Output_From_Constrained
(Constrained
),
4247 Expressions
=> New_List
(
4248 Make_Attribute_Reference
(Loc
,
4250 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4251 Attribute_Name
=> Name_Access
),
4256 -- If the current parameter has a dynamic constrained status,
4257 -- then this status is transmitted as well.
4258 -- This should be done for accessibility as well ???
4260 if Nkind
(Typ
) /= N_Access_Definition
4261 and then Need_Extra_Constrained
(Current_Parameter
)
4263 -- In this block, we do not use the extra formal that has
4264 -- been created because it does not exist at the time of
4265 -- expansion when building calling stubs for remote access
4266 -- to subprogram types. We create an extra variable of this
4267 -- type and push it in the stream after the regular
4270 Extra_Parameter
:= Make_Defining_Identifier
4271 (Loc
, New_Internal_Name
('P'));
4274 Make_Object_Declaration
(Loc
,
4275 Defining_Identifier
=> Extra_Parameter
,
4276 Constant_Present
=> True,
4277 Object_Definition
=>
4278 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4280 Make_Attribute_Reference
(Loc
,
4283 Defining_Identifier
(Current_Parameter
), Loc
),
4284 Attribute_Name
=> Name_Constrained
)));
4286 Append_To
(Extra_Formal_Statements
,
4287 Make_Attribute_Reference
(Loc
,
4289 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4290 Attribute_Name
=> Name_Write
,
4291 Expressions
=> New_List
(
4292 Make_Attribute_Reference
(Loc
,
4295 (Stream_Parameter
, Loc
), Attribute_Name
=>
4297 New_Occurrence_Of
(Extra_Parameter
, Loc
))));
4300 Next
(Current_Parameter
);
4304 -- Append the formal statements list to the statements
4306 Append_List_To
(Statements
, Extra_Formal_Statements
);
4308 if not Is_Known_Non_Asynchronous
then
4310 -- Build the call to System.RPC.Do_APC
4312 Asynchronous_Statements
:= New_List
(
4313 Make_Procedure_Call_Statement
(Loc
,
4315 New_Occurrence_Of
(RTE
(RE_Do_Apc
), Loc
),
4316 Parameter_Associations
=> New_List
(
4317 New_Occurrence_Of
(Target_Partition
, Loc
),
4318 Make_Attribute_Reference
(Loc
,
4320 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4321 Attribute_Name
=> Name_Access
))));
4323 Asynchronous_Statements
:= No_List
;
4326 if not Is_Known_Asynchronous
then
4328 -- Build the call to System.RPC.Do_RPC
4330 Non_Asynchronous_Statements
:= New_List
(
4331 Make_Procedure_Call_Statement
(Loc
,
4333 New_Occurrence_Of
(RTE
(RE_Do_Rpc
), Loc
),
4334 Parameter_Associations
=> New_List
(
4335 New_Occurrence_Of
(Target_Partition
, Loc
),
4337 Make_Attribute_Reference
(Loc
,
4339 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4340 Attribute_Name
=> Name_Access
),
4342 Make_Attribute_Reference
(Loc
,
4344 New_Occurrence_Of
(Result_Parameter
, Loc
),
4345 Attribute_Name
=> Name_Access
))));
4347 -- Read the exception occurrence from the result stream and
4348 -- reraise it. It does no harm if this is a Null_Occurrence since
4349 -- this does nothing.
4351 Append_To
(Non_Asynchronous_Statements
,
4352 Make_Attribute_Reference
(Loc
,
4354 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4356 Attribute_Name
=> Name_Read
,
4358 Expressions
=> New_List
(
4359 Make_Attribute_Reference
(Loc
,
4361 New_Occurrence_Of
(Result_Parameter
, Loc
),
4362 Attribute_Name
=> Name_Access
),
4363 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
4365 Append_To
(Non_Asynchronous_Statements
,
4366 Make_Procedure_Call_Statement
(Loc
,
4368 New_Occurrence_Of
(RTE
(RE_Reraise_Occurrence
), Loc
),
4369 Parameter_Associations
=> New_List
(
4370 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
4374 -- If this is a function call, then read the value and return
4375 -- it. The return value is written/read using 'Output/'Input.
4377 Append_To
(Non_Asynchronous_Statements
,
4378 Make_Tag_Check
(Loc
,
4379 Make_Simple_Return_Statement
(Loc
,
4381 Make_Attribute_Reference
(Loc
,
4384 Etype
(Result_Definition
(Spec
)), Loc
),
4386 Attribute_Name
=> Name_Input
,
4388 Expressions
=> New_List
(
4389 Make_Attribute_Reference
(Loc
,
4391 New_Occurrence_Of
(Result_Parameter
, Loc
),
4392 Attribute_Name
=> Name_Access
))))));
4395 -- Loop around parameters and assign out (or in out)
4396 -- parameters. In the case of RACW, controlling arguments
4397 -- cannot possibly have changed since they are remote, so we do
4398 -- not read them from the stream.
4400 Current_Parameter
:= First
(Ordered_Parameters_List
);
4401 while Present
(Current_Parameter
) loop
4403 Typ
: constant Node_Id
:=
4404 Parameter_Type
(Current_Parameter
);
4411 (Defining_Identifier
(Current_Parameter
), Loc
);
4413 if Nkind
(Typ
) = N_Access_Definition
then
4414 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4415 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4417 Etyp
:= Etype
(Typ
);
4420 if (Out_Present
(Current_Parameter
)
4421 or else Nkind
(Typ
) = N_Access_Definition
)
4422 and then Etyp
/= Stub_Type
4424 Append_To
(Non_Asynchronous_Statements
,
4425 Make_Attribute_Reference
(Loc
,
4427 New_Occurrence_Of
(Etyp
, Loc
),
4429 Attribute_Name
=> Name_Read
,
4431 Expressions
=> New_List
(
4432 Make_Attribute_Reference
(Loc
,
4434 New_Occurrence_Of
(Result_Parameter
, Loc
),
4435 Attribute_Name
=> Name_Access
),
4440 Next
(Current_Parameter
);
4445 if Is_Known_Asynchronous
then
4446 Append_List_To
(Statements
, Asynchronous_Statements
);
4448 elsif Is_Known_Non_Asynchronous
then
4449 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
4452 pragma Assert
(Present
(Asynchronous
));
4453 Prepend_To
(Asynchronous_Statements
,
4454 Make_Attribute_Reference
(Loc
,
4455 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4456 Attribute_Name
=> Name_Write
,
4457 Expressions
=> New_List
(
4458 Make_Attribute_Reference
(Loc
,
4460 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4461 Attribute_Name
=> Name_Access
),
4462 New_Occurrence_Of
(Standard_True
, Loc
))));
4464 Prepend_To
(Non_Asynchronous_Statements
,
4465 Make_Attribute_Reference
(Loc
,
4466 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4467 Attribute_Name
=> Name_Write
,
4468 Expressions
=> New_List
(
4469 Make_Attribute_Reference
(Loc
,
4471 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4472 Attribute_Name
=> Name_Access
),
4473 New_Occurrence_Of
(Standard_False
, Loc
))));
4475 Append_To
(Statements
,
4476 Make_Implicit_If_Statement
(Nod
,
4477 Condition
=> Asynchronous
,
4478 Then_Statements
=> Asynchronous_Statements
,
4479 Else_Statements
=> Non_Asynchronous_Statements
));
4481 end Build_General_Calling_Stubs
;
4483 -----------------------------
4484 -- Build_RPC_Receiver_Body --
4485 -----------------------------
4487 procedure Build_RPC_Receiver_Body
4488 (RPC_Receiver
: Entity_Id
;
4489 Request
: out Entity_Id
;
4490 Subp_Id
: out Entity_Id
;
4491 Subp_Index
: out Entity_Id
;
4492 Stmts
: out List_Id
;
4495 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
4497 RPC_Receiver_Spec
: Node_Id
;
4498 RPC_Receiver_Decls
: List_Id
;
4501 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
4503 RPC_Receiver_Spec
:=
4504 Build_RPC_Receiver_Specification
4505 (RPC_Receiver
=> RPC_Receiver
,
4506 Request_Parameter
=> Request
);
4508 Subp_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4509 Subp_Index
:= Subp_Id
;
4511 -- Subp_Id may not be a constant, because in the case of the RPC
4512 -- receiver for an RCI package, when a call is received from a RAS
4513 -- dereference, it will be assigned during subsequent processing.
4515 RPC_Receiver_Decls
:= New_List
(
4516 Make_Object_Declaration
(Loc
,
4517 Defining_Identifier
=> Subp_Id
,
4518 Object_Definition
=>
4519 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4521 Make_Attribute_Reference
(Loc
,
4523 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4524 Attribute_Name
=> Name_Input
,
4525 Expressions
=> New_List
(
4526 Make_Selected_Component
(Loc
,
4528 Selector_Name
=> Name_Params
)))));
4533 Make_Subprogram_Body
(Loc
,
4534 Specification
=> RPC_Receiver_Spec
,
4535 Declarations
=> RPC_Receiver_Decls
,
4536 Handled_Statement_Sequence
=>
4537 Make_Handled_Sequence_Of_Statements
(Loc
,
4538 Statements
=> Stmts
));
4539 end Build_RPC_Receiver_Body
;
4541 -----------------------
4542 -- Build_Stub_Target --
4543 -----------------------
4545 function Build_Stub_Target
4548 RCI_Locator
: Entity_Id
;
4549 Controlling_Parameter
: Entity_Id
) return RPC_Target
4551 Target_Info
: RPC_Target
(PCS_Kind
=> Name_GARLIC_DSA
);
4553 Target_Info
.Partition
:=
4554 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4555 if Present
(Controlling_Parameter
) then
4557 Make_Object_Declaration
(Loc
,
4558 Defining_Identifier
=> Target_Info
.Partition
,
4559 Constant_Present
=> True,
4560 Object_Definition
=>
4561 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4564 Make_Selected_Component
(Loc
,
4565 Prefix
=> Controlling_Parameter
,
4566 Selector_Name
=> Name_Origin
)));
4568 Target_Info
.RPC_Receiver
:=
4569 Make_Selected_Component
(Loc
,
4570 Prefix
=> Controlling_Parameter
,
4571 Selector_Name
=> Name_Receiver
);
4575 Make_Object_Declaration
(Loc
,
4576 Defining_Identifier
=> Target_Info
.Partition
,
4577 Constant_Present
=> True,
4578 Object_Definition
=>
4579 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4582 Make_Function_Call
(Loc
,
4583 Name
=> Make_Selected_Component
(Loc
,
4585 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4587 Make_Identifier
(Loc
,
4588 Name_Get_Active_Partition_ID
)))));
4590 Target_Info
.RPC_Receiver
:=
4591 Make_Selected_Component
(Loc
,
4593 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4595 Make_Identifier
(Loc
, Name_Get_RCI_Package_Receiver
));
4598 end Build_Stub_Target
;
4600 ---------------------
4601 -- Build_Stub_Type --
4602 ---------------------
4604 procedure Build_Stub_Type
4605 (RACW_Type
: Entity_Id
;
4606 Stub_Type
: Entity_Id
;
4607 Stub_Type_Decl
: out Node_Id
;
4608 RPC_Receiver_Decl
: out Node_Id
)
4610 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
4611 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
4615 Make_Full_Type_Declaration
(Loc
,
4616 Defining_Identifier
=> Stub_Type
,
4618 Make_Record_Definition
(Loc
,
4619 Tagged_Present
=> True,
4620 Limited_Present
=> True,
4622 Make_Component_List
(Loc
,
4623 Component_Items
=> New_List
(
4625 Make_Component_Declaration
(Loc
,
4626 Defining_Identifier
=>
4627 Make_Defining_Identifier
(Loc
, Name_Origin
),
4628 Component_Definition
=>
4629 Make_Component_Definition
(Loc
,
4630 Aliased_Present
=> False,
4631 Subtype_Indication
=>
4633 RTE
(RE_Partition_ID
), Loc
))),
4635 Make_Component_Declaration
(Loc
,
4636 Defining_Identifier
=>
4637 Make_Defining_Identifier
(Loc
, Name_Receiver
),
4638 Component_Definition
=>
4639 Make_Component_Definition
(Loc
,
4640 Aliased_Present
=> False,
4641 Subtype_Indication
=>
4642 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4644 Make_Component_Declaration
(Loc
,
4645 Defining_Identifier
=>
4646 Make_Defining_Identifier
(Loc
, Name_Addr
),
4647 Component_Definition
=>
4648 Make_Component_Definition
(Loc
,
4649 Aliased_Present
=> False,
4650 Subtype_Indication
=>
4651 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4653 Make_Component_Declaration
(Loc
,
4654 Defining_Identifier
=>
4655 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
4656 Component_Definition
=>
4657 Make_Component_Definition
(Loc
,
4658 Aliased_Present
=> False,
4659 Subtype_Indication
=>
4661 Standard_Boolean
, Loc
)))))));
4664 RPC_Receiver_Decl
:= Empty
;
4667 RPC_Receiver_Request
: constant Entity_Id
:=
4668 Make_Defining_Identifier
(Loc
, Name_R
);
4670 RPC_Receiver_Decl
:=
4671 Make_Subprogram_Declaration
(Loc
,
4672 Build_RPC_Receiver_Specification
(
4673 RPC_Receiver
=> Make_Defining_Identifier
(Loc
,
4674 New_Internal_Name
('R')),
4675 Request_Parameter
=> RPC_Receiver_Request
));
4678 end Build_Stub_Type
;
4680 --------------------------------------
4681 -- Build_Subprogram_Receiving_Stubs --
4682 --------------------------------------
4684 function Build_Subprogram_Receiving_Stubs
4685 (Vis_Decl
: Node_Id
;
4686 Asynchronous
: Boolean;
4687 Dynamically_Asynchronous
: Boolean := False;
4688 Stub_Type
: Entity_Id
:= Empty
;
4689 RACW_Type
: Entity_Id
:= Empty
;
4690 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
4692 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
4694 Request_Parameter
: constant Entity_Id
:=
4695 Make_Defining_Identifier
(Loc
,
4696 New_Internal_Name
('R'));
4697 -- Formal parameter for receiving stubs: a descriptor for an incoming
4700 Decls
: constant List_Id
:= New_List
;
4701 -- All the parameters will get declared before calling the real
4702 -- subprograms. Also the out parameters will be declared.
4704 Statements
: constant List_Id
:= New_List
;
4706 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4707 -- Statements concerning extra formal parameters
4709 After_Statements
: constant List_Id
:= New_List
;
4710 -- Statements to be executed after the subprogram call
4712 Inner_Decls
: List_Id
:= No_List
;
4713 -- In case of a function, the inner declarations are needed since
4714 -- the result may be unconstrained.
4716 Excep_Handlers
: List_Id
:= No_List
;
4717 Excep_Choice
: Entity_Id
;
4718 Excep_Code
: List_Id
;
4720 Parameter_List
: constant List_Id
:= New_List
;
4721 -- List of parameters to be passed to the subprogram
4723 Current_Parameter
: Node_Id
;
4725 Ordered_Parameters_List
: constant List_Id
:=
4726 Build_Ordered_Parameters_List
4727 (Specification
(Vis_Decl
));
4729 Subp_Spec
: Node_Id
;
4730 -- Subprogram specification
4732 Called_Subprogram
: Node_Id
;
4733 -- The subprogram to call
4735 Null_Raise_Statement
: Node_Id
;
4737 Dynamic_Async
: Entity_Id
;
4740 if Present
(RACW_Type
) then
4741 Called_Subprogram
:= New_Occurrence_Of
(Parent_Primitive
, Loc
);
4743 Called_Subprogram
:=
4745 (Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
4748 if Dynamically_Asynchronous
then
4750 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
4752 Dynamic_Async
:= Empty
;
4755 if not Asynchronous
or Dynamically_Asynchronous
then
4757 -- The first statement after the subprogram call is a statement to
4758 -- write a Null_Occurrence into the result stream.
4760 Null_Raise_Statement
:=
4761 Make_Attribute_Reference
(Loc
,
4763 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4764 Attribute_Name
=> Name_Write
,
4765 Expressions
=> New_List
(
4766 Make_Selected_Component
(Loc
,
4767 Prefix
=> Request_Parameter
,
4768 Selector_Name
=> Name_Result
),
4769 New_Occurrence_Of
(RTE
(RE_Null_Occurrence
), Loc
)));
4771 if Dynamically_Asynchronous
then
4772 Null_Raise_Statement
:=
4773 Make_Implicit_If_Statement
(Vis_Decl
,
4775 Make_Op_Not
(Loc
, New_Occurrence_Of
(Dynamic_Async
, Loc
)),
4776 Then_Statements
=> New_List
(Null_Raise_Statement
));
4779 Append_To
(After_Statements
, Null_Raise_Statement
);
4782 -- Loop through every parameter and get its value from the stream. If
4783 -- the parameter is unconstrained, then the parameter is read using
4784 -- 'Input at the point of declaration.
4786 Current_Parameter
:= First
(Ordered_Parameters_List
);
4787 while Present
(Current_Parameter
) loop
4790 Constrained
: Boolean;
4792 Need_Extra_Constrained
: Boolean;
4793 -- True when an Extra_Constrained actual is required
4795 Object
: constant Entity_Id
:=
4796 Make_Defining_Identifier
(Loc
,
4797 New_Internal_Name
('P'));
4799 Expr
: Node_Id
:= Empty
;
4801 Is_Controlling_Formal
: constant Boolean :=
4802 Is_RACW_Controlling_Formal
4803 (Current_Parameter
, Stub_Type
);
4806 if Is_Controlling_Formal
then
4808 -- We have a controlling formal parameter. Read its address
4809 -- rather than a real object. The address is in Unsigned_64
4812 Etyp
:= RTE
(RE_Unsigned_64
);
4814 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
4817 Constrained
:= not Transmit_As_Unconstrained
(Etyp
);
4819 if In_Present
(Current_Parameter
)
4820 or else not Out_Present
(Current_Parameter
)
4821 or else not Constrained
4822 or else Is_Controlling_Formal
4824 -- If an input parameter is constrained, then the read of
4825 -- the parameter is deferred until the beginning of the
4826 -- subprogram body. If it is unconstrained, then an
4827 -- expression is built for the object declaration and the
4828 -- variable is set using 'Input instead of 'Read. Note that
4829 -- this deferral does not change the order in which the
4830 -- actuals are read because Build_Ordered_Parameter_List
4831 -- puts them unconstrained first.
4834 Append_To
(Statements
,
4835 Make_Attribute_Reference
(Loc
,
4836 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4837 Attribute_Name
=> Name_Read
,
4838 Expressions
=> New_List
(
4839 Make_Selected_Component
(Loc
,
4840 Prefix
=> Request_Parameter
,
4841 Selector_Name
=> Name_Params
),
4842 New_Occurrence_Of
(Object
, Loc
))));
4846 -- Build and append Input_With_Tag_Check function
4849 Input_With_Tag_Check
(Loc
,
4852 Make_Selected_Component
(Loc
,
4853 Prefix
=> Request_Parameter
,
4854 Selector_Name
=> Name_Params
)));
4856 -- Prepare function call expression
4859 Make_Function_Call
(Loc
,
4863 (Specification
(Last
(Decls
))), Loc
));
4867 Need_Extra_Constrained
:=
4868 Nkind
(Parameter_Type
(Current_Parameter
)) /=
4871 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
4873 Present
(Extra_Constrained
4874 (Defining_Identifier
(Current_Parameter
)));
4876 -- We may not associate an extra constrained actual to a
4877 -- constant object, so if one is needed, declare the actual
4878 -- as a variable even if it won't be modified.
4880 Build_Actual_Object_Declaration
4883 Variable
=> Need_Extra_Constrained
4884 or else Out_Present
(Current_Parameter
),
4888 -- An out parameter may be written back using a 'Write
4889 -- attribute instead of a 'Output because it has been
4890 -- constrained by the parameter given to the caller. Note that
4891 -- out controlling arguments in the case of a RACW are not put
4892 -- back in the stream because the pointer on them has not
4895 if Out_Present
(Current_Parameter
)
4897 Etype
(Parameter_Type
(Current_Parameter
)) /= Stub_Type
4899 Append_To
(After_Statements
,
4900 Make_Attribute_Reference
(Loc
,
4901 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4902 Attribute_Name
=> Name_Write
,
4903 Expressions
=> New_List
(
4904 Make_Selected_Component
(Loc
,
4905 Prefix
=> Request_Parameter
,
4906 Selector_Name
=> Name_Result
),
4907 New_Occurrence_Of
(Object
, Loc
))));
4910 -- For RACW controlling formals, the Etyp of Object is always
4911 -- an RACW, even if the parameter is not of an anonymous access
4912 -- type. In such case, we need to dereference it at call time.
4914 if Is_Controlling_Formal
then
4915 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
4918 Append_To
(Parameter_List
,
4919 Make_Parameter_Association
(Loc
,
4922 Defining_Identifier
(Current_Parameter
), Loc
),
4923 Explicit_Actual_Parameter
=>
4924 Make_Explicit_Dereference
(Loc
,
4925 Unchecked_Convert_To
(RACW_Type
,
4926 OK_Convert_To
(RTE
(RE_Address
),
4927 New_Occurrence_Of
(Object
, Loc
))))));
4930 Append_To
(Parameter_List
,
4931 Make_Parameter_Association
(Loc
,
4934 Defining_Identifier
(Current_Parameter
), Loc
),
4935 Explicit_Actual_Parameter
=>
4936 Unchecked_Convert_To
(RACW_Type
,
4937 OK_Convert_To
(RTE
(RE_Address
),
4938 New_Occurrence_Of
(Object
, Loc
)))));
4942 Append_To
(Parameter_List
,
4943 Make_Parameter_Association
(Loc
,
4946 Defining_Identifier
(Current_Parameter
), Loc
),
4947 Explicit_Actual_Parameter
=>
4948 New_Occurrence_Of
(Object
, Loc
)));
4951 -- If the current parameter needs an extra formal, then read it
4952 -- from the stream and set the corresponding semantic field in
4953 -- the variable. If the kind of the parameter identifier is
4954 -- E_Void, then this is a compiler generated parameter that
4955 -- doesn't need an extra constrained status.
4957 -- The case of Extra_Accessibility should also be handled ???
4959 if Need_Extra_Constrained
then
4961 Extra_Parameter
: constant Entity_Id
:=
4963 (Defining_Identifier
4964 (Current_Parameter
));
4966 Formal_Entity
: constant Entity_Id
:=
4967 Make_Defining_Identifier
4968 (Loc
, Chars
(Extra_Parameter
));
4970 Formal_Type
: constant Entity_Id
:=
4971 Etype
(Extra_Parameter
);
4975 Make_Object_Declaration
(Loc
,
4976 Defining_Identifier
=> Formal_Entity
,
4977 Object_Definition
=>
4978 New_Occurrence_Of
(Formal_Type
, Loc
)));
4980 Append_To
(Extra_Formal_Statements
,
4981 Make_Attribute_Reference
(Loc
,
4982 Prefix
=> New_Occurrence_Of
(
4984 Attribute_Name
=> Name_Read
,
4985 Expressions
=> New_List
(
4986 Make_Selected_Component
(Loc
,
4987 Prefix
=> Request_Parameter
,
4988 Selector_Name
=> Name_Params
),
4989 New_Occurrence_Of
(Formal_Entity
, Loc
))));
4991 -- Note: the call to Set_Extra_Constrained below relies
4992 -- on the fact that Object's Ekind has been set by
4993 -- Build_Actual_Object_Declaration.
4995 Set_Extra_Constrained
(Object
, Formal_Entity
);
5000 Next
(Current_Parameter
);
5003 -- Append the formal statements list at the end of regular statements
5005 Append_List_To
(Statements
, Extra_Formal_Statements
);
5007 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
5009 -- The remote subprogram is a function. We build an inner block to
5010 -- be able to hold a potentially unconstrained result in a
5014 Etyp
: constant Entity_Id
:=
5015 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
5016 Result
: constant Node_Id
:=
5017 Make_Defining_Identifier
(Loc
,
5018 New_Internal_Name
('R'));
5020 Inner_Decls
:= New_List
(
5021 Make_Object_Declaration
(Loc
,
5022 Defining_Identifier
=> Result
,
5023 Constant_Present
=> True,
5024 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
5026 Make_Function_Call
(Loc
,
5027 Name
=> Called_Subprogram
,
5028 Parameter_Associations
=> Parameter_List
)));
5030 if Is_Class_Wide_Type
(Etyp
) then
5032 -- For a remote call to a function with a class-wide type,
5033 -- check that the returned value satisfies the requirements
5036 Append_To
(Inner_Decls
,
5037 Make_Transportable_Check
(Loc
,
5038 New_Occurrence_Of
(Result
, Loc
)));
5042 Append_To
(After_Statements
,
5043 Make_Attribute_Reference
(Loc
,
5044 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5045 Attribute_Name
=> Name_Output
,
5046 Expressions
=> New_List
(
5047 Make_Selected_Component
(Loc
,
5048 Prefix
=> Request_Parameter
,
5049 Selector_Name
=> Name_Result
),
5050 New_Occurrence_Of
(Result
, Loc
))));
5053 Append_To
(Statements
,
5054 Make_Block_Statement
(Loc
,
5055 Declarations
=> Inner_Decls
,
5056 Handled_Statement_Sequence
=>
5057 Make_Handled_Sequence_Of_Statements
(Loc
,
5058 Statements
=> After_Statements
)));
5061 -- The remote subprogram is a procedure. We do not need any inner
5062 -- block in this case.
5064 if Dynamically_Asynchronous
then
5066 Make_Object_Declaration
(Loc
,
5067 Defining_Identifier
=> Dynamic_Async
,
5068 Object_Definition
=>
5069 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
5071 Append_To
(Statements
,
5072 Make_Attribute_Reference
(Loc
,
5073 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
5074 Attribute_Name
=> Name_Read
,
5075 Expressions
=> New_List
(
5076 Make_Selected_Component
(Loc
,
5077 Prefix
=> Request_Parameter
,
5078 Selector_Name
=> Name_Params
),
5079 New_Occurrence_Of
(Dynamic_Async
, Loc
))));
5082 Append_To
(Statements
,
5083 Make_Procedure_Call_Statement
(Loc
,
5084 Name
=> Called_Subprogram
,
5085 Parameter_Associations
=> Parameter_List
));
5087 Append_List_To
(Statements
, After_Statements
);
5090 if Asynchronous
and then not Dynamically_Asynchronous
then
5092 -- For an asynchronous procedure, add a null exception handler
5094 Excep_Handlers
:= New_List
(
5095 Make_Implicit_Exception_Handler
(Loc
,
5096 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5097 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
5100 -- In the other cases, if an exception is raised, then the
5101 -- exception occurrence is copied into the output stream and
5102 -- no other output parameter is written.
5105 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
5107 Excep_Code
:= New_List
(
5108 Make_Attribute_Reference
(Loc
,
5110 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
5111 Attribute_Name
=> Name_Write
,
5112 Expressions
=> New_List
(
5113 Make_Selected_Component
(Loc
,
5114 Prefix
=> Request_Parameter
,
5115 Selector_Name
=> Name_Result
),
5116 New_Occurrence_Of
(Excep_Choice
, Loc
))));
5118 if Dynamically_Asynchronous
then
5119 Excep_Code
:= New_List
(
5120 Make_Implicit_If_Statement
(Vis_Decl
,
5121 Condition
=> Make_Op_Not
(Loc
,
5122 New_Occurrence_Of
(Dynamic_Async
, Loc
)),
5123 Then_Statements
=> Excep_Code
));
5126 Excep_Handlers
:= New_List
(
5127 Make_Implicit_Exception_Handler
(Loc
,
5128 Choice_Parameter
=> Excep_Choice
,
5129 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5130 Statements
=> Excep_Code
));
5135 Make_Procedure_Specification
(Loc
,
5136 Defining_Unit_Name
=>
5137 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
5139 Parameter_Specifications
=> New_List
(
5140 Make_Parameter_Specification
(Loc
,
5141 Defining_Identifier
=> Request_Parameter
,
5143 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
5146 Make_Subprogram_Body
(Loc
,
5147 Specification
=> Subp_Spec
,
5148 Declarations
=> Decls
,
5149 Handled_Statement_Sequence
=>
5150 Make_Handled_Sequence_Of_Statements
(Loc
,
5151 Statements
=> Statements
,
5152 Exception_Handlers
=> Excep_Handlers
));
5153 end Build_Subprogram_Receiving_Stubs
;
5159 function Result
return Node_Id
is
5161 return Make_Identifier
(Loc
, Name_V
);
5164 ----------------------
5165 -- Stream_Parameter --
5166 ----------------------
5168 function Stream_Parameter
return Node_Id
is
5170 return Make_Identifier
(Loc
, Name_S
);
5171 end Stream_Parameter
;
5175 -------------------------------
5176 -- Get_And_Reset_RACW_Bodies --
5177 -------------------------------
5179 function Get_And_Reset_RACW_Bodies
(RACW_Type
: Entity_Id
) return List_Id
is
5180 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
5181 Stub_Elements
: Stub_Structure
:= Stubs_Table
.Get
(Desig
);
5183 Body_Decls
: List_Id
;
5184 -- Returned list of declarations
5187 if Stub_Elements
= Empty_Stub_Structure
then
5189 -- Stub elements may be missing as a consequence of a previously
5195 Body_Decls
:= Stub_Elements
.Body_Decls
;
5196 Stub_Elements
.Body_Decls
:= No_List
;
5197 Stubs_Table
.Set
(Desig
, Stub_Elements
);
5199 end Get_And_Reset_RACW_Bodies
;
5201 -----------------------
5202 -- Get_Stub_Elements --
5203 -----------------------
5205 function Get_Stub_Elements
(RACW_Type
: Entity_Id
) return Stub_Structure
is
5206 Desig
: constant Entity_Id
:=
5207 Etype
(Designated_Type
(RACW_Type
));
5208 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
5210 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5211 return Stub_Elements
;
5212 end Get_Stub_Elements
;
5214 -----------------------
5215 -- Get_Subprogram_Id --
5216 -----------------------
5218 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
is
5219 Result
: constant String_Id
:= Get_Subprogram_Ids
(Def
).Str_Identifier
;
5221 pragma Assert
(Result
/= No_String
);
5223 end Get_Subprogram_Id
;
5225 -----------------------
5226 -- Get_Subprogram_Id --
5227 -----------------------
5229 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
is
5231 return Get_Subprogram_Ids
(Def
).Int_Identifier
;
5232 end Get_Subprogram_Id
;
5234 ------------------------
5235 -- Get_Subprogram_Ids --
5236 ------------------------
5238 function Get_Subprogram_Ids
5239 (Def
: Entity_Id
) return Subprogram_Identifiers
5242 return Subprogram_Identifier_Table
.Get
(Def
);
5243 end Get_Subprogram_Ids
;
5249 function Hash
(F
: Entity_Id
) return Hash_Index
is
5251 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
5254 function Hash
(F
: Name_Id
) return Hash_Index
is
5256 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
5259 --------------------------
5260 -- Input_With_Tag_Check --
5261 --------------------------
5263 function Input_With_Tag_Check
5265 Var_Type
: Entity_Id
;
5266 Stream
: Node_Id
) return Node_Id
5270 Make_Subprogram_Body
(Loc
,
5271 Specification
=> Make_Function_Specification
(Loc
,
5272 Defining_Unit_Name
=>
5273 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S')),
5274 Result_Definition
=> New_Occurrence_Of
(Var_Type
, Loc
)),
5275 Declarations
=> No_List
,
5276 Handled_Statement_Sequence
=>
5277 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
5278 Make_Tag_Check
(Loc
,
5279 Make_Simple_Return_Statement
(Loc
,
5280 Make_Attribute_Reference
(Loc
,
5281 Prefix
=> New_Occurrence_Of
(Var_Type
, Loc
),
5282 Attribute_Name
=> Name_Input
,
5284 New_List
(Stream
)))))));
5285 end Input_With_Tag_Check
;
5287 --------------------------------
5288 -- Is_RACW_Controlling_Formal --
5289 --------------------------------
5291 function Is_RACW_Controlling_Formal
5292 (Parameter
: Node_Id
;
5293 Stub_Type
: Entity_Id
) return Boolean
5298 -- If the kind of the parameter is E_Void, then it is not a
5299 -- controlling formal (this can happen in the context of RAS).
5301 if Ekind
(Defining_Identifier
(Parameter
)) = E_Void
then
5305 -- If the parameter is not a controlling formal, then it cannot
5306 -- be possibly a RACW_Controlling_Formal.
5308 if not Is_Controlling_Formal
(Defining_Identifier
(Parameter
)) then
5312 Typ
:= Parameter_Type
(Parameter
);
5313 return (Nkind
(Typ
) = N_Access_Definition
5314 and then Etype
(Subtype_Mark
(Typ
)) = Stub_Type
)
5315 or else Etype
(Typ
) = Stub_Type
;
5316 end Is_RACW_Controlling_Formal
;
5318 ------------------------------
5319 -- Make_Transportable_Check --
5320 ------------------------------
5322 function Make_Transportable_Check
5324 Expr
: Node_Id
) return Node_Id
is
5327 Make_Raise_Program_Error
(Loc
,
5330 Build_Get_Transportable
(Loc
,
5331 Make_Selected_Component
(Loc
,
5333 Selector_Name
=> Make_Identifier
(Loc
, Name_uTag
)))),
5334 Reason
=> PE_Non_Transportable_Actual
);
5335 end Make_Transportable_Check
;
5337 -----------------------------
5338 -- Make_Selected_Component --
5339 -----------------------------
5341 function Make_Selected_Component
5344 Selector_Name
: Name_Id
) return Node_Id
5347 return Make_Selected_Component
(Loc
,
5348 Prefix
=> New_Occurrence_Of
(Prefix
, Loc
),
5349 Selector_Name
=> Make_Identifier
(Loc
, Selector_Name
));
5350 end Make_Selected_Component
;
5352 --------------------
5353 -- Make_Tag_Check --
5354 --------------------
5356 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
is
5357 Occ
: constant Entity_Id
:=
5358 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
5361 return Make_Block_Statement
(Loc
,
5362 Handled_Statement_Sequence
=>
5363 Make_Handled_Sequence_Of_Statements
(Loc
,
5364 Statements
=> New_List
(N
),
5366 Exception_Handlers
=> New_List
(
5367 Make_Implicit_Exception_Handler
(Loc
,
5368 Choice_Parameter
=> Occ
,
5370 Exception_Choices
=>
5371 New_List
(New_Occurrence_Of
(RTE
(RE_Tag_Error
), Loc
)),
5374 New_List
(Make_Procedure_Call_Statement
(Loc
,
5376 (RTE
(RE_Raise_Program_Error_Unknown_Tag
), Loc
),
5377 New_List
(New_Occurrence_Of
(Occ
, Loc
))))))));
5380 ----------------------------
5381 -- Need_Extra_Constrained --
5382 ----------------------------
5384 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean is
5385 Etyp
: constant Entity_Id
:= Etype
(Parameter_Type
(Parameter
));
5387 return Out_Present
(Parameter
)
5388 and then Has_Discriminants
(Etyp
)
5389 and then not Is_Constrained
(Etyp
)
5390 and then not Is_Indefinite_Subtype
(Etyp
);
5391 end Need_Extra_Constrained
;
5393 ------------------------------------
5394 -- Pack_Entity_Into_Stream_Access --
5395 ------------------------------------
5397 function Pack_Entity_Into_Stream_Access
5401 Etyp
: Entity_Id
:= Empty
) return Node_Id
5406 if Present
(Etyp
) then
5409 Typ
:= Etype
(Object
);
5413 Pack_Node_Into_Stream_Access
(Loc
,
5415 Object
=> New_Occurrence_Of
(Object
, Loc
),
5417 end Pack_Entity_Into_Stream_Access
;
5419 ---------------------------
5420 -- Pack_Node_Into_Stream --
5421 ---------------------------
5423 function Pack_Node_Into_Stream
5427 Etyp
: Entity_Id
) return Node_Id
5429 Write_Attribute
: Name_Id
:= Name_Write
;
5432 if not Is_Constrained
(Etyp
) then
5433 Write_Attribute
:= Name_Output
;
5437 Make_Attribute_Reference
(Loc
,
5438 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5439 Attribute_Name
=> Write_Attribute
,
5440 Expressions
=> New_List
(
5441 Make_Attribute_Reference
(Loc
,
5442 Prefix
=> New_Occurrence_Of
(Stream
, Loc
),
5443 Attribute_Name
=> Name_Access
),
5445 end Pack_Node_Into_Stream
;
5447 ----------------------------------
5448 -- Pack_Node_Into_Stream_Access --
5449 ----------------------------------
5451 function Pack_Node_Into_Stream_Access
5455 Etyp
: Entity_Id
) return Node_Id
5457 Write_Attribute
: Name_Id
:= Name_Write
;
5460 if not Is_Constrained
(Etyp
) then
5461 Write_Attribute
:= Name_Output
;
5465 Make_Attribute_Reference
(Loc
,
5466 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5467 Attribute_Name
=> Write_Attribute
,
5468 Expressions
=> New_List
(
5471 end Pack_Node_Into_Stream_Access
;
5473 ---------------------
5474 -- PolyORB_Support --
5475 ---------------------
5477 package body PolyORB_Support
is
5479 -- Local subprograms
5481 procedure Add_RACW_Read_Attribute
5482 (RACW_Type
: Entity_Id
;
5483 Stub_Type
: Entity_Id
;
5484 Stub_Type_Access
: Entity_Id
;
5485 Body_Decls
: List_Id
);
5486 -- Add Read attribute for the RACW type. The declaration and attribute
5487 -- definition clauses are inserted right after the declaration of
5488 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5489 -- appended to it (case where the RACW declaration is in the main unit).
5491 procedure Add_RACW_Write_Attribute
5492 (RACW_Type
: Entity_Id
;
5493 Stub_Type
: Entity_Id
;
5494 Stub_Type_Access
: Entity_Id
;
5495 Body_Decls
: List_Id
);
5496 -- Same as above for the Write attribute
5498 procedure Add_RACW_From_Any
5499 (RACW_Type
: Entity_Id
;
5500 Body_Decls
: List_Id
);
5501 -- Add the From_Any TSS for this RACW type
5503 procedure Add_RACW_To_Any
5504 (RACW_Type
: Entity_Id
;
5505 Body_Decls
: List_Id
);
5506 -- Add the To_Any TSS for this RACW type
5508 procedure Add_RACW_TypeCode
5509 (Designated_Type
: Entity_Id
;
5510 RACW_Type
: Entity_Id
;
5511 Body_Decls
: List_Id
);
5512 -- Add the TypeCode TSS for this RACW type
5514 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
);
5515 -- Add the From_Any TSS for this RAS type
5517 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
);
5518 -- Add the To_Any TSS for this RAS type
5520 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
);
5521 -- Add the TypeCode TSS for this RAS type
5523 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
5524 -- Add a subprogram body for RAS Access TSS
5526 -------------------------------------
5527 -- Add_Obj_RPC_Receiver_Completion --
5528 -------------------------------------
5530 procedure Add_Obj_RPC_Receiver_Completion
5533 RPC_Receiver
: Entity_Id
;
5534 Stub_Elements
: Stub_Structure
)
5536 Desig
: constant Entity_Id
:=
5537 Etype
(Designated_Type
(Stub_Elements
.RACW_Type
));
5540 Make_Procedure_Call_Statement
(Loc
,
5543 RTE
(RE_Register_Obj_Receiving_Stub
), Loc
),
5545 Parameter_Associations
=> New_List
(
5549 Make_String_Literal
(Loc
,
5550 Full_Qualified_Name
(Desig
)),
5554 Make_Attribute_Reference
(Loc
,
5557 Defining_Unit_Name
(Parent
(RPC_Receiver
)), Loc
),
5563 Make_Attribute_Reference
(Loc
,
5566 Defining_Identifier
(
5567 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5570 end Add_Obj_RPC_Receiver_Completion
;
5572 -----------------------
5573 -- Add_RACW_Features --
5574 -----------------------
5576 procedure Add_RACW_Features
5577 (RACW_Type
: Entity_Id
;
5579 Stub_Type
: Entity_Id
;
5580 Stub_Type_Access
: Entity_Id
;
5581 RPC_Receiver_Decl
: Node_Id
;
5582 Body_Decls
: List_Id
)
5584 pragma Warnings
(Off
);
5585 pragma Unreferenced
(RPC_Receiver_Decl
);
5586 pragma Warnings
(On
);
5590 (RACW_Type
=> RACW_Type
,
5591 Body_Decls
=> Body_Decls
);
5594 (RACW_Type
=> RACW_Type
,
5595 Body_Decls
=> Body_Decls
);
5597 Add_RACW_Write_Attribute
5598 (RACW_Type
=> RACW_Type
,
5599 Stub_Type
=> Stub_Type
,
5600 Stub_Type_Access
=> Stub_Type_Access
,
5601 Body_Decls
=> Body_Decls
);
5603 Add_RACW_Read_Attribute
5604 (RACW_Type
=> RACW_Type
,
5605 Stub_Type
=> Stub_Type
,
5606 Stub_Type_Access
=> Stub_Type_Access
,
5607 Body_Decls
=> Body_Decls
);
5610 (Designated_Type
=> Desig
,
5611 RACW_Type
=> RACW_Type
,
5612 Body_Decls
=> Body_Decls
);
5613 end Add_RACW_Features
;
5615 -----------------------
5616 -- Add_RACW_From_Any --
5617 -----------------------
5619 procedure Add_RACW_From_Any
5620 (RACW_Type
: Entity_Id
;
5621 Body_Decls
: List_Id
)
5623 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5624 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5626 Fnam
: constant Entity_Id
:=
5627 Make_Defining_Identifier
(Loc
,
5628 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'F'));
5630 Func_Spec
: Node_Id
;
5631 Func_Decl
: Node_Id
;
5632 Func_Body
: Node_Id
;
5634 Statements
: List_Id
;
5635 -- Various parts of the subprogram
5637 Any_Parameter
: constant Entity_Id
:=
5638 Make_Defining_Identifier
(Loc
, Name_A
);
5640 Asynchronous_Flag
: constant Entity_Id
:=
5641 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5642 -- The flag object declared in Add_RACW_Asynchronous_Flag
5646 Make_Function_Specification
(Loc
,
5647 Defining_Unit_Name
=>
5649 Parameter_Specifications
=> New_List
(
5650 Make_Parameter_Specification
(Loc
,
5651 Defining_Identifier
=>
5654 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
5655 Result_Definition
=> New_Occurrence_Of
(RACW_Type
, Loc
));
5657 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5658 -- entity in the declaration spec, not those of the body spec.
5660 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5661 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5662 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_From_Any
);
5664 if No
(Body_Decls
) then
5668 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5669 -- set on the stub type if, and only if, the RACW type has a pragma
5670 -- Asynchronous. This is incorrect for RACWs that implement RAS
5671 -- types, because in that case the /designated subprogram/ (not the
5672 -- type) might be asynchronous, and that causes the stub to need to
5673 -- be asynchronous too. A solution is to transport a RAS as a struct
5674 -- containing a RACW and an asynchronous flag, and to properly alter
5675 -- the Asynchronous component in the stub type in the RAS's _From_Any
5678 Statements
:= New_List
(
5679 Make_Simple_Return_Statement
(Loc
,
5680 Expression
=> Unchecked_Convert_To
(RACW_Type
,
5681 Make_Function_Call
(Loc
,
5682 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RACW
), Loc
),
5683 Parameter_Associations
=> New_List
(
5684 Make_Function_Call
(Loc
,
5685 Name
=> New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
5686 Parameter_Associations
=> New_List
(
5687 New_Occurrence_Of
(Any_Parameter
, Loc
))),
5688 Build_Stub_Tag
(Loc
, RACW_Type
),
5689 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5690 New_Occurrence_Of
(Asynchronous_Flag
, Loc
))))));
5693 Make_Subprogram_Body
(Loc
,
5694 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
5695 Declarations
=> No_List
,
5696 Handled_Statement_Sequence
=>
5697 Make_Handled_Sequence_Of_Statements
(Loc
,
5698 Statements
=> Statements
));
5700 Append_To
(Body_Decls
, Func_Body
);
5701 end Add_RACW_From_Any
;
5703 -----------------------------
5704 -- Add_RACW_Read_Attribute --
5705 -----------------------------
5707 procedure Add_RACW_Read_Attribute
5708 (RACW_Type
: Entity_Id
;
5709 Stub_Type
: Entity_Id
;
5710 Stub_Type_Access
: Entity_Id
;
5711 Body_Decls
: List_Id
)
5713 pragma Warnings
(Off
);
5714 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
5715 pragma Warnings
(On
);
5716 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5718 Proc_Decl
: Node_Id
;
5719 Attr_Decl
: Node_Id
;
5721 Body_Node
: Node_Id
;
5723 Decls
: constant List_Id
:= New_List
;
5724 Statements
: constant List_Id
:= New_List
;
5725 Reference
: constant Entity_Id
:=
5726 Make_Defining_Identifier
(Loc
, Name_R
);
5727 -- Various parts of the procedure
5729 Pnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
5730 New_Internal_Name
('R'));
5732 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5734 Asynchronous_Flag
: constant Entity_Id
:=
5735 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5736 pragma Assert
(Present
(Asynchronous_Flag
));
5738 function Stream_Parameter
return Node_Id
;
5739 function Result
return Node_Id
;
5741 -- Functions to create occurrences of the formal parameter names
5747 function Result
return Node_Id
is
5749 return Make_Identifier
(Loc
, Name_V
);
5752 ----------------------
5753 -- Stream_Parameter --
5754 ----------------------
5756 function Stream_Parameter
return Node_Id
is
5758 return Make_Identifier
(Loc
, Name_S
);
5759 end Stream_Parameter
;
5761 -- Start of processing for Add_RACW_Read_Attribute
5764 Build_Stream_Procedure
5765 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> True);
5767 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
5768 Copy_Specification
(Loc
, Specification
(Body_Node
)));
5771 Make_Attribute_Definition_Clause
(Loc
,
5772 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
5776 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
5778 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
5779 Insert_After
(Proc_Decl
, Attr_Decl
);
5781 if No
(Body_Decls
) then
5786 Make_Object_Declaration
(Loc
,
5787 Defining_Identifier
=>
5789 Object_Definition
=>
5790 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)));
5792 Append_List_To
(Statements
, New_List
(
5793 Make_Attribute_Reference
(Loc
,
5795 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5796 Attribute_Name
=> Name_Read
,
5797 Expressions
=> New_List
(
5799 New_Occurrence_Of
(Reference
, Loc
))),
5801 Make_Assignment_Statement
(Loc
,
5805 Unchecked_Convert_To
(RACW_Type
,
5806 Make_Function_Call
(Loc
,
5808 New_Occurrence_Of
(RTE
(RE_Get_RACW
), Loc
),
5809 Parameter_Associations
=> New_List
(
5810 New_Occurrence_Of
(Reference
, Loc
),
5811 Build_Stub_Tag
(Loc
, RACW_Type
),
5812 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5813 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)))))));
5815 Set_Declarations
(Body_Node
, Decls
);
5816 Append_To
(Body_Decls
, Body_Node
);
5817 end Add_RACW_Read_Attribute
;
5819 ---------------------
5820 -- Add_RACW_To_Any --
5821 ---------------------
5823 procedure Add_RACW_To_Any
5824 (RACW_Type
: Entity_Id
;
5825 Body_Decls
: List_Id
)
5827 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5829 Fnam
: constant Entity_Id
:=
5830 Make_Defining_Identifier
(Loc
,
5831 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'T'));
5833 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5835 Stub_Elements
: constant Stub_Structure
:=
5836 Get_Stub_Elements
(RACW_Type
);
5838 Func_Spec
: Node_Id
;
5839 Func_Decl
: Node_Id
;
5840 Func_Body
: Node_Id
;
5843 Statements
: List_Id
;
5844 -- Various parts of the subprogram
5846 RACW_Parameter
: constant Entity_Id
:=
5847 Make_Defining_Identifier
(Loc
, Name_R
);
5849 Reference
: constant Entity_Id
:=
5850 Make_Defining_Identifier
5851 (Loc
, New_Internal_Name
('R'));
5852 Any
: constant Entity_Id
:=
5853 Make_Defining_Identifier
5854 (Loc
, New_Internal_Name
('A'));
5858 Make_Function_Specification
(Loc
,
5859 Defining_Unit_Name
=>
5861 Parameter_Specifications
=> New_List
(
5862 Make_Parameter_Specification
(Loc
,
5863 Defining_Identifier
=>
5866 New_Occurrence_Of
(RACW_Type
, Loc
))),
5867 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
5869 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5870 -- entity in the declaration spec, not in the body spec.
5872 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5874 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5875 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_To_Any
);
5877 if No
(Body_Decls
) then
5883 -- R : constant Object_Ref :=
5889 -- RPC_Receiver'Access);
5893 Make_Object_Declaration
(Loc
,
5894 Defining_Identifier
=> Reference
,
5895 Constant_Present
=> True,
5896 Object_Definition
=>
5897 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5899 Make_Function_Call
(Loc
,
5900 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
5901 Parameter_Associations
=> New_List
(
5902 Unchecked_Convert_To
(RTE
(RE_Address
),
5903 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5904 Make_String_Literal
(Loc
,
5905 Strval
=> Full_Qualified_Name
5906 (Etype
(Designated_Type
(RACW_Type
)))),
5907 Build_Stub_Tag
(Loc
, RACW_Type
),
5908 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5909 Make_Attribute_Reference
(Loc
,
5912 (Defining_Identifier
5913 (Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5914 Attribute_Name
=> Name_Access
)))),
5916 Make_Object_Declaration
(Loc
,
5917 Defining_Identifier
=> Any
,
5918 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
5922 -- Any := TA_ObjRef (Reference);
5923 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
5926 Statements
:= New_List
(
5927 Make_Assignment_Statement
(Loc
,
5928 Name
=> New_Occurrence_Of
(Any
, Loc
),
5930 Make_Function_Call
(Loc
,
5931 Name
=> New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
5932 Parameter_Associations
=> New_List
(
5933 New_Occurrence_Of
(Reference
, Loc
)))),
5935 Make_Procedure_Call_Statement
(Loc
,
5936 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
5937 Parameter_Associations
=> New_List
(
5938 New_Occurrence_Of
(Any
, Loc
),
5939 Make_Selected_Component
(Loc
,
5941 Defining_Identifier
(
5942 Stub_Elements
.RPC_Receiver_Decl
),
5943 Selector_Name
=> Name_Obj_TypeCode
))),
5945 Make_Simple_Return_Statement
(Loc
,
5946 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
5949 Make_Subprogram_Body
(Loc
,
5950 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
5951 Declarations
=> Decls
,
5952 Handled_Statement_Sequence
=>
5953 Make_Handled_Sequence_Of_Statements
(Loc
,
5954 Statements
=> Statements
));
5955 Append_To
(Body_Decls
, Func_Body
);
5956 end Add_RACW_To_Any
;
5958 -----------------------
5959 -- Add_RACW_TypeCode --
5960 -----------------------
5962 procedure Add_RACW_TypeCode
5963 (Designated_Type
: Entity_Id
;
5964 RACW_Type
: Entity_Id
;
5965 Body_Decls
: List_Id
)
5967 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5969 Fnam
: constant Entity_Id
:=
5970 Make_Defining_Identifier
(Loc
,
5971 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'Y'));
5973 Stub_Elements
: constant Stub_Structure
:=
5974 Stubs_Table
.Get
(Designated_Type
);
5975 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5977 Func_Spec
: Node_Id
;
5978 Func_Decl
: Node_Id
;
5979 Func_Body
: Node_Id
;
5983 -- The spec for this subprogram has a dummy 'access RACW' argument,
5984 -- which serves only for overloading purposes.
5987 Make_Function_Specification
(Loc
,
5988 Defining_Unit_Name
=> Fnam
,
5989 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
5991 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5992 -- entity in the declaration spec, not those of the body spec.
5994 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5995 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5996 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_TypeCode
);
5998 if No
(Body_Decls
) then
6003 Make_Subprogram_Body
(Loc
,
6004 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
6005 Declarations
=> Empty_List
,
6006 Handled_Statement_Sequence
=>
6007 Make_Handled_Sequence_Of_Statements
(Loc
,
6008 Statements
=> New_List
(
6009 Make_Simple_Return_Statement
(Loc
,
6011 Make_Selected_Component
(Loc
,
6014 (Stub_Elements
.RPC_Receiver_Decl
),
6015 Selector_Name
=> Name_Obj_TypeCode
)))));
6017 Append_To
(Body_Decls
, Func_Body
);
6018 end Add_RACW_TypeCode
;
6020 ------------------------------
6021 -- Add_RACW_Write_Attribute --
6022 ------------------------------
6024 procedure Add_RACW_Write_Attribute
6025 (RACW_Type
: Entity_Id
;
6026 Stub_Type
: Entity_Id
;
6027 Stub_Type_Access
: Entity_Id
;
6028 Body_Decls
: List_Id
)
6030 pragma Warnings
(Off
);
6031 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
6032 pragma Warnings
(On
);
6034 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
6036 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
6038 Stub_Elements
: constant Stub_Structure
:=
6039 Get_Stub_Elements
(RACW_Type
);
6041 Body_Node
: Node_Id
;
6042 Proc_Decl
: Node_Id
;
6043 Attr_Decl
: Node_Id
;
6045 Statements
: constant List_Id
:= New_List
;
6046 Pnam
: constant Entity_Id
:=
6047 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
6049 function Stream_Parameter
return Node_Id
;
6050 function Object
return Node_Id
;
6051 -- Functions to create occurrences of the formal parameter names
6057 function Object
return Node_Id
is
6059 return Make_Identifier
(Loc
, Name_V
);
6062 ----------------------
6063 -- Stream_Parameter --
6064 ----------------------
6066 function Stream_Parameter
return Node_Id
is
6068 return Make_Identifier
(Loc
, Name_S
);
6069 end Stream_Parameter
;
6071 -- Start of processing for Add_RACW_Write_Attribute
6074 Build_Stream_Procedure
6075 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> False);
6078 Make_Subprogram_Declaration
(Loc
,
6079 Copy_Specification
(Loc
, Specification
(Body_Node
)));
6082 Make_Attribute_Definition_Clause
(Loc
,
6083 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
6084 Chars
=> Name_Write
,
6087 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
6089 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
6090 Insert_After
(Proc_Decl
, Attr_Decl
);
6092 if No
(Body_Decls
) then
6096 Append_To
(Statements
,
6097 Pack_Node_Into_Stream_Access
(Loc
,
6098 Stream
=> Stream_Parameter
,
6100 Make_Function_Call
(Loc
,
6101 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
6102 Parameter_Associations
=> New_List
(
6103 Unchecked_Convert_To
(RTE
(RE_Address
), Object
),
6104 Make_String_Literal
(Loc
,
6105 Strval
=> Full_Qualified_Name
6106 (Etype
(Designated_Type
(RACW_Type
)))),
6107 Build_Stub_Tag
(Loc
, RACW_Type
),
6108 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
6109 Make_Attribute_Reference
(Loc
,
6112 (Defining_Identifier
6113 (Stub_Elements
.RPC_Receiver_Decl
), Loc
),
6114 Attribute_Name
=> Name_Access
))),
6116 Etyp
=> RTE
(RE_Object_Ref
)));
6118 Append_To
(Body_Decls
, Body_Node
);
6119 end Add_RACW_Write_Attribute
;
6121 -----------------------
6122 -- Add_RAST_Features --
6123 -----------------------
6125 procedure Add_RAST_Features
6126 (Vis_Decl
: Node_Id
;
6127 RAS_Type
: Entity_Id
)
6130 Add_RAS_Access_TSS
(Vis_Decl
);
6132 Add_RAS_From_Any
(RAS_Type
);
6133 Add_RAS_TypeCode
(RAS_Type
);
6135 -- To_Any uses TypeCode, and therefore needs to be generated last
6137 Add_RAS_To_Any
(RAS_Type
);
6138 end Add_RAST_Features
;
6140 ------------------------
6141 -- Add_RAS_Access_TSS --
6142 ------------------------
6144 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
6145 Loc
: constant Source_Ptr
:= Sloc
(N
);
6147 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
6148 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
6149 -- Ras_Type is the access to subprogram type; Fat_Type is the
6150 -- corresponding record type.
6152 RACW_Type
: constant Entity_Id
:=
6153 Underlying_RACW_Type
(Ras_Type
);
6155 Stub_Elements
: constant Stub_Structure
:=
6156 Get_Stub_Elements
(RACW_Type
);
6158 Proc
: constant Entity_Id
:=
6159 Make_Defining_Identifier
(Loc
,
6160 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
6162 Proc_Spec
: Node_Id
;
6164 -- Formal parameters
6166 Package_Name
: constant Entity_Id
:=
6167 Make_Defining_Identifier
(Loc
,
6172 Subp_Id
: constant Entity_Id
:=
6173 Make_Defining_Identifier
(Loc
,
6176 -- Target subprogram
6178 Asynch_P
: constant Entity_Id
:=
6179 Make_Defining_Identifier
(Loc
,
6180 Chars
=> Name_Asynchronous
);
6181 -- Is the procedure to which the 'Access applies asynchronous?
6183 All_Calls_Remote
: constant Entity_Id
:=
6184 Make_Defining_Identifier
(Loc
,
6185 Chars
=> Name_All_Calls_Remote
);
6186 -- True if an All_Calls_Remote pragma applies to the RCI unit
6187 -- that contains the subprogram.
6189 -- Common local variables
6191 Proc_Decls
: List_Id
;
6192 Proc_Statements
: List_Id
;
6194 Subp_Ref
: constant Entity_Id
:=
6195 Make_Defining_Identifier
(Loc
, Name_R
);
6196 -- Reference that designates the target subprogram (returned
6197 -- by Get_RAS_Info).
6199 Is_Local
: constant Entity_Id
:=
6200 Make_Defining_Identifier
(Loc
, Name_L
);
6201 Local_Addr
: constant Entity_Id
:=
6202 Make_Defining_Identifier
(Loc
, Name_A
);
6203 -- For the call to Get_Local_Address
6205 -- Additional local variables for the remote case
6207 Local_Stub
: constant Entity_Id
:=
6208 Make_Defining_Identifier
(Loc
,
6209 Chars
=> New_Internal_Name
('L'));
6211 Stub_Ptr
: constant Entity_Id
:=
6212 Make_Defining_Identifier
(Loc
,
6213 Chars
=> New_Internal_Name
('S'));
6216 (Field_Name
: Name_Id
;
6217 Value
: Node_Id
) return Node_Id
;
6218 -- Construct an assignment that sets the named component in the
6226 (Field_Name
: Name_Id
;
6227 Value
: Node_Id
) return Node_Id
6231 Make_Assignment_Statement
(Loc
,
6233 Make_Selected_Component
(Loc
,
6235 Selector_Name
=> Field_Name
),
6236 Expression
=> Value
);
6239 -- Start of processing for Add_RAS_Access_TSS
6242 Proc_Decls
:= New_List
(
6244 -- Common declarations
6246 Make_Object_Declaration
(Loc
,
6247 Defining_Identifier
=> Subp_Ref
,
6248 Object_Definition
=>
6249 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
6251 Make_Object_Declaration
(Loc
,
6252 Defining_Identifier
=> Is_Local
,
6253 Object_Definition
=>
6254 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6256 Make_Object_Declaration
(Loc
,
6257 Defining_Identifier
=> Local_Addr
,
6258 Object_Definition
=>
6259 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
6261 Make_Object_Declaration
(Loc
,
6262 Defining_Identifier
=> Local_Stub
,
6263 Aliased_Present
=> True,
6264 Object_Definition
=>
6265 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
6267 Make_Object_Declaration
(Loc
,
6268 Defining_Identifier
=> Stub_Ptr
,
6269 Object_Definition
=>
6270 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
6272 Make_Attribute_Reference
(Loc
,
6273 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
6274 Attribute_Name
=> Name_Unchecked_Access
)));
6276 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
6277 -- Build_Get_Unique_RP_Call needs this information
6279 -- Get_RAS_Info (Pkg, Subp, R);
6280 -- Obtain a reference to the target subprogram
6282 Proc_Statements
:= New_List
(
6283 Make_Procedure_Call_Statement
(Loc
,
6284 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
6285 Parameter_Associations
=> New_List
(
6286 New_Occurrence_Of
(Package_Name
, Loc
),
6287 New_Occurrence_Of
(Subp_Id
, Loc
),
6288 New_Occurrence_Of
(Subp_Ref
, Loc
))),
6290 -- Get_Local_Address (R, L, A);
6291 -- Determine whether the subprogram is local (L), and if so
6292 -- obtain the local address of its proxy (A).
6294 Make_Procedure_Call_Statement
(Loc
,
6295 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6296 Parameter_Associations
=> New_List
(
6297 New_Occurrence_Of
(Subp_Ref
, Loc
),
6298 New_Occurrence_Of
(Is_Local
, Loc
),
6299 New_Occurrence_Of
(Local_Addr
, Loc
))));
6301 -- Note: Here we assume that the Fat_Type is a record containing just
6302 -- an access to a proxy or stub object.
6304 Append_To
(Proc_Statements
,
6308 Make_Implicit_If_Statement
(N
,
6309 Condition
=> New_Occurrence_Of
(Is_Local
, Loc
),
6311 Then_Statements
=> New_List
(
6313 -- if A.Target = null then
6315 Make_Implicit_If_Statement
(N
,
6318 Make_Selected_Component
(Loc
,
6320 Unchecked_Convert_To
6321 (RTE
(RE_RAS_Proxy_Type_Access
),
6322 New_Occurrence_Of
(Local_Addr
, Loc
)),
6323 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)),
6326 Then_Statements
=> New_List
(
6328 -- A.Target := Entity_Of (Ref);
6330 Make_Assignment_Statement
(Loc
,
6332 Make_Selected_Component
(Loc
,
6334 Unchecked_Convert_To
6335 (RTE
(RE_RAS_Proxy_Type_Access
),
6336 New_Occurrence_Of
(Local_Addr
, Loc
)),
6337 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)),
6339 Make_Function_Call
(Loc
,
6340 Name
=> New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6341 Parameter_Associations
=> New_List
(
6342 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6344 -- Inc_Usage (A.Target);
6346 Make_Procedure_Call_Statement
(Loc
,
6347 Name
=> New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6348 Parameter_Associations
=> New_List
(
6349 Make_Selected_Component
(Loc
,
6351 Unchecked_Convert_To
6352 (RTE
(RE_RAS_Proxy_Type_Access
),
6353 New_Occurrence_Of
(Local_Addr
, Loc
)),
6355 Make_Identifier
(Loc
, Name_Target
)))))),
6358 -- if not All_Calls_Remote then
6359 -- return Fat_Type!(A);
6362 Make_Implicit_If_Statement
(N
,
6366 New_Occurrence_Of
(All_Calls_Remote
, Loc
)),
6368 Then_Statements
=> New_List
(
6369 Make_Simple_Return_Statement
(Loc
,
6371 Unchecked_Convert_To
6372 (Fat_Type
, New_Occurrence_Of
(Local_Addr
, Loc
))))))));
6374 Append_List_To
(Proc_Statements
, New_List
(
6376 -- Stub.Target := Entity_Of (Ref);
6378 Set_Field
(Name_Target
,
6379 Make_Function_Call
(Loc
,
6380 Name
=> New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6381 Parameter_Associations
=> New_List
(
6382 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6384 -- Inc_Usage (Stub.Target);
6386 Make_Procedure_Call_Statement
(Loc
,
6387 Name
=> New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6388 Parameter_Associations
=> New_List
(
6389 Make_Selected_Component
(Loc
,
6391 Selector_Name
=> Name_Target
))),
6393 -- E.4.1(9) A remote call is asynchronous if it is a call to
6394 -- a procedure, or a call through a value of an access-to-procedure
6395 -- type, to which a pragma Asynchronous applies.
6397 -- Parameter Asynch_P is true when the procedure is asynchronous;
6398 -- Expression Asynch_T is true when the type is asynchronous.
6400 Set_Field
(Name_Asynchronous
,
6402 Left_Opnd
=> New_Occurrence_Of
(Asynch_P
, Loc
),
6405 (Boolean_Literals
(Is_Asynchronous
(Ras_Type
)), Loc
)))));
6407 Append_List_To
(Proc_Statements
,
6408 Build_Get_Unique_RP_Call
(Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
6410 Append_To
(Proc_Statements
,
6411 Make_Simple_Return_Statement
(Loc
,
6413 Unchecked_Convert_To
(Fat_Type
,
6414 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
6417 Make_Function_Specification
(Loc
,
6418 Defining_Unit_Name
=> Proc
,
6419 Parameter_Specifications
=> New_List
(
6420 Make_Parameter_Specification
(Loc
,
6421 Defining_Identifier
=> Package_Name
,
6423 New_Occurrence_Of
(Standard_String
, Loc
)),
6425 Make_Parameter_Specification
(Loc
,
6426 Defining_Identifier
=> Subp_Id
,
6428 New_Occurrence_Of
(Standard_String
, Loc
)),
6430 Make_Parameter_Specification
(Loc
,
6431 Defining_Identifier
=> Asynch_P
,
6433 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6435 Make_Parameter_Specification
(Loc
,
6436 Defining_Identifier
=> All_Calls_Remote
,
6438 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
6440 Result_Definition
=>
6441 New_Occurrence_Of
(Fat_Type
, Loc
));
6443 -- Set the kind and return type of the function to prevent
6444 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6446 Set_Ekind
(Proc
, E_Function
);
6447 Set_Etype
(Proc
, Fat_Type
);
6450 Make_Subprogram_Body
(Loc
,
6451 Specification
=> Proc_Spec
,
6452 Declarations
=> Proc_Decls
,
6453 Handled_Statement_Sequence
=>
6454 Make_Handled_Sequence_Of_Statements
(Loc
,
6455 Statements
=> Proc_Statements
)));
6457 Set_TSS
(Fat_Type
, Proc
);
6458 end Add_RAS_Access_TSS
;
6460 ----------------------
6461 -- Add_RAS_From_Any --
6462 ----------------------
6464 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
) is
6465 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6467 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6468 Make_TSS_Name
(RAS_Type
, TSS_From_Any
));
6470 Func_Spec
: Node_Id
;
6472 Statements
: List_Id
;
6474 Any_Parameter
: constant Entity_Id
:=
6475 Make_Defining_Identifier
(Loc
, Name_A
);
6478 Statements
:= New_List
(
6479 Make_Simple_Return_Statement
(Loc
,
6481 Make_Aggregate
(Loc
,
6482 Component_Associations
=> New_List
(
6483 Make_Component_Association
(Loc
,
6484 Choices
=> New_List
(
6485 Make_Identifier
(Loc
, Name_Ras
)),
6487 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
6488 Underlying_RACW_Type
(RAS_Type
),
6489 New_Occurrence_Of
(Any_Parameter
, Loc
),
6493 Make_Function_Specification
(Loc
,
6494 Defining_Unit_Name
=> Fnam
,
6495 Parameter_Specifications
=> New_List
(
6496 Make_Parameter_Specification
(Loc
,
6497 Defining_Identifier
=> Any_Parameter
,
6498 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
6499 Result_Definition
=> New_Occurrence_Of
(RAS_Type
, Loc
));
6502 Make_Subprogram_Body
(Loc
,
6503 Specification
=> Func_Spec
,
6504 Declarations
=> No_List
,
6505 Handled_Statement_Sequence
=>
6506 Make_Handled_Sequence_Of_Statements
(Loc
,
6507 Statements
=> Statements
)));
6508 Set_TSS
(RAS_Type
, Fnam
);
6509 end Add_RAS_From_Any
;
6511 --------------------
6512 -- Add_RAS_To_Any --
6513 --------------------
6515 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
) is
6516 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6518 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6519 Make_TSS_Name
(RAS_Type
, TSS_To_Any
));
6522 Statements
: List_Id
;
6524 Func_Spec
: Node_Id
;
6526 Any
: constant Entity_Id
:=
6527 Make_Defining_Identifier
(Loc
,
6528 Chars
=> New_Internal_Name
('A'));
6529 RAS_Parameter
: constant Entity_Id
:=
6530 Make_Defining_Identifier
(Loc
,
6531 Chars
=> New_Internal_Name
('R'));
6532 RACW_Parameter
: constant Node_Id
:=
6533 Make_Selected_Component
(Loc
,
6534 Prefix
=> RAS_Parameter
,
6535 Selector_Name
=> Name_Ras
);
6538 -- Object declarations
6540 Set_Etype
(RACW_Parameter
, Underlying_RACW_Type
(RAS_Type
));
6542 Make_Object_Declaration
(Loc
,
6543 Defining_Identifier
=> Any
,
6544 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
6546 PolyORB_Support
.Helpers
.Build_To_Any_Call
6547 (RACW_Parameter
, No_List
)));
6549 Statements
:= New_List
(
6550 Make_Procedure_Call_Statement
(Loc
,
6551 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
6552 Parameter_Associations
=> New_List
(
6553 New_Occurrence_Of
(Any
, Loc
),
6554 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
6557 Make_Simple_Return_Statement
(Loc
,
6558 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
6561 Make_Function_Specification
(Loc
,
6562 Defining_Unit_Name
=> Fnam
,
6563 Parameter_Specifications
=> New_List
(
6564 Make_Parameter_Specification
(Loc
,
6565 Defining_Identifier
=> RAS_Parameter
,
6566 Parameter_Type
=> New_Occurrence_Of
(RAS_Type
, Loc
))),
6567 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
6570 Make_Subprogram_Body
(Loc
,
6571 Specification
=> Func_Spec
,
6572 Declarations
=> Decls
,
6573 Handled_Statement_Sequence
=>
6574 Make_Handled_Sequence_Of_Statements
(Loc
,
6575 Statements
=> Statements
)));
6576 Set_TSS
(RAS_Type
, Fnam
);
6579 ----------------------
6580 -- Add_RAS_TypeCode --
6581 ----------------------
6583 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
) is
6584 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6586 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6587 Make_TSS_Name
(RAS_Type
, TSS_TypeCode
));
6589 Func_Spec
: Node_Id
;
6590 Decls
: constant List_Id
:= New_List
;
6591 Name_String
: String_Id
;
6592 Repo_Id_String
: String_Id
;
6596 Make_Function_Specification
(Loc
,
6597 Defining_Unit_Name
=> Fnam
,
6598 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6600 PolyORB_Support
.Helpers
.Build_Name_And_Repository_Id
6601 (RAS_Type
, Name_Str
=> Name_String
, Repo_Id_Str
=> Repo_Id_String
);
6604 Make_Subprogram_Body
(Loc
,
6605 Specification
=> Func_Spec
,
6606 Declarations
=> Decls
,
6607 Handled_Statement_Sequence
=>
6608 Make_Handled_Sequence_Of_Statements
(Loc
,
6609 Statements
=> New_List
(
6610 Make_Simple_Return_Statement
(Loc
,
6612 Make_Function_Call
(Loc
,
6613 Name
=> New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
6614 Parameter_Associations
=> New_List
(
6615 New_Occurrence_Of
(RTE
(RE_TC_Object
), Loc
),
6616 Make_Aggregate
(Loc
,
6619 Make_Function_Call
(Loc
,
6622 (RTE
(RE_TA_String
), Loc
),
6623 Parameter_Associations
=> New_List
(
6624 Make_String_Literal
(Loc
, Name_String
))),
6625 Make_Function_Call
(Loc
,
6628 (RTE
(RE_TA_String
), Loc
),
6629 Parameter_Associations
=> New_List
(
6630 Make_String_Literal
(Loc
,
6631 Strval
=> Repo_Id_String
))))))))))));
6632 Set_TSS
(RAS_Type
, Fnam
);
6633 end Add_RAS_TypeCode
;
6635 -----------------------------------------
6636 -- Add_Receiving_Stubs_To_Declarations --
6637 -----------------------------------------
6639 procedure Add_Receiving_Stubs_To_Declarations
6640 (Pkg_Spec
: Node_Id
;
6644 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
6646 Pkg_RPC_Receiver
: constant Entity_Id
:=
6647 Make_Defining_Identifier
(Loc
,
6648 New_Internal_Name
('H'));
6649 Pkg_RPC_Receiver_Object
: Node_Id
;
6650 Pkg_RPC_Receiver_Body
: Node_Id
;
6651 Pkg_RPC_Receiver_Decls
: List_Id
;
6652 Pkg_RPC_Receiver_Statements
: List_Id
;
6654 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
6655 -- A Pkg_RPC_Receiver is built to decode the request
6658 -- Request object received from neutral layer
6660 Subp_Id
: Entity_Id
;
6661 -- Subprogram identifier as received from the neutral
6662 -- distribution core.
6664 Subp_Index
: Entity_Id
;
6665 -- Internal index as determined by matching either the method name
6666 -- from the request structure, or the local subprogram address (in
6669 Is_Local
: constant Entity_Id
:=
6670 Make_Defining_Identifier
(Loc
,
6671 Chars
=> New_Internal_Name
('L'));
6673 Local_Address
: constant Entity_Id
:=
6674 Make_Defining_Identifier
(Loc
,
6675 Chars
=> New_Internal_Name
('A'));
6676 -- Address of a local subprogram designated by a reference
6677 -- corresponding to a RAS.
6679 Dispatch_On_Address
: constant List_Id
:= New_List
;
6680 Dispatch_On_Name
: constant List_Id
:= New_List
;
6682 Current_Declaration
: Node_Id
;
6683 Current_Stubs
: Node_Id
;
6684 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
6686 Subp_Info_Array
: constant Entity_Id
:=
6687 Make_Defining_Identifier
(Loc
,
6688 Chars
=> New_Internal_Name
('I'));
6690 Subp_Info_List
: constant List_Id
:= New_List
;
6692 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
6694 All_Calls_Remote_E
: Entity_Id
;
6696 procedure Append_Stubs_To
6697 (RPC_Receiver_Cases
: List_Id
;
6698 Declaration
: Node_Id
;
6701 Subp_Dist_Name
: Entity_Id
;
6702 Subp_Proxy_Addr
: Entity_Id
);
6703 -- Add one case to the specified RPC receiver case list associating
6704 -- Subprogram_Number with the subprogram declared by Declaration, for
6705 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6706 -- subprogram index. Subp_Dist_Name is the string used to call the
6707 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6708 -- object, used in the context of calls through remote
6709 -- access-to-subprogram types.
6711 ---------------------
6712 -- Append_Stubs_To --
6713 ---------------------
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
)
6723 Case_Stmts
: List_Id
;
6725 Case_Stmts
:= New_List
(
6726 Make_Procedure_Call_Statement
(Loc
,
6729 Defining_Entity
(Stubs
), Loc
),
6730 Parameter_Associations
=>
6731 New_List
(New_Occurrence_Of
(Request
, Loc
))));
6733 if Nkind
(Specification
(Declaration
)) = N_Function_Specification
6735 Is_Asynchronous
(Defining_Entity
(Specification
(Declaration
)))
6737 Append_To
(Case_Stmts
, Make_Simple_Return_Statement
(Loc
));
6740 Append_To
(RPC_Receiver_Cases
,
6741 Make_Case_Statement_Alternative
(Loc
,
6743 New_List
(Make_Integer_Literal
(Loc
, Subp_Number
)),
6744 Statements
=> Case_Stmts
));
6746 Append_To
(Dispatch_On_Name
,
6747 Make_Elsif_Part
(Loc
,
6749 Make_Function_Call
(Loc
,
6751 New_Occurrence_Of
(RTE
(RE_Caseless_String_Eq
), Loc
),
6752 Parameter_Associations
=> New_List
(
6753 New_Occurrence_Of
(Subp_Id
, Loc
),
6754 New_Occurrence_Of
(Subp_Dist_Name
, Loc
))),
6756 Then_Statements
=> New_List
(
6757 Make_Assignment_Statement
(Loc
,
6758 New_Occurrence_Of
(Subp_Index
, Loc
),
6759 Make_Integer_Literal
(Loc
, Subp_Number
)))));
6761 Append_To
(Dispatch_On_Address
,
6762 Make_Elsif_Part
(Loc
,
6765 Left_Opnd
=> New_Occurrence_Of
(Local_Address
, Loc
),
6766 Right_Opnd
=> New_Occurrence_Of
(Subp_Proxy_Addr
, Loc
)),
6768 Then_Statements
=> New_List
(
6769 Make_Assignment_Statement
(Loc
,
6770 New_Occurrence_Of
(Subp_Index
, Loc
),
6771 Make_Integer_Literal
(Loc
, Subp_Number
)))));
6772 end Append_Stubs_To
;
6774 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6777 -- Building receiving stubs consist in several operations:
6779 -- - a package RPC receiver must be built. This subprogram
6780 -- will get a Subprogram_Id from the incoming stream
6781 -- and will dispatch the call to the right subprogram;
6783 -- - a receiving stub for each subprogram visible in the package
6784 -- spec. This stub will read all the parameters from the stream,
6785 -- and put the result as well as the exception occurrence in the
6788 -- - a dummy package with an empty spec and a body made of an
6789 -- elaboration part, whose job is to register the receiving
6790 -- part of this RCI package on the name server. This is done
6791 -- by calling System.Partition_Interface.Register_Receiving_Stub.
6793 Build_RPC_Receiver_Body
(
6794 RPC_Receiver
=> Pkg_RPC_Receiver
,
6797 Subp_Index
=> Subp_Index
,
6798 Stmts
=> Pkg_RPC_Receiver_Statements
,
6799 Decl
=> Pkg_RPC_Receiver_Body
);
6800 Pkg_RPC_Receiver_Decls
:= Declarations
(Pkg_RPC_Receiver_Body
);
6802 -- Extract local address information from the target reference:
6803 -- if non-null, that means that this is a reference that denotes
6804 -- one particular operation, and hence that the operation name
6805 -- must not be taken into account for dispatching.
6807 Append_To
(Pkg_RPC_Receiver_Decls
,
6808 Make_Object_Declaration
(Loc
,
6809 Defining_Identifier
=> Is_Local
,
6810 Object_Definition
=>
6811 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
6813 Append_To
(Pkg_RPC_Receiver_Decls
,
6814 Make_Object_Declaration
(Loc
,
6815 Defining_Identifier
=> Local_Address
,
6816 Object_Definition
=>
6817 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6819 Append_To
(Pkg_RPC_Receiver_Statements
,
6820 Make_Procedure_Call_Statement
(Loc
,
6821 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6822 Parameter_Associations
=> New_List
(
6823 Make_Selected_Component
(Loc
,
6825 Selector_Name
=> Name_Target
),
6826 New_Occurrence_Of
(Is_Local
, Loc
),
6827 New_Occurrence_Of
(Local_Address
, Loc
))));
6829 -- For each subprogram, the receiving stub will be built and a
6830 -- case statement will be made on the Subprogram_Id to dispatch
6831 -- to the right subprogram.
6833 All_Calls_Remote_E
:= Boolean_Literals
(
6834 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
6836 Overload_Counter_Table
.Reset
;
6837 Reserve_NamingContext_Methods
;
6839 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
6840 while Present
(Current_Declaration
) loop
6841 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
6842 and then Comes_From_Source
(Current_Declaration
)
6845 Loc
: constant Source_Ptr
:= Sloc
(Current_Declaration
);
6846 -- While specifically processing Current_Declaration, use
6847 -- its Sloc as the location of all generated nodes.
6849 Subp_Def
: constant Entity_Id
:=
6851 (Specification
(Current_Declaration
));
6853 Subp_Val
: String_Id
;
6855 Subp_Dist_Name
: constant Entity_Id
:=
6856 Make_Defining_Identifier
(Loc
,
6859 (Related_Id
=> Chars
(Subp_Def
),
6861 Suffix_Index
=> -1));
6863 Proxy_Object_Addr
: Entity_Id
;
6866 -- Build receiving stub
6869 Build_Subprogram_Receiving_Stubs
6870 (Vis_Decl
=> Current_Declaration
,
6872 Nkind
(Specification
(Current_Declaration
)) =
6873 N_Procedure_Specification
6874 and then Is_Asynchronous
(Subp_Def
));
6876 Append_To
(Decls
, Current_Stubs
);
6877 Analyze
(Current_Stubs
);
6881 Add_RAS_Proxy_And_Analyze
(Decls
,
6882 Vis_Decl
=> Current_Declaration
,
6883 All_Calls_Remote_E
=> All_Calls_Remote_E
,
6884 Proxy_Object_Addr
=> Proxy_Object_Addr
);
6886 -- Compute distribution identifier
6888 Assign_Subprogram_Identifier
6890 Current_Subprogram_Number
,
6894 (Current_Subprogram_Number
= Get_Subprogram_Id
(Subp_Def
));
6897 Make_Object_Declaration
(Loc
,
6898 Defining_Identifier
=> Subp_Dist_Name
,
6899 Constant_Present
=> True,
6900 Object_Definition
=>
6901 New_Occurrence_Of
(Standard_String
, Loc
),
6903 Make_String_Literal
(Loc
, Subp_Val
)));
6904 Analyze
(Last
(Decls
));
6906 -- Add subprogram descriptor (RCI_Subp_Info) to the
6907 -- subprograms table for this receiver. The aggregate
6908 -- below must be kept consistent with the declaration
6909 -- of type RCI_Subp_Info in System.Partition_Interface.
6911 Append_To
(Subp_Info_List
,
6912 Make_Component_Association
(Loc
,
6913 Choices
=> New_List
(
6914 Make_Integer_Literal
(Loc
, Current_Subprogram_Number
)),
6917 Make_Aggregate
(Loc
,
6918 Expressions
=> New_List
(
6919 Make_Attribute_Reference
(Loc
,
6921 New_Occurrence_Of
(Subp_Dist_Name
, Loc
),
6922 Attribute_Name
=> Name_Address
),
6924 Make_Attribute_Reference
(Loc
,
6926 New_Occurrence_Of
(Subp_Dist_Name
, Loc
),
6927 Attribute_Name
=> Name_Length
),
6929 New_Occurrence_Of
(Proxy_Object_Addr
, Loc
)))));
6931 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
6932 Declaration
=> Current_Declaration
,
6933 Stubs
=> Current_Stubs
,
6934 Subp_Number
=> Current_Subprogram_Number
,
6935 Subp_Dist_Name
=> Subp_Dist_Name
,
6936 Subp_Proxy_Addr
=> Proxy_Object_Addr
);
6939 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
6942 Next
(Current_Declaration
);
6946 Make_Object_Declaration
(Loc
,
6947 Defining_Identifier
=> Subp_Info_Array
,
6948 Constant_Present
=> True,
6949 Aliased_Present
=> True,
6950 Object_Definition
=>
6951 Make_Subtype_Indication
(Loc
,
6953 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
6955 Make_Index_Or_Discriminant_Constraint
(Loc
,
6959 Make_Integer_Literal
(Loc
,
6960 Intval
=> First_RCI_Subprogram_Id
),
6962 Make_Integer_Literal
(Loc
,
6964 First_RCI_Subprogram_Id
6965 + List_Length
(Subp_Info_List
) - 1)))))));
6967 if Present
(First
(Subp_Info_List
)) then
6968 Set_Expression
(Last
(Decls
),
6969 Make_Aggregate
(Loc
,
6970 Component_Associations
=> Subp_Info_List
));
6972 -- Generate the dispatch statement to determine the subprogram id
6973 -- of the called subprogram.
6975 -- We first test whether the reference that was used to make the
6976 -- call was the base RCI reference (in which case Local_Address is
6977 -- zero, and the method identifier from the request must be used
6978 -- to determine which subprogram is called) or a reference
6979 -- identifying one particular subprogram (in which case
6980 -- Local_Address is the address of that subprogram, and the
6981 -- method name from the request is ignored). The latter occurs
6982 -- for the case of a call through a remote access-to-subprogram.
6984 -- In each case, cascaded elsifs are used to determine the proper
6985 -- subprogram index. Using hash tables might be more efficient.
6987 Append_To
(Pkg_RPC_Receiver_Statements
,
6988 Make_Implicit_If_Statement
(Pkg_Spec
,
6991 Left_Opnd
=> New_Occurrence_Of
(Local_Address
, Loc
),
6992 Right_Opnd
=> New_Occurrence_Of
6993 (RTE
(RE_Null_Address
), Loc
)),
6995 Then_Statements
=> New_List
(
6996 Make_Implicit_If_Statement
(Pkg_Spec
,
6997 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
6998 Then_Statements
=> New_List
(
6999 Make_Null_Statement
(Loc
)),
7000 Elsif_Parts
=> Dispatch_On_Address
)),
7002 Else_Statements
=> New_List
(
7003 Make_Implicit_If_Statement
(Pkg_Spec
,
7004 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
7005 Then_Statements
=> New_List
(Make_Null_Statement
(Loc
)),
7006 Elsif_Parts
=> Dispatch_On_Name
))));
7009 -- For a degenerate RCI with no visible subprograms,
7010 -- Subp_Info_List has zero length, and the declaration is for an
7011 -- empty array, in which case no initialization aggregate must be
7012 -- generated. We do not generate a Dispatch_Statement either.
7014 -- No initialization provided: remove CONSTANT so that the
7015 -- declaration is not an incomplete deferred constant.
7017 Set_Constant_Present
(Last
(Decls
), False);
7020 -- Analyze Subp_Info_Array declaration
7022 Analyze
(Last
(Decls
));
7024 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7025 -- rather than raising an exception since we do not want someone
7026 -- to crash a remote partition by sending invalid subprogram ids.
7027 -- This is consistent with the other parts of the case statement
7028 -- since even in presence of incorrect parameters in the stream,
7029 -- every exception will be caught and (if the subprogram is not an
7030 -- APC) put into the result stream and sent away.
7032 Append_To
(Pkg_RPC_Receiver_Cases
,
7033 Make_Case_Statement_Alternative
(Loc
,
7034 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7035 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
7037 Append_To
(Pkg_RPC_Receiver_Statements
,
7038 Make_Case_Statement
(Loc
,
7039 Expression
=> New_Occurrence_Of
(Subp_Index
, Loc
),
7040 Alternatives
=> Pkg_RPC_Receiver_Cases
));
7042 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7045 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
7046 Analyze
(Last
(Decls
));
7048 Pkg_RPC_Receiver_Object
:=
7049 Make_Object_Declaration
(Loc
,
7050 Defining_Identifier
=>
7051 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
7052 Aliased_Present
=> True,
7053 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7054 Append_To
(Decls
, Pkg_RPC_Receiver_Object
);
7055 Analyze
(Last
(Decls
));
7057 Get_Library_Unit_Name_String
(Pkg_Spec
);
7061 Append_To
(Register_Pkg_Actuals
,
7062 Make_String_Literal
(Loc
,
7063 Strval
=> String_From_Name_Buffer
));
7067 Append_To
(Register_Pkg_Actuals
,
7068 Make_Attribute_Reference
(Loc
,
7071 (Defining_Entity
(Pkg_Spec
), Loc
),
7072 Attribute_Name
=> Name_Version
));
7076 Append_To
(Register_Pkg_Actuals
,
7077 Make_Attribute_Reference
(Loc
,
7079 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
7080 Attribute_Name
=> Name_Access
));
7084 Append_To
(Register_Pkg_Actuals
,
7085 Make_Attribute_Reference
(Loc
,
7088 Defining_Identifier
(Pkg_RPC_Receiver_Object
), Loc
),
7089 Attribute_Name
=> Name_Access
));
7093 Append_To
(Register_Pkg_Actuals
,
7094 Make_Attribute_Reference
(Loc
,
7095 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
7096 Attribute_Name
=> Name_Address
));
7100 Append_To
(Register_Pkg_Actuals
,
7101 Make_Attribute_Reference
(Loc
,
7102 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
7103 Attribute_Name
=> Name_Length
));
7105 -- Is_All_Calls_Remote
7107 Append_To
(Register_Pkg_Actuals
,
7108 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
));
7113 Make_Procedure_Call_Statement
(Loc
,
7115 New_Occurrence_Of
(RTE
(RE_Register_Pkg_Receiving_Stub
), Loc
),
7116 Parameter_Associations
=> Register_Pkg_Actuals
));
7117 Analyze
(Last
(Stmts
));
7118 end Add_Receiving_Stubs_To_Declarations
;
7120 ---------------------------------
7121 -- Build_General_Calling_Stubs --
7122 ---------------------------------
7124 procedure Build_General_Calling_Stubs
7126 Statements
: List_Id
;
7127 Target_Object
: Node_Id
;
7128 Subprogram_Id
: Node_Id
;
7129 Asynchronous
: Node_Id
:= Empty
;
7130 Is_Known_Asynchronous
: Boolean := False;
7131 Is_Known_Non_Asynchronous
: Boolean := False;
7132 Is_Function
: Boolean;
7134 Stub_Type
: Entity_Id
:= Empty
;
7135 RACW_Type
: Entity_Id
:= Empty
;
7138 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
7140 Arguments
: Node_Id
;
7141 -- Name of the named values list used to transmit parameters
7142 -- to the remote package
7145 -- The request object constructed by these stubs
7148 -- Name of the result named value (in non-APC cases) which get the
7149 -- result of the remote subprogram.
7151 Result_TC
: Node_Id
;
7152 -- Typecode expression for the result of the request (void
7153 -- typecode for procedures).
7155 Exception_Return_Parameter
: Node_Id
;
7156 -- Name of the parameter which will hold the exception sent by the
7157 -- remote subprogram.
7159 Current_Parameter
: Node_Id
;
7160 -- Current parameter being handled
7162 Ordered_Parameters_List
: constant List_Id
:=
7163 Build_Ordered_Parameters_List
(Spec
);
7165 Asynchronous_P
: Node_Id
;
7166 -- A Boolean expression indicating whether this call is asynchronous
7168 Asynchronous_Statements
: List_Id
:= No_List
;
7169 Non_Asynchronous_Statements
: List_Id
:= No_List
;
7170 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7172 Extra_Formal_Statements
: constant List_Id
:= New_List
;
7173 -- List of statements for extra formal parameters. It will appear
7174 -- after the regular statements for writing out parameters.
7176 After_Statements
: constant List_Id
:= New_List
;
7177 -- Statements to be executed after call returns (to assign
7178 -- in out or out parameter values).
7181 -- The type of the formal parameter being processed
7183 Is_Controlling_Formal
: Boolean;
7184 Is_First_Controlling_Formal
: Boolean;
7185 First_Controlling_Formal_Seen
: Boolean := False;
7186 -- Controlling formal parameters of distributed object primitives
7187 -- require special handling, and the first such parameter needs even
7188 -- more special handling.
7191 -- ??? document general form of stub subprograms for the PolyORB case
7192 Request
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
7195 Make_Object_Declaration
(Loc
,
7196 Defining_Identifier
=> Request
,
7197 Aliased_Present
=> False,
7198 Object_Definition
=>
7199 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
)));
7202 Make_Defining_Identifier
(Loc
,
7203 Chars
=> New_Internal_Name
('R'));
7207 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7208 (Loc
, Etype
(Result_Definition
(Spec
)), Decls
);
7210 Result_TC
:= New_Occurrence_Of
(RTE
(RE_TC_Void
), Loc
);
7214 Make_Object_Declaration
(Loc
,
7215 Defining_Identifier
=> Result
,
7216 Aliased_Present
=> False,
7217 Object_Definition
=>
7218 New_Occurrence_Of
(RTE
(RE_NamedValue
), Loc
),
7220 Make_Aggregate
(Loc
,
7221 Component_Associations
=> New_List
(
7222 Make_Component_Association
(Loc
,
7223 Choices
=> New_List
(Make_Identifier
(Loc
, Name_Name
)),
7225 New_Occurrence_Of
(RTE
(RE_Result_Name
), Loc
)),
7226 Make_Component_Association
(Loc
,
7227 Choices
=> New_List
(
7228 Make_Identifier
(Loc
, Name_Argument
)),
7230 Make_Function_Call
(Loc
,
7231 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7232 Parameter_Associations
=> New_List
(Result_TC
))),
7233 Make_Component_Association
(Loc
,
7234 Choices
=> New_List
(
7235 Make_Identifier
(Loc
, Name_Arg_Modes
)),
7236 Expression
=> Make_Integer_Literal
(Loc
, 0))))));
7238 if not Is_Known_Asynchronous
then
7239 Exception_Return_Parameter
:=
7240 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
7243 Make_Object_Declaration
(Loc
,
7244 Defining_Identifier
=> Exception_Return_Parameter
,
7245 Object_Definition
=>
7246 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
7249 Exception_Return_Parameter
:= Empty
;
7252 -- Initialize and fill in arguments list
7255 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
7256 Declare_Create_NVList
(Loc
, Arguments
, Decls
, Statements
);
7258 Current_Parameter
:= First
(Ordered_Parameters_List
);
7259 while Present
(Current_Parameter
) loop
7260 if Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
) then
7261 Is_Controlling_Formal
:= True;
7262 Is_First_Controlling_Formal
:=
7263 not First_Controlling_Formal_Seen
;
7264 First_Controlling_Formal_Seen
:= True;
7267 Is_Controlling_Formal
:= False;
7268 Is_First_Controlling_Formal
:= False;
7271 if Is_Controlling_Formal
then
7273 -- For a controlling formal argument, we send its reference
7278 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7281 -- The first controlling formal parameter is treated specially:
7282 -- it is used to set the target object of the call.
7284 if not Is_First_Controlling_Formal
then
7286 Constrained
: constant Boolean :=
7287 Is_Constrained
(Etyp
)
7288 or else Is_Elementary_Type
(Etyp
);
7290 Any
: constant Entity_Id
:=
7291 Make_Defining_Identifier
(Loc
,
7292 New_Internal_Name
('A'));
7294 Actual_Parameter
: Node_Id
:=
7296 Defining_Identifier
(
7297 Current_Parameter
), Loc
);
7302 if Is_Controlling_Formal
then
7304 -- For a controlling formal parameter (other than the
7305 -- first one), use the corresponding RACW. If the
7306 -- parameter is not an anonymous access parameter, that
7307 -- involves taking its 'Unrestricted_Access.
7309 if Nkind
(Parameter_Type
(Current_Parameter
))
7310 = N_Access_Definition
7312 Actual_Parameter
:= OK_Convert_To
7313 (Etyp
, Actual_Parameter
);
7315 Actual_Parameter
:= OK_Convert_To
(Etyp
,
7316 Make_Attribute_Reference
(Loc
,
7317 Prefix
=> Actual_Parameter
,
7318 Attribute_Name
=> Name_Unrestricted_Access
));
7323 if In_Present
(Current_Parameter
)
7324 or else not Out_Present
(Current_Parameter
)
7325 or else not Constrained
7326 or else Is_Controlling_Formal
7328 -- The parameter has an input value, is constrained at
7329 -- runtime by an input value, or is a controlling formal
7330 -- parameter (always passed as a reference) other than
7333 Expr
:= PolyORB_Support
.Helpers
.Build_To_Any_Call
7334 (Actual_Parameter
, Decls
);
7337 Expr
:= Make_Function_Call
(Loc
,
7338 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7339 Parameter_Associations
=> New_List
(
7340 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7341 (Loc
, Etyp
, Decls
)));
7345 Make_Object_Declaration
(Loc
,
7346 Defining_Identifier
=> Any
,
7347 Aliased_Present
=> False,
7348 Object_Definition
=>
7349 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7350 Expression
=> Expr
));
7352 Append_To
(Statements
,
7353 Add_Parameter_To_NVList
(Loc
,
7354 Parameter
=> Current_Parameter
,
7355 NVList
=> Arguments
,
7356 Constrained
=> Constrained
,
7359 if Out_Present
(Current_Parameter
)
7360 and then not Is_Controlling_Formal
7362 Append_To
(After_Statements
,
7363 Make_Assignment_Statement
(Loc
,
7366 Defining_Identifier
(Current_Parameter
), Loc
),
7368 PolyORB_Support
.Helpers
.Build_From_Any_Call
7369 (Etype
(Parameter_Type
(Current_Parameter
)),
7370 New_Occurrence_Of
(Any
, Loc
),
7377 -- If the current parameter has a dynamic constrained status, then
7378 -- this status is transmitted as well.
7379 -- This should be done for accessibility as well ???
7381 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7383 and then Need_Extra_Constrained
(Current_Parameter
)
7385 -- In this block, we do not use the extra formal that has been
7386 -- created because it does not exist at the time of expansion
7387 -- when building calling stubs for remote access to subprogram
7388 -- types. We create an extra variable of this type and push it
7389 -- in the stream after the regular parameters.
7392 Extra_Any_Parameter
: constant Entity_Id
:=
7393 Make_Defining_Identifier
7394 (Loc
, New_Internal_Name
('P'));
7396 Parameter_Exp
: constant Node_Id
:=
7397 Make_Attribute_Reference
(Loc
,
7398 Prefix
=> New_Occurrence_Of
(
7399 Defining_Identifier
(Current_Parameter
), Loc
),
7400 Attribute_Name
=> Name_Constrained
);
7403 Set_Etype
(Parameter_Exp
, Etype
(Standard_Boolean
));
7406 Make_Object_Declaration
(Loc
,
7407 Defining_Identifier
=> Extra_Any_Parameter
,
7408 Aliased_Present
=> False,
7409 Object_Definition
=>
7410 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7412 PolyORB_Support
.Helpers
.Build_To_Any_Call
7413 (Parameter_Exp
, Decls
)));
7415 Append_To
(Extra_Formal_Statements
,
7416 Add_Parameter_To_NVList
(Loc
,
7417 Parameter
=> Extra_Any_Parameter
,
7418 NVList
=> Arguments
,
7419 Constrained
=> True,
7420 Any
=> Extra_Any_Parameter
));
7424 Next
(Current_Parameter
);
7427 -- Append the formal statements list to the statements
7429 Append_List_To
(Statements
, Extra_Formal_Statements
);
7431 Append_To
(Statements
,
7432 Make_Procedure_Call_Statement
(Loc
,
7434 New_Occurrence_Of
(RTE
(RE_Request_Create
), Loc
),
7436 Parameter_Associations
=> New_List
(
7439 New_Occurrence_Of
(Arguments
, Loc
),
7440 New_Occurrence_Of
(Result
, Loc
),
7441 New_Occurrence_Of
(RTE
(RE_Nil_Exc_List
), Loc
))));
7443 Append_To
(Parameter_Associations
(Last
(Statements
)),
7444 New_Occurrence_Of
(Request
, Loc
));
7447 (not (Is_Known_Non_Asynchronous
and Is_Known_Asynchronous
));
7449 if Is_Known_Non_Asynchronous
or Is_Known_Asynchronous
then
7452 (Boolean_Literals
(Is_Known_Asynchronous
), Loc
);
7455 pragma Assert
(Present
(Asynchronous
));
7456 Asynchronous_P
:= New_Copy_Tree
(Asynchronous
);
7458 -- The expression node Asynchronous will be used to build an 'if'
7459 -- statement at the end of Build_General_Calling_Stubs: we need to
7460 -- make a copy here.
7463 Append_To
(Parameter_Associations
(Last
(Statements
)),
7464 Make_Indexed_Component
(Loc
,
7467 RTE
(RE_Asynchronous_P_To_Sync_Scope
), Loc
),
7468 Expressions
=> New_List
(Asynchronous_P
)));
7470 Append_To
(Statements
,
7471 Make_Procedure_Call_Statement
(Loc
,
7473 New_Occurrence_Of
(RTE
(RE_Request_Invoke
), Loc
),
7474 Parameter_Associations
=> New_List
(
7475 New_Occurrence_Of
(Request
, Loc
))));
7477 Non_Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7478 Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7480 if not Is_Known_Asynchronous
then
7482 -- Reraise an exception occurrence from the completed request.
7483 -- If the exception occurrence is empty, this is a no-op.
7485 Append_To
(Non_Asynchronous_Statements
,
7486 Make_Procedure_Call_Statement
(Loc
,
7488 New_Occurrence_Of
(RTE
(RE_Request_Raise_Occurrence
), Loc
),
7489 Parameter_Associations
=> New_List
(
7490 New_Occurrence_Of
(Request
, Loc
))));
7494 -- If this is a function call, read the value and return it
7496 Append_To
(Non_Asynchronous_Statements
,
7497 Make_Tag_Check
(Loc
,
7498 Make_Simple_Return_Statement
(Loc
,
7499 PolyORB_Support
.Helpers
.Build_From_Any_Call
7500 (Etype
(Result_Definition
(Spec
)),
7501 Make_Selected_Component
(Loc
,
7503 Selector_Name
=> Name_Argument
),
7508 Append_List_To
(Non_Asynchronous_Statements
, After_Statements
);
7510 if Is_Known_Asynchronous
then
7511 Append_List_To
(Statements
, Asynchronous_Statements
);
7513 elsif Is_Known_Non_Asynchronous
then
7514 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
7517 pragma Assert
(Present
(Asynchronous
));
7518 Append_To
(Statements
,
7519 Make_Implicit_If_Statement
(Nod
,
7520 Condition
=> Asynchronous
,
7521 Then_Statements
=> Asynchronous_Statements
,
7522 Else_Statements
=> Non_Asynchronous_Statements
));
7524 end Build_General_Calling_Stubs
;
7526 -----------------------
7527 -- Build_Stub_Target --
7528 -----------------------
7530 function Build_Stub_Target
7533 RCI_Locator
: Entity_Id
;
7534 Controlling_Parameter
: Entity_Id
) return RPC_Target
7536 Target_Info
: RPC_Target
(PCS_Kind
=> Name_PolyORB_DSA
);
7537 Target_Reference
: constant Entity_Id
:=
7538 Make_Defining_Identifier
(Loc
,
7539 New_Internal_Name
('T'));
7541 if Present
(Controlling_Parameter
) then
7543 Make_Object_Declaration
(Loc
,
7544 Defining_Identifier
=> Target_Reference
,
7546 Object_Definition
=>
7547 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
7550 Make_Function_Call
(Loc
,
7552 New_Occurrence_Of
(RTE
(RE_Make_Ref
), Loc
),
7553 Parameter_Associations
=> New_List
(
7554 Make_Selected_Component
(Loc
,
7555 Prefix
=> Controlling_Parameter
,
7556 Selector_Name
=> Name_Target
)))));
7558 -- Note: Controlling_Parameter has the same components as
7559 -- System.Partition_Interface.RACW_Stub_Type.
7561 Target_Info
.Object
:= New_Occurrence_Of
(Target_Reference
, Loc
);
7564 Target_Info
.Object
:=
7565 Make_Selected_Component
(Loc
,
7566 Prefix
=> Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
7568 Make_Identifier
(Loc
, Name_Get_RCI_Package_Ref
));
7572 end Build_Stub_Target
;
7574 ---------------------
7575 -- Build_Stub_Type --
7576 ---------------------
7578 procedure Build_Stub_Type
7579 (RACW_Type
: Entity_Id
;
7580 Stub_Type
: Entity_Id
;
7581 Stub_Type_Decl
: out Node_Id
;
7582 RPC_Receiver_Decl
: out Node_Id
)
7584 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
7585 pragma Warnings
(Off
);
7586 pragma Unreferenced
(RACW_Type
);
7587 pragma Warnings
(On
);
7591 Make_Full_Type_Declaration
(Loc
,
7592 Defining_Identifier
=> Stub_Type
,
7594 Make_Record_Definition
(Loc
,
7595 Tagged_Present
=> True,
7596 Limited_Present
=> True,
7598 Make_Component_List
(Loc
,
7599 Component_Items
=> New_List
(
7601 Make_Component_Declaration
(Loc
,
7602 Defining_Identifier
=>
7603 Make_Defining_Identifier
(Loc
, Name_Target
),
7604 Component_Definition
=>
7605 Make_Component_Definition
(Loc
,
7606 Aliased_Present
=> False,
7607 Subtype_Indication
=>
7608 New_Occurrence_Of
(RTE
(RE_Entity_Ptr
), Loc
))),
7610 Make_Component_Declaration
(Loc
,
7611 Defining_Identifier
=>
7612 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
7614 Component_Definition
=>
7615 Make_Component_Definition
(Loc
,
7616 Aliased_Present
=> False,
7617 Subtype_Indication
=>
7618 New_Occurrence_Of
(Standard_Boolean
, Loc
)))))));
7620 RPC_Receiver_Decl
:=
7621 Make_Object_Declaration
(Loc
,
7622 Defining_Identifier
=> Make_Defining_Identifier
(Loc
,
7623 New_Internal_Name
('R')),
7624 Aliased_Present
=> True,
7625 Object_Definition
=>
7626 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7627 end Build_Stub_Type
;
7629 -----------------------------
7630 -- Build_RPC_Receiver_Body --
7631 -----------------------------
7633 procedure Build_RPC_Receiver_Body
7634 (RPC_Receiver
: Entity_Id
;
7635 Request
: out Entity_Id
;
7636 Subp_Id
: out Entity_Id
;
7637 Subp_Index
: out Entity_Id
;
7638 Stmts
: out List_Id
;
7641 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
7643 RPC_Receiver_Spec
: Node_Id
;
7644 RPC_Receiver_Decls
: List_Id
;
7647 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
7649 RPC_Receiver_Spec
:=
7650 Build_RPC_Receiver_Specification
(
7651 RPC_Receiver
=> RPC_Receiver
,
7652 Request_Parameter
=> Request
);
7654 Subp_Id
:= Make_Defining_Identifier
(Loc
, Name_P
);
7655 Subp_Index
:= Make_Defining_Identifier
(Loc
, Name_I
);
7657 RPC_Receiver_Decls
:= New_List
(
7658 Make_Object_Renaming_Declaration
(Loc
,
7659 Defining_Identifier
=> Subp_Id
,
7660 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
7662 Make_Explicit_Dereference
(Loc
,
7664 Make_Selected_Component
(Loc
,
7666 Selector_Name
=> Name_Operation
))),
7668 Make_Object_Declaration
(Loc
,
7669 Defining_Identifier
=> Subp_Index
,
7670 Object_Definition
=>
7671 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7673 Make_Attribute_Reference
(Loc
,
7675 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7676 Attribute_Name
=> Name_Last
)));
7681 Make_Subprogram_Body
(Loc
,
7682 Specification
=> RPC_Receiver_Spec
,
7683 Declarations
=> RPC_Receiver_Decls
,
7684 Handled_Statement_Sequence
=>
7685 Make_Handled_Sequence_Of_Statements
(Loc
,
7686 Statements
=> Stmts
));
7687 end Build_RPC_Receiver_Body
;
7689 --------------------------------------
7690 -- Build_Subprogram_Receiving_Stubs --
7691 --------------------------------------
7693 function Build_Subprogram_Receiving_Stubs
7694 (Vis_Decl
: Node_Id
;
7695 Asynchronous
: Boolean;
7696 Dynamically_Asynchronous
: Boolean := False;
7697 Stub_Type
: Entity_Id
:= Empty
;
7698 RACW_Type
: Entity_Id
:= Empty
;
7699 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
7701 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
7703 Request_Parameter
: constant Entity_Id
:=
7704 Make_Defining_Identifier
(Loc
,
7705 New_Internal_Name
('R'));
7706 -- Formal parameter for receiving stubs: a descriptor for an incoming
7709 Outer_Decls
: constant List_Id
:= New_List
;
7710 -- At the outermost level, an NVList and Any's are declared for all
7711 -- parameters. The Dynamic_Async flag also needs to be declared there
7712 -- to be visible from the exception handling code.
7714 Outer_Statements
: constant List_Id
:= New_List
;
7715 -- Statements that occur prior to the declaration of the actual
7716 -- parameter variables.
7718 Outer_Extra_Formal_Statements
: constant List_Id
:= New_List
;
7719 -- Statements concerning extra formal parameters, prior to the
7720 -- declaration of the actual parameter variables.
7722 Decls
: constant List_Id
:= New_List
;
7723 -- All the parameters will get declared before calling the real
7724 -- subprograms. Also the out parameters will be declared.
7725 -- At this level, parameters may be unconstrained.
7727 Statements
: constant List_Id
:= New_List
;
7729 After_Statements
: constant List_Id
:= New_List
;
7730 -- Statements to be executed after the subprogram call
7732 Inner_Decls
: List_Id
:= No_List
;
7733 -- In case of a function, the inner declarations are needed since
7734 -- the result may be unconstrained.
7736 Excep_Handlers
: List_Id
:= No_List
;
7738 Parameter_List
: constant List_Id
:= New_List
;
7739 -- List of parameters to be passed to the subprogram
7741 First_Controlling_Formal_Seen
: Boolean := False;
7743 Current_Parameter
: Node_Id
;
7745 Ordered_Parameters_List
: constant List_Id
:=
7746 Build_Ordered_Parameters_List
7747 (Specification
(Vis_Decl
));
7749 Arguments
: constant Entity_Id
:=
7750 Make_Defining_Identifier
(Loc
,
7751 New_Internal_Name
('A'));
7752 -- Name of the named values list used to retrieve parameters
7754 Subp_Spec
: Node_Id
;
7755 -- Subprogram specification
7757 Called_Subprogram
: Node_Id
;
7758 -- The subprogram to call
7761 if Present
(RACW_Type
) then
7762 Called_Subprogram
:=
7763 New_Occurrence_Of
(Parent_Primitive
, Loc
);
7765 Called_Subprogram
:=
7767 (Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
7770 Declare_Create_NVList
(Loc
, Arguments
, Outer_Decls
, Outer_Statements
);
7772 -- Loop through every parameter and get its value from the stream. If
7773 -- the parameter is unconstrained, then the parameter is read using
7774 -- 'Input at the point of declaration.
7776 Current_Parameter
:= First
(Ordered_Parameters_List
);
7777 while Present
(Current_Parameter
) loop
7780 Constrained
: Boolean;
7781 Any
: Entity_Id
:= Empty
;
7782 Object
: constant Entity_Id
:=
7783 Make_Defining_Identifier
(Loc
,
7784 Chars
=> New_Internal_Name
('P'));
7785 Expr
: Node_Id
:= Empty
;
7787 Is_Controlling_Formal
: constant Boolean :=
7788 Is_RACW_Controlling_Formal
7789 (Current_Parameter
, Stub_Type
);
7791 Is_First_Controlling_Formal
: Boolean := False;
7793 Need_Extra_Constrained
: Boolean;
7794 -- True when an extra constrained actual is required
7797 if Is_Controlling_Formal
then
7799 -- Controlling formals in distributed object primitive
7800 -- operations are handled specially:
7801 -- - the first controlling formal is used as the
7802 -- target of the call;
7803 -- - the remaining controlling formals are transmitted
7807 Is_First_Controlling_Formal
:=
7808 not First_Controlling_Formal_Seen
;
7809 First_Controlling_Formal_Seen
:= True;
7812 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7816 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
7818 if not Is_First_Controlling_Formal
then
7820 Make_Defining_Identifier
(Loc
,
7821 Chars
=> New_Internal_Name
('A'));
7823 Append_To
(Outer_Decls
,
7824 Make_Object_Declaration
(Loc
,
7825 Defining_Identifier
=> Any
,
7826 Object_Definition
=>
7827 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7829 Make_Function_Call
(Loc
,
7830 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7831 Parameter_Associations
=> New_List
(
7832 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7833 (Loc
, Etyp
, Outer_Decls
)))));
7835 Append_To
(Outer_Statements
,
7836 Add_Parameter_To_NVList
(Loc
,
7837 Parameter
=> Current_Parameter
,
7838 NVList
=> Arguments
,
7839 Constrained
=> Constrained
,
7843 if Is_First_Controlling_Formal
then
7845 Addr
: constant Entity_Id
:=
7846 Make_Defining_Identifier
(Loc
,
7847 Chars
=> New_Internal_Name
('A'));
7849 Is_Local
: constant Entity_Id
:=
7850 Make_Defining_Identifier
(Loc
,
7851 Chars
=> New_Internal_Name
('L'));
7854 -- Special case: obtain the first controlling formal
7855 -- from the target of the remote call, instead of the
7858 Append_To
(Outer_Decls
,
7859 Make_Object_Declaration
(Loc
,
7860 Defining_Identifier
=> Addr
,
7861 Object_Definition
=>
7862 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
7864 Append_To
(Outer_Decls
,
7865 Make_Object_Declaration
(Loc
,
7866 Defining_Identifier
=> Is_Local
,
7867 Object_Definition
=>
7868 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7870 Append_To
(Outer_Statements
,
7871 Make_Procedure_Call_Statement
(Loc
,
7873 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
7874 Parameter_Associations
=> New_List
(
7875 Make_Selected_Component
(Loc
,
7878 Request_Parameter
, Loc
),
7880 Make_Identifier
(Loc
, Name_Target
)),
7881 New_Occurrence_Of
(Is_Local
, Loc
),
7882 New_Occurrence_Of
(Addr
, Loc
))));
7884 Expr
:= Unchecked_Convert_To
(RACW_Type
,
7885 New_Occurrence_Of
(Addr
, Loc
));
7888 elsif In_Present
(Current_Parameter
)
7889 or else not Out_Present
(Current_Parameter
)
7890 or else not Constrained
7892 -- If an input parameter is constrained, then its reading is
7893 -- deferred until the beginning of the subprogram body. If
7894 -- it is unconstrained, then an expression is built for
7895 -- the object declaration and the variable is set using
7896 -- 'Input instead of 'Read.
7898 Expr
:= PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7899 Etyp
, New_Occurrence_Of
(Any
, Loc
), Decls
);
7902 Append_To
(Statements
,
7903 Make_Assignment_Statement
(Loc
,
7904 Name
=> New_Occurrence_Of
(Object
, Loc
),
7905 Expression
=> Expr
));
7910 -- Expr will be used to initialize (and constrain) the
7911 -- parameter when it is declared.
7916 Need_Extra_Constrained
:=
7917 Nkind
(Parameter_Type
(Current_Parameter
)) /=
7920 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
7922 Present
(Extra_Constrained
7923 (Defining_Identifier
(Current_Parameter
)));
7925 -- We may not associate an extra constrained actual to a
7926 -- constant object, so if one is needed, declare the actual
7927 -- as a variable even if it won't be modified.
7929 Build_Actual_Object_Declaration
7932 Variable
=> Need_Extra_Constrained
7933 or else Out_Present
(Current_Parameter
),
7936 Set_Etype
(Object
, Etyp
);
7938 -- An out parameter may be written back using a 'Write
7939 -- attribute instead of a 'Output because it has been
7940 -- constrained by the parameter given to the caller. Note that
7941 -- out controlling arguments in the case of a RACW are not put
7942 -- back in the stream because the pointer on them has not
7945 if Out_Present
(Current_Parameter
)
7946 and then not Is_Controlling_Formal
7948 Append_To
(After_Statements
,
7949 Make_Procedure_Call_Statement
(Loc
,
7950 Name
=> New_Occurrence_Of
(RTE
(RE_Move_Any_Value
), Loc
),
7951 Parameter_Associations
=> New_List
(
7952 New_Occurrence_Of
(Any
, Loc
),
7953 PolyORB_Support
.Helpers
.Build_To_Any_Call
7954 (New_Occurrence_Of
(Object
, Loc
), Decls
))));
7957 -- For RACW controlling formals, the Etyp of Object is always
7958 -- an RACW, even if the parameter is not of an anonymous access
7959 -- type. In such case, we need to dereference it at call time.
7961 if Is_Controlling_Formal
then
7962 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7965 Append_To
(Parameter_List
,
7966 Make_Parameter_Association
(Loc
,
7969 (Defining_Identifier
(Current_Parameter
), Loc
),
7970 Explicit_Actual_Parameter
=>
7971 Make_Explicit_Dereference
(Loc
,
7973 Unchecked_Convert_To
(RACW_Type
,
7974 OK_Convert_To
(RTE
(RE_Address
),
7975 New_Occurrence_Of
(Object
, Loc
))))));
7978 Append_To
(Parameter_List
,
7979 Make_Parameter_Association
(Loc
,
7982 (Defining_Identifier
(Current_Parameter
), Loc
),
7984 Explicit_Actual_Parameter
=>
7985 Unchecked_Convert_To
(RACW_Type
,
7986 OK_Convert_To
(RTE
(RE_Address
),
7987 New_Occurrence_Of
(Object
, Loc
)))));
7991 Append_To
(Parameter_List
,
7992 Make_Parameter_Association
(Loc
,
7995 Defining_Identifier
(Current_Parameter
), Loc
),
7996 Explicit_Actual_Parameter
=>
7997 New_Occurrence_Of
(Object
, Loc
)));
8000 -- If the current parameter needs an extra formal, then read it
8001 -- from the stream and set the corresponding semantic field in
8002 -- the variable. If the kind of the parameter identifier is
8003 -- E_Void, then this is a compiler generated parameter that
8004 -- doesn't need an extra constrained status.
8006 -- The case of Extra_Accessibility should also be handled ???
8008 if Need_Extra_Constrained
then
8010 Extra_Parameter
: constant Entity_Id
:=
8012 (Defining_Identifier
8013 (Current_Parameter
));
8015 Extra_Any
: constant Entity_Id
:=
8016 Make_Defining_Identifier
(Loc
,
8017 Chars
=> New_Internal_Name
('A'));
8019 Formal_Entity
: constant Entity_Id
:=
8020 Make_Defining_Identifier
(Loc
,
8021 Chars
=> Chars
(Extra_Parameter
));
8023 Formal_Type
: constant Entity_Id
:=
8024 Etype
(Extra_Parameter
);
8027 Append_To
(Outer_Decls
,
8028 Make_Object_Declaration
(Loc
,
8029 Defining_Identifier
=> Extra_Any
,
8030 Object_Definition
=>
8031 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8033 Make_Function_Call
(Loc
,
8035 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
8036 Parameter_Associations
=> New_List
(
8037 PolyORB_Support
.Helpers
.Build_TypeCode_Call
8038 (Loc
, Formal_Type
, Outer_Decls
)))));
8040 Append_To
(Outer_Extra_Formal_Statements
,
8041 Add_Parameter_To_NVList
(Loc
,
8042 Parameter
=> Extra_Parameter
,
8043 NVList
=> Arguments
,
8044 Constrained
=> True,
8048 Make_Object_Declaration
(Loc
,
8049 Defining_Identifier
=> Formal_Entity
,
8050 Object_Definition
=>
8051 New_Occurrence_Of
(Formal_Type
, Loc
)));
8053 Append_To
(Statements
,
8054 Make_Assignment_Statement
(Loc
,
8055 Name
=> New_Occurrence_Of
(Formal_Entity
, Loc
),
8057 PolyORB_Support
.Helpers
.Build_From_Any_Call
8059 New_Occurrence_Of
(Extra_Any
, Loc
),
8061 Set_Extra_Constrained
(Object
, Formal_Entity
);
8066 Next
(Current_Parameter
);
8069 -- Extra Formals should go after all the other parameters
8071 Append_List_To
(Outer_Statements
, Outer_Extra_Formal_Statements
);
8073 Append_To
(Outer_Statements
,
8074 Make_Procedure_Call_Statement
(Loc
,
8075 Name
=> New_Occurrence_Of
(RTE
(RE_Request_Arguments
), Loc
),
8076 Parameter_Associations
=> New_List
(
8077 New_Occurrence_Of
(Request_Parameter
, Loc
),
8078 New_Occurrence_Of
(Arguments
, Loc
))));
8080 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
8082 -- The remote subprogram is a function: Build an inner block to be
8083 -- able to hold a potentially unconstrained result in a variable.
8086 Etyp
: constant Entity_Id
:=
8087 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
8088 Result
: constant Node_Id
:=
8089 Make_Defining_Identifier
(Loc
,
8090 Chars
=> New_Internal_Name
('R'));
8093 Inner_Decls
:= New_List
(
8094 Make_Object_Declaration
(Loc
,
8095 Defining_Identifier
=> Result
,
8096 Constant_Present
=> True,
8097 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
8099 Make_Function_Call
(Loc
,
8100 Name
=> Called_Subprogram
,
8101 Parameter_Associations
=> Parameter_List
)));
8103 if Is_Class_Wide_Type
(Etyp
) then
8105 -- For a remote call to a function with a class-wide type,
8106 -- check that the returned value satisfies the requirements
8109 Append_To
(Inner_Decls
,
8110 Make_Transportable_Check
(Loc
,
8111 New_Occurrence_Of
(Result
, Loc
)));
8115 Set_Etype
(Result
, Etyp
);
8116 Append_To
(After_Statements
,
8117 Make_Procedure_Call_Statement
(Loc
,
8118 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Result
), Loc
),
8119 Parameter_Associations
=> New_List
(
8120 New_Occurrence_Of
(Request_Parameter
, Loc
),
8121 PolyORB_Support
.Helpers
.Build_To_Any_Call
8122 (New_Occurrence_Of
(Result
, Loc
), Decls
))));
8124 -- A DSA function does not have out or inout arguments
8127 Append_To
(Statements
,
8128 Make_Block_Statement
(Loc
,
8129 Declarations
=> Inner_Decls
,
8130 Handled_Statement_Sequence
=>
8131 Make_Handled_Sequence_Of_Statements
(Loc
,
8132 Statements
=> After_Statements
)));
8135 -- The remote subprogram is a procedure. We do not need any inner
8136 -- block in this case. No specific processing is required here for
8137 -- the dynamically asynchronous case: the indication of whether
8138 -- call is asynchronous or not is managed by the Sync_Scope
8139 -- attibute of the request, and is handled entirely in the
8142 Append_To
(After_Statements
,
8143 Make_Procedure_Call_Statement
(Loc
,
8144 Name
=> New_Occurrence_Of
(RTE
(RE_Request_Set_Out
), Loc
),
8145 Parameter_Associations
=> New_List
(
8146 New_Occurrence_Of
(Request_Parameter
, Loc
))));
8148 Append_To
(Statements
,
8149 Make_Procedure_Call_Statement
(Loc
,
8150 Name
=> Called_Subprogram
,
8151 Parameter_Associations
=> Parameter_List
));
8153 Append_List_To
(Statements
, After_Statements
);
8157 Make_Procedure_Specification
(Loc
,
8158 Defining_Unit_Name
=>
8159 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
8161 Parameter_Specifications
=> New_List
(
8162 Make_Parameter_Specification
(Loc
,
8163 Defining_Identifier
=> Request_Parameter
,
8165 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
8167 -- An exception raised during the execution of an incoming
8168 -- remote subprogram call and that needs to be sent back
8169 -- to the caller is propagated by the receiving stubs, and
8170 -- will be handled by the caller (the distribution runtime).
8172 if Asynchronous
and then not Dynamically_Asynchronous
then
8174 -- For an asynchronous procedure, add a null exception handler
8176 Excep_Handlers
:= New_List
(
8177 Make_Implicit_Exception_Handler
(Loc
,
8178 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8179 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
8182 -- In the other cases, if an exception is raised, then the
8183 -- exception occurrence is propagated.
8188 Append_To
(Outer_Statements
,
8189 Make_Block_Statement
(Loc
,
8190 Declarations
=> Decls
,
8191 Handled_Statement_Sequence
=>
8192 Make_Handled_Sequence_Of_Statements
(Loc
,
8193 Statements
=> Statements
)));
8196 Make_Subprogram_Body
(Loc
,
8197 Specification
=> Subp_Spec
,
8198 Declarations
=> Outer_Decls
,
8199 Handled_Statement_Sequence
=>
8200 Make_Handled_Sequence_Of_Statements
(Loc
,
8201 Statements
=> Outer_Statements
,
8202 Exception_Handlers
=> Excep_Handlers
));
8203 end Build_Subprogram_Receiving_Stubs
;
8209 package body Helpers
is
8211 -----------------------
8212 -- Local Subprograms --
8213 -----------------------
8215 function Find_Numeric_Representation
8216 (Typ
: Entity_Id
) return Entity_Id
;
8217 -- Given a numeric type Typ, return the smallest integer or floating
8218 -- point type from Standard, or the smallest unsigned (modular) type
8219 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8221 function Make_Stream_Procedure_Function_Name
8224 Nam
: Name_Id
) return Entity_Id
;
8225 -- Return the name to be assigned for stream subprogram Nam of Typ.
8226 -- (copied from exp_strm.adb, should be shared???)
8228 ------------------------------------------------------------
8229 -- Common subprograms for building various tree fragments --
8230 ------------------------------------------------------------
8232 function Build_Get_Aggregate_Element
8236 Idx
: Node_Id
) return Node_Id
;
8237 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8238 -- returning the Idx'th element.
8241 Subprogram
: Entity_Id
;
8242 -- Reference location for constructed nodes
8245 -- For 'Range and Etype
8248 -- For the construction of the innermost element expression
8250 with procedure Add_Process_Element
8253 Counter
: Entity_Id
;
8256 procedure Append_Array_Traversal
8259 Counter
: Entity_Id
:= Empty
;
8261 -- Build nested loop statements that iterate over the elements of an
8262 -- array Arry. The statement(s) built by Add_Process_Element are
8263 -- executed for each element; Indices is the list of indices to be
8264 -- used in the construction of the indexed component that denotes the
8265 -- current element. Subprogram is the entity for the subprogram for
8266 -- which this iterator is generated. The generated statements are
8267 -- appended to Stmts.
8271 -- The record entity being dealt with
8273 with procedure Add_Process_Element
8275 Container
: Node_Or_Entity_Id
;
8276 Counter
: in out Int
;
8279 -- Rec is the instance of the record type, or Empty.
8280 -- Field is either the N_Defining_Identifier for a component,
8281 -- or an N_Variant_Part.
8283 procedure Append_Record_Traversal
8286 Container
: Node_Or_Entity_Id
;
8287 Counter
: in out Int
);
8288 -- Process component list Clist. Individual fields are passed
8289 -- to Field_Processing. Each variant part is also processed.
8290 -- Container is the outer Any (for From_Any/To_Any),
8291 -- the outer typecode (for TC) to which the operation applies.
8293 -----------------------------
8294 -- Append_Record_Traversal --
8295 -----------------------------
8297 procedure Append_Record_Traversal
8300 Container
: Node_Or_Entity_Id
;
8301 Counter
: in out Int
)
8305 -- Clist's Component_Items and Variant_Part
8315 CI
:= Component_Items
(Clist
);
8316 VP
:= Variant_Part
(Clist
);
8319 while Present
(Item
) loop
8320 Def
:= Defining_Identifier
(Item
);
8322 if not Is_Internal_Name
(Chars
(Def
)) then
8324 (Stmts
, Container
, Counter
, Rec
, Def
);
8330 if Present
(VP
) then
8331 Add_Process_Element
(Stmts
, Container
, Counter
, Rec
, VP
);
8333 end Append_Record_Traversal
;
8335 -------------------------
8336 -- Build_From_Any_Call --
8337 -------------------------
8339 function Build_From_Any_Call
8342 Decls
: List_Id
) return Node_Id
8344 Loc
: constant Source_Ptr
:= Sloc
(N
);
8346 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
8348 Fnam
: Entity_Id
:= Empty
;
8349 Lib_RE
: RE_Id
:= RE_Null
;
8353 -- First simple case where the From_Any function is present
8354 -- in the type's TSS.
8356 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_From_Any
);
8358 if Sloc
(U_Type
) <= Standard_Location
then
8359 U_Type
:= Base_Type
(U_Type
);
8362 -- Check first for Boolean and Character. These are enumeration
8363 -- types, but we treat them specially, since they may require
8364 -- special handling in the transfer protocol. However, this
8365 -- special handling only applies if they have standard
8366 -- representation, otherwise they are treated like any other
8367 -- enumeration type.
8369 if Present
(Fnam
) then
8372 elsif U_Type
= Standard_Boolean
then
8375 elsif U_Type
= Standard_Character
then
8378 elsif U_Type
= Standard_Wide_Character
then
8381 elsif U_Type
= Standard_Wide_Wide_Character
then
8382 Lib_RE
:= RE_FA_WWC
;
8384 -- Floating point types
8386 elsif U_Type
= Standard_Short_Float
then
8389 elsif U_Type
= Standard_Float
then
8392 elsif U_Type
= Standard_Long_Float
then
8395 elsif U_Type
= Standard_Long_Long_Float
then
8396 Lib_RE
:= RE_FA_LLF
;
8400 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
8401 Lib_RE
:= RE_FA_SSI
;
8403 elsif U_Type
= Etype
(Standard_Short_Integer
) then
8406 elsif U_Type
= Etype
(Standard_Integer
) then
8409 elsif U_Type
= Etype
(Standard_Long_Integer
) then
8412 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
8413 Lib_RE
:= RE_FA_LLI
;
8415 -- Unsigned integer types
8417 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
8418 Lib_RE
:= RE_FA_SSU
;
8420 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
8423 elsif U_Type
= RTE
(RE_Unsigned
) then
8426 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
8429 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
8430 Lib_RE
:= RE_FA_LLU
;
8432 elsif U_Type
= Standard_String
then
8433 Lib_RE
:= RE_FA_String
;
8435 -- Other (non-primitive) types
8441 Build_From_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
8442 Append_To
(Decls
, Decl
);
8446 -- Call the function
8448 if Lib_RE
/= RE_Null
then
8449 pragma Assert
(No
(Fnam
));
8450 Fnam
:= RTE
(Lib_RE
);
8454 Make_Function_Call
(Loc
,
8455 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
8456 Parameter_Associations
=> New_List
(N
));
8458 -- We must set the type of Result, so the unchecked conversion
8459 -- from the underlying type to the base type is properly done.
8461 Set_Etype
(Result
, U_Type
);
8463 return Unchecked_Convert_To
(Typ
, Result
);
8464 end Build_From_Any_Call
;
8466 -----------------------------
8467 -- Build_From_Any_Function --
8468 -----------------------------
8470 procedure Build_From_Any_Function
8474 Fnam
: out Entity_Id
)
8477 Decls
: constant List_Id
:= New_List
;
8478 Stms
: constant List_Id
:= New_List
;
8480 Any_Parameter
: constant Entity_Id
:=
8481 Make_Defining_Identifier
(Loc
,
8482 New_Internal_Name
('A'));
8484 Use_Opaque_Representation
: Boolean;
8487 if Is_Itype
(Typ
) then
8488 Build_From_Any_Function
8497 Make_Stream_Procedure_Function_Name
(Loc
, Typ
, Name_uFrom_Any
);
8500 Make_Function_Specification
(Loc
,
8501 Defining_Unit_Name
=> Fnam
,
8502 Parameter_Specifications
=> New_List
(
8503 Make_Parameter_Specification
(Loc
,
8504 Defining_Identifier
=> Any_Parameter
,
8505 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
8506 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
8508 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8511 (not (Is_Remote_Access_To_Class_Wide_Type
(Typ
)));
8513 Use_Opaque_Representation
:= False;
8515 if Has_Stream_Attribute_Definition
8516 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
8518 Has_Stream_Attribute_Definition
8519 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
8521 -- If user-defined stream attributes are specified for this
8522 -- type, use them and transmit data as an opaque sequence of
8525 Use_Opaque_Representation
:= True;
8527 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
8529 Make_Simple_Return_Statement
(Loc
,
8534 New_Occurrence_Of
(Any_Parameter
, Loc
),
8537 elsif Is_Record_Type
(Typ
)
8538 and then not Is_Derived_Type
(Typ
)
8539 and then not Is_Tagged_Type
(Typ
)
8541 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
8543 Make_Simple_Return_Statement
(Loc
,
8548 New_Occurrence_Of
(Any_Parameter
, Loc
),
8553 Disc
: Entity_Id
:= Empty
;
8554 Discriminant_Associations
: List_Id
;
8555 Rdef
: constant Node_Id
:=
8557 (Declaration_Node
(Typ
));
8558 Component_Counter
: Int
:= 0;
8560 -- The returned object
8562 Res
: constant Entity_Id
:=
8563 Make_Defining_Identifier
(Loc
,
8564 New_Internal_Name
('R'));
8566 Res_Definition
: Node_Id
:= New_Occurrence_Of
(Typ
, Loc
);
8568 procedure FA_Rec_Add_Process_Element
8571 Counter
: in out Int
;
8575 procedure FA_Append_Record_Traversal
is
8576 new Append_Record_Traversal
8578 Add_Process_Element
=> FA_Rec_Add_Process_Element
);
8580 --------------------------------
8581 -- FA_Rec_Add_Process_Element --
8582 --------------------------------
8584 procedure FA_Rec_Add_Process_Element
8587 Counter
: in out Int
;
8592 if Nkind
(Field
) = N_Defining_Identifier
then
8594 -- A regular component
8597 Make_Assignment_Statement
(Loc
,
8598 Name
=> Make_Selected_Component
(Loc
,
8600 New_Occurrence_Of
(Rec
, Loc
),
8602 New_Occurrence_Of
(Field
, Loc
)),
8604 Build_From_Any_Call
(Etype
(Field
),
8605 Build_Get_Aggregate_Element
(Loc
,
8607 TC
=> Build_TypeCode_Call
(Loc
,
8608 Etype
(Field
), Decls
),
8609 Idx
=> Make_Integer_Literal
(Loc
,
8618 Struct_Counter
: Int
:= 0;
8620 Block_Decls
: constant List_Id
:= New_List
;
8621 Block_Stmts
: constant List_Id
:= New_List
;
8624 Alt_List
: constant List_Id
:= New_List
;
8625 Choice_List
: List_Id
;
8627 Struct_Any
: constant Entity_Id
:=
8628 Make_Defining_Identifier
(Loc
,
8629 New_Internal_Name
('S'));
8633 Make_Object_Declaration
(Loc
,
8634 Defining_Identifier
=> Struct_Any
,
8635 Constant_Present
=> True,
8636 Object_Definition
=>
8637 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8639 Make_Function_Call
(Loc
,
8642 (RTE
(RE_Extract_Union_Value
), Loc
),
8644 Parameter_Associations
=> New_List
(
8645 Build_Get_Aggregate_Element
(Loc
,
8648 Make_Function_Call
(Loc
,
8649 Name
=> New_Occurrence_Of
(
8650 RTE
(RE_Any_Member_Type
), Loc
),
8651 Parameter_Associations
=>
8653 New_Occurrence_Of
(Any
, Loc
),
8654 Make_Integer_Literal
(Loc
,
8655 Intval
=> Counter
))),
8657 Make_Integer_Literal
(Loc
,
8658 Intval
=> Counter
))))));
8661 Make_Block_Statement
(Loc
,
8662 Declarations
=> Block_Decls
,
8663 Handled_Statement_Sequence
=>
8664 Make_Handled_Sequence_Of_Statements
(Loc
,
8665 Statements
=> Block_Stmts
)));
8667 Append_To
(Block_Stmts
,
8668 Make_Case_Statement
(Loc
,
8670 Make_Selected_Component
(Loc
,
8672 Selector_Name
=> Chars
(Name
(Field
))),
8673 Alternatives
=> Alt_List
));
8675 Variant
:= First_Non_Pragma
(Variants
(Field
));
8676 while Present
(Variant
) loop
8679 (Discrete_Choices
(Variant
));
8681 VP_Stmts
:= New_List
;
8683 -- Struct_Counter should be reset before
8684 -- handling a variant part. Indeed only one
8685 -- of the case statement alternatives will be
8686 -- executed at run-time, so the counter must
8687 -- start at 0 for every case statement.
8689 Struct_Counter
:= 0;
8691 FA_Append_Record_Traversal
(
8693 Clist
=> Component_List
(Variant
),
8694 Container
=> Struct_Any
,
8695 Counter
=> Struct_Counter
);
8697 Append_To
(Alt_List
,
8698 Make_Case_Statement_Alternative
(Loc
,
8699 Discrete_Choices
=> Choice_List
,
8700 Statements
=> VP_Stmts
));
8701 Next_Non_Pragma
(Variant
);
8706 Counter
:= Counter
+ 1;
8707 end FA_Rec_Add_Process_Element
;
8710 -- First all discriminants
8712 if Has_Discriminants
(Typ
) then
8713 Discriminant_Associations
:= New_List
;
8715 Disc
:= First_Discriminant
(Typ
);
8716 while Present
(Disc
) loop
8718 Disc_Var_Name
: constant Entity_Id
:=
8719 Make_Defining_Identifier
(Loc
,
8720 Chars
=> Chars
(Disc
));
8721 Disc_Type
: constant Entity_Id
:=
8726 Make_Object_Declaration
(Loc
,
8727 Defining_Identifier
=> Disc_Var_Name
,
8728 Constant_Present
=> True,
8729 Object_Definition
=>
8730 New_Occurrence_Of
(Disc_Type
, Loc
),
8733 Build_From_Any_Call
(Disc_Type
,
8734 Build_Get_Aggregate_Element
(Loc
,
8735 Any
=> Any_Parameter
,
8736 TC
=> Build_TypeCode_Call
8737 (Loc
, Disc_Type
, Decls
),
8738 Idx
=> Make_Integer_Literal
(Loc
,
8739 Intval
=> Component_Counter
)),
8742 Component_Counter
:= Component_Counter
+ 1;
8744 Append_To
(Discriminant_Associations
,
8745 Make_Discriminant_Association
(Loc
,
8746 Selector_Names
=> New_List
(
8747 New_Occurrence_Of
(Disc
, Loc
)),
8749 New_Occurrence_Of
(Disc_Var_Name
, Loc
)));
8751 Next_Discriminant
(Disc
);
8755 Make_Subtype_Indication
(Loc
,
8756 Subtype_Mark
=> Res_Definition
,
8758 Make_Index_Or_Discriminant_Constraint
(Loc
,
8759 Discriminant_Associations
));
8762 -- Now we have all the discriminants in variables, we can
8763 -- declared a constrained object. Note that we are not
8764 -- initializing (non-discriminant) components directly in
8765 -- the object declarations, because which fields to
8766 -- initialize depends (at run time) on the discriminant
8770 Make_Object_Declaration
(Loc
,
8771 Defining_Identifier
=> Res
,
8772 Object_Definition
=> Res_Definition
));
8774 -- ... then all components
8776 FA_Append_Record_Traversal
(Stms
,
8777 Clist
=> Component_List
(Rdef
),
8778 Container
=> Any_Parameter
,
8779 Counter
=> Component_Counter
);
8782 Make_Simple_Return_Statement
(Loc
,
8783 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
8787 elsif Is_Array_Type
(Typ
) then
8789 Constrained
: constant Boolean := Is_Constrained
(Typ
);
8791 procedure FA_Ary_Add_Process_Element
8794 Counter
: Entity_Id
;
8796 -- Assign the current element (as identified by Counter) of
8797 -- Any to the variable denoted by name Datum, and advance
8798 -- Counter by 1. If Datum is not an Any, a call to From_Any
8799 -- for its type is inserted.
8801 --------------------------------
8802 -- FA_Ary_Add_Process_Element --
8803 --------------------------------
8805 procedure FA_Ary_Add_Process_Element
8808 Counter
: Entity_Id
;
8811 Assignment
: constant Node_Id
:=
8812 Make_Assignment_Statement
(Loc
,
8814 Expression
=> Empty
);
8816 Element_Any
: Node_Id
;
8820 Element_TC
: Node_Id
;
8823 if Etype
(Datum
) = RTE
(RE_Any
) then
8825 -- When Datum is an Any the Etype field is not
8826 -- sufficient to determine the typecode of Datum
8827 -- (which can be a TC_SEQUENCE or TC_ARRAY
8828 -- depending on the value of Constrained).
8830 -- Therefore we retrieve the typecode which has
8831 -- been constructed in Append_Array_Traversal with
8832 -- a call to Get_Any_Type.
8835 Make_Function_Call
(Loc
,
8836 Name
=> New_Occurrence_Of
(
8837 RTE
(RE_Get_Any_Type
), Loc
),
8838 Parameter_Associations
=> New_List
(
8839 New_Occurrence_Of
(Entity
(Datum
), Loc
)));
8841 -- For non Any Datum we simply construct a typecode
8842 -- matching the Etype of the Datum.
8844 Element_TC
:= Build_TypeCode_Call
8845 (Loc
, Etype
(Datum
), Decls
);
8849 Build_Get_Aggregate_Element
(Loc
,
8852 Idx
=> New_Occurrence_Of
(Counter
, Loc
));
8855 -- Note: here we *prepend* statements to Stmts, so
8856 -- we must do it in reverse order.
8859 Make_Assignment_Statement
(Loc
,
8861 New_Occurrence_Of
(Counter
, Loc
),
8864 Left_Opnd
=> New_Occurrence_Of
(Counter
, Loc
),
8865 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
8867 if Nkind
(Datum
) /= N_Attribute_Reference
then
8869 -- We ignore the value of the length of each
8870 -- dimension, since the target array has already
8871 -- been constrained anyway.
8873 if Etype
(Datum
) /= RTE
(RE_Any
) then
8874 Set_Expression
(Assignment
,
8876 (Component_Type
(Typ
), Element_Any
, Decls
));
8878 Set_Expression
(Assignment
, Element_Any
);
8881 Prepend_To
(Stmts
, Assignment
);
8883 end FA_Ary_Add_Process_Element
;
8885 ------------------------
8886 -- Local Declarations --
8887 ------------------------
8889 Counter
: constant Entity_Id
:=
8890 Make_Defining_Identifier
(Loc
, Name_J
);
8892 Initial_Counter_Value
: Int
:= 0;
8894 Component_TC
: constant Entity_Id
:=
8895 Make_Defining_Identifier
(Loc
, Name_T
);
8897 Res
: constant Entity_Id
:=
8898 Make_Defining_Identifier
(Loc
, Name_R
);
8900 procedure Append_From_Any_Array_Iterator
is
8901 new Append_Array_Traversal
(
8904 Indices
=> New_List
,
8905 Add_Process_Element
=> FA_Ary_Add_Process_Element
);
8907 Res_Subtype_Indication
: Node_Id
:=
8908 New_Occurrence_Of
(Typ
, Loc
);
8911 if not Constrained
then
8913 Ndim
: constant Int
:= Number_Dimensions
(Typ
);
8916 Indx
: Node_Id
:= First_Index
(Typ
);
8919 Ranges
: constant List_Id
:= New_List
;
8922 for J
in 1 .. Ndim
loop
8923 Lnam
:= New_External_Name
('L', J
);
8924 Hnam
:= New_External_Name
('H', J
);
8925 Indt
:= Etype
(Indx
);
8928 Make_Object_Declaration
(Loc
,
8929 Defining_Identifier
=>
8930 Make_Defining_Identifier
(Loc
, Lnam
),
8931 Constant_Present
=> True,
8932 Object_Definition
=>
8933 New_Occurrence_Of
(Indt
, Loc
),
8937 Build_Get_Aggregate_Element
(Loc
,
8938 Any
=> Any_Parameter
,
8939 TC
=> Build_TypeCode_Call
8942 Make_Integer_Literal
(Loc
, J
- 1)),
8946 Make_Object_Declaration
(Loc
,
8947 Defining_Identifier
=>
8948 Make_Defining_Identifier
(Loc
, Hnam
),
8950 Constant_Present
=> True,
8952 Object_Definition
=>
8953 New_Occurrence_Of
(Indt
, Loc
),
8955 Expression
=> Make_Attribute_Reference
(Loc
,
8957 New_Occurrence_Of
(Indt
, Loc
),
8959 Attribute_Name
=> Name_Val
,
8961 Expressions
=> New_List
(
8962 Make_Op_Subtract
(Loc
,
8967 Standard_Long_Integer
,
8968 Make_Identifier
(Loc
, Lnam
)),
8972 Standard_Long_Integer
,
8973 Make_Function_Call
(Loc
,
8975 New_Occurrence_Of
(RTE
(
8976 RE_Get_Nested_Sequence_Length
8978 Parameter_Associations
=>
8981 Any_Parameter
, Loc
),
8982 Make_Integer_Literal
(Loc
,
8986 Make_Integer_Literal
(Loc
, 1))))));
8990 Low_Bound
=> Make_Identifier
(Loc
, Lnam
),
8991 High_Bound
=> Make_Identifier
(Loc
, Hnam
)));
8996 -- Now we have all the necessary bound information:
8997 -- apply the set of range constraints to the
8998 -- (unconstrained) nominal subtype of Res.
9000 Initial_Counter_Value
:= Ndim
;
9001 Res_Subtype_Indication
:= Make_Subtype_Indication
(Loc
,
9002 Subtype_Mark
=> Res_Subtype_Indication
,
9004 Make_Index_Or_Discriminant_Constraint
(Loc
,
9005 Constraints
=> Ranges
));
9010 Make_Object_Declaration
(Loc
,
9011 Defining_Identifier
=> Res
,
9012 Object_Definition
=> Res_Subtype_Indication
));
9013 Set_Etype
(Res
, Typ
);
9016 Make_Object_Declaration
(Loc
,
9017 Defining_Identifier
=> Counter
,
9018 Object_Definition
=>
9019 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
9021 Make_Integer_Literal
(Loc
, Initial_Counter_Value
)));
9024 Make_Object_Declaration
(Loc
,
9025 Defining_Identifier
=> Component_TC
,
9026 Constant_Present
=> True,
9027 Object_Definition
=>
9028 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
),
9030 Build_TypeCode_Call
(Loc
,
9031 Component_Type
(Typ
), Decls
)));
9033 Append_From_Any_Array_Iterator
9034 (Stms
, Any_Parameter
, Counter
);
9037 Make_Simple_Return_Statement
(Loc
,
9038 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
9041 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9043 Make_Simple_Return_Statement
(Loc
,
9045 Unchecked_Convert_To
(Typ
,
9047 (Find_Numeric_Representation
(Typ
),
9048 New_Occurrence_Of
(Any_Parameter
, Loc
),
9052 Use_Opaque_Representation
:= True;
9055 if Use_Opaque_Representation
then
9057 -- Default: type is represented as an opaque sequence of bytes
9060 Strm
: constant Entity_Id
:=
9061 Make_Defining_Identifier
(Loc
,
9062 Chars
=> New_Internal_Name
('S'));
9063 Res
: constant Entity_Id
:=
9064 Make_Defining_Identifier
(Loc
,
9065 Chars
=> New_Internal_Name
('R'));
9068 -- Strm : Buffer_Stream_Type;
9071 Make_Object_Declaration
(Loc
,
9072 Defining_Identifier
=> Strm
,
9073 Aliased_Present
=> True,
9074 Object_Definition
=>
9075 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
9077 -- Allocate_Buffer (Strm);
9080 Make_Procedure_Call_Statement
(Loc
,
9082 New_Occurrence_Of
(RTE
(RE_Allocate_Buffer
), Loc
),
9083 Parameter_Associations
=> New_List
(
9084 New_Occurrence_Of
(Strm
, Loc
))));
9086 -- Any_To_BS (Strm, A);
9089 Make_Procedure_Call_Statement
(Loc
,
9090 Name
=> New_Occurrence_Of
(RTE
(RE_Any_To_BS
), Loc
),
9091 Parameter_Associations
=> New_List
(
9092 New_Occurrence_Of
(Any_Parameter
, Loc
),
9093 New_Occurrence_Of
(Strm
, Loc
))));
9096 -- Res : constant T := T'Input (Strm);
9098 -- Release_Buffer (Strm);
9102 Append_To
(Stms
, Make_Block_Statement
(Loc
,
9103 Declarations
=> New_List
(
9104 Make_Object_Declaration
(Loc
,
9105 Defining_Identifier
=> Res
,
9106 Constant_Present
=> True,
9107 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
9109 Make_Attribute_Reference
(Loc
,
9110 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
9111 Attribute_Name
=> Name_Input
,
9112 Expressions
=> New_List
(
9113 Make_Attribute_Reference
(Loc
,
9114 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
9115 Attribute_Name
=> Name_Access
))))),
9117 Handled_Statement_Sequence
=>
9118 Make_Handled_Sequence_Of_Statements
(Loc
,
9119 Statements
=> New_List
(
9120 Make_Procedure_Call_Statement
(Loc
,
9122 New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
9123 Parameter_Associations
=>
9124 New_List
(New_Occurrence_Of
(Strm
, Loc
))),
9125 Make_Simple_Return_Statement
(Loc
,
9126 Expression
=> New_Occurrence_Of
(Res
, Loc
))))));
9132 Make_Subprogram_Body
(Loc
,
9133 Specification
=> Spec
,
9134 Declarations
=> Decls
,
9135 Handled_Statement_Sequence
=>
9136 Make_Handled_Sequence_Of_Statements
(Loc
,
9137 Statements
=> Stms
));
9138 end Build_From_Any_Function
;
9140 ---------------------------------
9141 -- Build_Get_Aggregate_Element --
9142 ---------------------------------
9144 function Build_Get_Aggregate_Element
9148 Idx
: Node_Id
) return Node_Id
9151 return Make_Function_Call
(Loc
,
9153 New_Occurrence_Of
(RTE
(RE_Get_Aggregate_Element
), Loc
),
9154 Parameter_Associations
=> New_List
(
9155 New_Occurrence_Of
(Any
, Loc
),
9158 end Build_Get_Aggregate_Element
;
9160 -------------------------
9161 -- Build_Reposiroty_Id --
9162 -------------------------
9164 procedure Build_Name_And_Repository_Id
9166 Name_Str
: out String_Id
;
9167 Repo_Id_Str
: out String_Id
)
9171 Store_String_Chars
("DSA:");
9172 Get_Library_Unit_Name_String
(Scope
(E
));
9174 (Name_Buffer
(Name_Buffer
'First ..
9175 Name_Buffer
'First + Name_Len
- 1));
9176 Store_String_Char
('.');
9177 Get_Name_String
(Chars
(E
));
9179 (Name_Buffer
(Name_Buffer
'First ..
9180 Name_Buffer
'First + Name_Len
- 1));
9181 Store_String_Chars
(":1.0");
9182 Repo_Id_Str
:= End_String
;
9183 Name_Str
:= String_From_Name_Buffer
;
9184 end Build_Name_And_Repository_Id
;
9186 -----------------------
9187 -- Build_To_Any_Call --
9188 -----------------------
9190 function Build_To_Any_Call
9192 Decls
: List_Id
) return Node_Id
9194 Loc
: constant Source_Ptr
:= Sloc
(N
);
9196 Typ
: Entity_Id
:= Etype
(N
);
9198 Fnam
: Entity_Id
:= Empty
;
9199 Lib_RE
: RE_Id
:= RE_Null
;
9202 -- If N is a selected component, then maybe its Etype has not been
9203 -- set yet: try to use Etype of the selector_name in that case.
9205 if No
(Typ
) and then Nkind
(N
) = N_Selected_Component
then
9206 Typ
:= Etype
(Selector_Name
(N
));
9208 pragma Assert
(Present
(Typ
));
9210 -- Get full view for private type, completion for incomplete type
9212 U_Type
:= Underlying_Type
(Typ
);
9214 -- First simple case where the To_Any function is present in the
9217 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_To_Any
);
9219 -- Check first for Boolean and Character. These are enumeration
9220 -- types, but we treat them specially, since they may require
9221 -- special handling in the transfer protocol. However, this
9222 -- special handling only applies if they have standard
9223 -- representation, otherwise they are treated like any other
9224 -- enumeration type.
9226 if Sloc
(U_Type
) <= Standard_Location
then
9227 U_Type
:= Base_Type
(U_Type
);
9230 if Present
(Fnam
) then
9233 elsif U_Type
= Standard_Boolean
then
9236 elsif U_Type
= Standard_Character
then
9239 elsif U_Type
= Standard_Wide_Character
then
9242 elsif U_Type
= Standard_Wide_Wide_Character
then
9243 Lib_RE
:= RE_TA_WWC
;
9245 -- Floating point types
9247 elsif U_Type
= Standard_Short_Float
then
9250 elsif U_Type
= Standard_Float
then
9253 elsif U_Type
= Standard_Long_Float
then
9256 elsif U_Type
= Standard_Long_Long_Float
then
9257 Lib_RE
:= RE_TA_LLF
;
9261 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
9262 Lib_RE
:= RE_TA_SSI
;
9264 elsif U_Type
= Etype
(Standard_Short_Integer
) then
9267 elsif U_Type
= Etype
(Standard_Integer
) then
9270 elsif U_Type
= Etype
(Standard_Long_Integer
) then
9273 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
9274 Lib_RE
:= RE_TA_LLI
;
9276 -- Unsigned integer types
9278 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
9279 Lib_RE
:= RE_TA_SSU
;
9281 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
9284 elsif U_Type
= RTE
(RE_Unsigned
) then
9287 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
9290 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
9291 Lib_RE
:= RE_TA_LLU
;
9293 elsif U_Type
= Standard_String
then
9294 Lib_RE
:= RE_TA_String
;
9296 elsif U_Type
= Underlying_Type
(RTE
(RE_TypeCode
)) then
9299 -- Other (non-primitive) types
9305 Build_To_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
9306 Append_To
(Decls
, Decl
);
9310 -- Call the function
9312 if Lib_RE
/= RE_Null
then
9313 pragma Assert
(No
(Fnam
));
9314 Fnam
:= RTE
(Lib_RE
);
9318 Make_Function_Call
(Loc
,
9319 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
9320 Parameter_Associations
=>
9321 New_List
(Unchecked_Convert_To
(U_Type
, N
)));
9322 end Build_To_Any_Call
;
9324 ---------------------------
9325 -- Build_To_Any_Function --
9326 ---------------------------
9328 procedure Build_To_Any_Function
9332 Fnam
: out Entity_Id
)
9335 Decls
: constant List_Id
:= New_List
;
9336 Stms
: constant List_Id
:= New_List
;
9338 Expr_Parameter
: constant Entity_Id
:=
9339 Make_Defining_Identifier
(Loc
, Name_E
);
9341 Any
: constant Entity_Id
:=
9342 Make_Defining_Identifier
(Loc
, Name_A
);
9345 Result_TC
: Node_Id
:= Build_TypeCode_Call
(Loc
, Typ
, Decls
);
9347 Use_Opaque_Representation
: Boolean;
9348 -- When True, use stream attributes and represent type as an
9349 -- opaque sequence of bytes.
9352 if Is_Itype
(Typ
) then
9353 Build_To_Any_Function
9362 Make_Stream_Procedure_Function_Name
(Loc
, Typ
, Name_uTo_Any
);
9365 Make_Function_Specification
(Loc
,
9366 Defining_Unit_Name
=> Fnam
,
9367 Parameter_Specifications
=> New_List
(
9368 Make_Parameter_Specification
(Loc
,
9369 Defining_Identifier
=> Expr_Parameter
,
9370 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
9371 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9372 Set_Etype
(Expr_Parameter
, Typ
);
9375 Make_Object_Declaration
(Loc
,
9376 Defining_Identifier
=> Any
,
9377 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9379 Use_Opaque_Representation
:= False;
9381 if Has_Stream_Attribute_Definition
9382 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
9384 Has_Stream_Attribute_Definition
9385 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
9387 -- If user-defined stream attributes are specified for this
9388 -- type, use them and transmit data as an opaque sequence of
9391 Use_Opaque_Representation
:= True;
9393 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9395 -- Non-tagged derived type: convert to root type
9398 Rt_Type
: constant Entity_Id
:= Root_Type
(Typ
);
9399 Expr
: constant Node_Id
:=
9402 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9404 Set_Expression
(Any_Decl
, Build_To_Any_Call
(Expr
, Decls
));
9407 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9409 -- Non-tagged record type
9411 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
9413 Rt_Type
: constant Entity_Id
:= Etype
(Typ
);
9414 Expr
: constant Node_Id
:=
9415 OK_Convert_To
(Rt_Type
,
9416 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9420 (Any_Decl
, Build_To_Any_Call
(Expr
, Decls
));
9423 -- Comment needed here (and label on declare block ???)
9427 Disc
: Entity_Id
:= Empty
;
9428 Rdef
: constant Node_Id
:=
9429 Type_Definition
(Declaration_Node
(Typ
));
9431 Elements
: constant List_Id
:= New_List
;
9433 procedure TA_Rec_Add_Process_Element
9435 Container
: Node_Or_Entity_Id
;
9436 Counter
: in out Int
;
9439 -- Processing routine for traversal below
9441 procedure TA_Append_Record_Traversal
is
9442 new Append_Record_Traversal
9443 (Rec
=> Expr_Parameter
,
9444 Add_Process_Element
=> TA_Rec_Add_Process_Element
);
9446 --------------------------------
9447 -- TA_Rec_Add_Process_Element --
9448 --------------------------------
9450 procedure TA_Rec_Add_Process_Element
9452 Container
: Node_Or_Entity_Id
;
9453 Counter
: in out Int
;
9457 Field_Ref
: Node_Id
;
9460 if Nkind
(Field
) = N_Defining_Identifier
then
9462 -- A regular component
9464 Field_Ref
:= Make_Selected_Component
(Loc
,
9465 Prefix
=> New_Occurrence_Of
(Rec
, Loc
),
9466 Selector_Name
=> New_Occurrence_Of
(Field
, Loc
));
9467 Set_Etype
(Field_Ref
, Etype
(Field
));
9470 Make_Procedure_Call_Statement
(Loc
,
9473 RTE
(RE_Add_Aggregate_Element
), Loc
),
9474 Parameter_Associations
=> New_List
(
9475 New_Occurrence_Of
(Container
, Loc
),
9476 Build_To_Any_Call
(Field_Ref
, Decls
))));
9481 Variant_Part
: declare
9483 Struct_Counter
: Int
:= 0;
9485 Block_Decls
: constant List_Id
:= New_List
;
9486 Block_Stmts
: constant List_Id
:= New_List
;
9489 Alt_List
: constant List_Id
:= New_List
;
9490 Choice_List
: List_Id
;
9492 Union_Any
: constant Entity_Id
:=
9493 Make_Defining_Identifier
(Loc
,
9494 New_Internal_Name
('V'));
9496 Struct_Any
: constant Entity_Id
:=
9497 Make_Defining_Identifier
(Loc
,
9498 New_Internal_Name
('S'));
9500 function Make_Discriminant_Reference
9502 -- Build reference to the discriminant for this
9505 ---------------------------------
9506 -- Make_Discriminant_Reference --
9507 ---------------------------------
9509 function Make_Discriminant_Reference
9512 Nod
: constant Node_Id
:=
9513 Make_Selected_Component
(Loc
,
9516 Chars
(Name
(Field
)));
9518 Set_Etype
(Nod
, Etype
(Name
(Field
)));
9520 end Make_Discriminant_Reference
;
9522 -- Start processing for Variant_Part
9526 Make_Block_Statement
(Loc
,
9529 Handled_Statement_Sequence
=>
9530 Make_Handled_Sequence_Of_Statements
(Loc
,
9531 Statements
=> Block_Stmts
)));
9533 -- Declare variant part aggregate (Union_Any).
9534 -- Knowing the position of this VP in the
9535 -- variant record, we can fetch the VP typecode
9538 Append_To
(Block_Decls
,
9539 Make_Object_Declaration
(Loc
,
9540 Defining_Identifier
=> Union_Any
,
9541 Object_Definition
=>
9542 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9544 Make_Function_Call
(Loc
,
9545 Name
=> New_Occurrence_Of
(
9546 RTE
(RE_Create_Any
), Loc
),
9547 Parameter_Associations
=> New_List
(
9548 Make_Function_Call
(Loc
,
9551 RTE
(RE_Any_Member_Type
), Loc
),
9552 Parameter_Associations
=> New_List
(
9553 New_Occurrence_Of
(Container
, Loc
),
9554 Make_Integer_Literal
(Loc
,
9557 -- Declare inner struct aggregate (which
9558 -- contains the components of this VP).
9560 Append_To
(Block_Decls
,
9561 Make_Object_Declaration
(Loc
,
9562 Defining_Identifier
=> Struct_Any
,
9563 Object_Definition
=>
9564 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9566 Make_Function_Call
(Loc
,
9567 Name
=> New_Occurrence_Of
(
9568 RTE
(RE_Create_Any
), Loc
),
9569 Parameter_Associations
=> New_List
(
9570 Make_Function_Call
(Loc
,
9573 RTE
(RE_Any_Member_Type
), Loc
),
9574 Parameter_Associations
=> New_List
(
9575 New_Occurrence_Of
(Union_Any
, Loc
),
9576 Make_Integer_Literal
(Loc
,
9579 -- Build case statement
9581 Append_To
(Block_Stmts
,
9582 Make_Case_Statement
(Loc
,
9583 Expression
=> Make_Discriminant_Reference
,
9584 Alternatives
=> Alt_List
));
9586 Variant
:= First_Non_Pragma
(Variants
(Field
));
9587 while Present
(Variant
) loop
9588 Choice_List
:= New_Copy_List_Tree
9589 (Discrete_Choices
(Variant
));
9591 VP_Stmts
:= New_List
;
9593 -- Append discriminant val to union aggregate
9595 Append_To
(VP_Stmts
,
9596 Make_Procedure_Call_Statement
(Loc
,
9599 RTE
(RE_Add_Aggregate_Element
), Loc
),
9600 Parameter_Associations
=> New_List
(
9601 New_Occurrence_Of
(Union_Any
, Loc
),
9603 (Make_Discriminant_Reference
,
9606 -- Populate inner struct aggregate
9608 -- Struct_Counter should be reset before
9609 -- handling a variant part. Indeed only one
9610 -- of the case statement alternatives will be
9611 -- executed at run-time, so the counter must
9612 -- start at 0 for every case statement.
9614 Struct_Counter
:= 0;
9616 TA_Append_Record_Traversal
(
9618 Clist
=> Component_List
(Variant
),
9619 Container
=> Struct_Any
,
9620 Counter
=> Struct_Counter
);
9622 -- Append inner struct to union aggregate
9624 Append_To
(VP_Stmts
,
9625 Make_Procedure_Call_Statement
(Loc
,
9628 RTE
(RE_Add_Aggregate_Element
), Loc
),
9629 Parameter_Associations
=> New_List
(
9630 New_Occurrence_Of
(Union_Any
, Loc
),
9631 New_Occurrence_Of
(Struct_Any
, Loc
))));
9633 -- Append union to outer aggregate
9635 Append_To
(VP_Stmts
,
9636 Make_Procedure_Call_Statement
(Loc
,
9639 RTE
(RE_Add_Aggregate_Element
), Loc
),
9640 Parameter_Associations
=> New_List
(
9641 New_Occurrence_Of
(Container
, Loc
),
9643 (Union_Any
, Loc
))));
9645 Append_To
(Alt_List
,
9646 Make_Case_Statement_Alternative
(Loc
,
9647 Discrete_Choices
=> Choice_List
,
9648 Statements
=> VP_Stmts
));
9650 Next_Non_Pragma
(Variant
);
9655 Counter
:= Counter
+ 1;
9656 end TA_Rec_Add_Process_Element
;
9659 -- Records are encoded in a TC_STRUCT aggregate:
9661 -- -- Outer aggregate (TC_STRUCT)
9662 -- | [discriminant1]
9663 -- | [discriminant2]
9670 -- A component can be a common component or variant part
9672 -- A variant part is encoded as a TC_UNION aggregate:
9674 -- -- Variant Part Aggregate (TC_UNION)
9675 -- | [discriminant choice for this Variant Part]
9677 -- | -- Inner struct (TC_STRUCT)
9682 -- Let's start by building the outer aggregate. First we
9683 -- construct Elements array containing all discriminants.
9685 if Has_Discriminants
(Typ
) then
9686 Disc
:= First_Discriminant
(Typ
);
9687 while Present
(Disc
) loop
9689 Discriminant
: constant Entity_Id
:=
9690 Make_Selected_Component
(Loc
,
9697 Set_Etype
(Discriminant
, Etype
(Disc
));
9699 Append_To
(Elements
,
9700 Make_Component_Association
(Loc
,
9701 Choices
=> New_List
(
9702 Make_Integer_Literal
(Loc
, Counter
)),
9704 Build_To_Any_Call
(Discriminant
, Decls
)));
9707 Counter
:= Counter
+ 1;
9708 Next_Discriminant
(Disc
);
9712 -- If there are no discriminants, we declare an empty
9716 Dummy_Any
: constant Entity_Id
:=
9717 Make_Defining_Identifier
(Loc
,
9718 Chars
=> New_Internal_Name
('A'));
9722 Make_Object_Declaration
(Loc
,
9723 Defining_Identifier
=> Dummy_Any
,
9724 Object_Definition
=>
9725 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
9727 Append_To
(Elements
,
9728 Make_Component_Association
(Loc
,
9729 Choices
=> New_List
(
9732 Make_Integer_Literal
(Loc
, 1),
9734 Make_Integer_Literal
(Loc
, 0))),
9736 New_Occurrence_Of
(Dummy_Any
, Loc
)));
9740 -- We build the result aggregate with discriminants
9741 -- as the first elements.
9743 Set_Expression
(Any_Decl
,
9744 Make_Function_Call
(Loc
,
9745 Name
=> New_Occurrence_Of
(
9746 RTE
(RE_Any_Aggregate_Build
), Loc
),
9747 Parameter_Associations
=> New_List
(
9749 Make_Aggregate
(Loc
,
9750 Component_Associations
=> Elements
))));
9753 -- Then we append all the components to the result
9756 TA_Append_Record_Traversal
(Stms
,
9757 Clist
=> Component_List
(Rdef
),
9759 Counter
=> Counter
);
9763 elsif Is_Array_Type
(Typ
) then
9765 -- Constrained and unconstrained array types
9768 Constrained
: constant Boolean := Is_Constrained
(Typ
);
9770 procedure TA_Ary_Add_Process_Element
9773 Counter
: Entity_Id
;
9776 --------------------------------
9777 -- TA_Ary_Add_Process_Element --
9778 --------------------------------
9780 procedure TA_Ary_Add_Process_Element
9783 Counter
: Entity_Id
;
9786 pragma Warnings
(Off
);
9787 pragma Unreferenced
(Counter
);
9788 pragma Warnings
(On
);
9790 Element_Any
: Node_Id
;
9793 if Etype
(Datum
) = RTE
(RE_Any
) then
9794 Element_Any
:= Datum
;
9796 Element_Any
:= Build_To_Any_Call
(Datum
, Decls
);
9800 Make_Procedure_Call_Statement
(Loc
,
9801 Name
=> New_Occurrence_Of
(
9802 RTE
(RE_Add_Aggregate_Element
), Loc
),
9803 Parameter_Associations
=> New_List
(
9804 New_Occurrence_Of
(Any
, Loc
),
9806 end TA_Ary_Add_Process_Element
;
9808 procedure Append_To_Any_Array_Iterator
is
9809 new Append_Array_Traversal
(
9811 Arry
=> Expr_Parameter
,
9812 Indices
=> New_List
,
9813 Add_Process_Element
=> TA_Ary_Add_Process_Element
);
9818 Set_Expression
(Any_Decl
,
9819 Make_Function_Call
(Loc
,
9821 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
9822 Parameter_Associations
=> New_List
(Result_TC
)));
9825 if not Constrained
then
9826 Index
:= First_Index
(Typ
);
9827 for J
in 1 .. Number_Dimensions
(Typ
) loop
9829 Make_Procedure_Call_Statement
(Loc
,
9832 RTE
(RE_Add_Aggregate_Element
), Loc
),
9833 Parameter_Associations
=> New_List
(
9834 New_Occurrence_Of
(Any
, Loc
),
9836 OK_Convert_To
(Etype
(Index
),
9837 Make_Attribute_Reference
(Loc
,
9839 New_Occurrence_Of
(Expr_Parameter
, Loc
),
9840 Attribute_Name
=> Name_First
,
9841 Expressions
=> New_List
(
9842 Make_Integer_Literal
(Loc
, J
)))),
9848 Append_To_Any_Array_Iterator
(Stms
, Any
);
9851 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9855 Set_Expression
(Any_Decl
,
9858 Find_Numeric_Representation
(Typ
),
9859 New_Occurrence_Of
(Expr_Parameter
, Loc
)),
9863 -- Default case, including tagged types: opaque representation
9865 Use_Opaque_Representation
:= True;
9868 if Use_Opaque_Representation
then
9870 Strm
: constant Entity_Id
:=
9871 Make_Defining_Identifier
(Loc
,
9872 Chars
=> New_Internal_Name
('S'));
9873 -- Stream used to store data representation produced by
9874 -- stream attribute.
9878 -- Strm : aliased Buffer_Stream_Type;
9881 Make_Object_Declaration
(Loc
,
9882 Defining_Identifier
=>
9886 Object_Definition
=>
9887 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
9890 -- Allocate_Buffer (Strm);
9893 Make_Procedure_Call_Statement
(Loc
,
9895 New_Occurrence_Of
(RTE
(RE_Allocate_Buffer
), Loc
),
9896 Parameter_Associations
=> New_List
(
9897 New_Occurrence_Of
(Strm
, Loc
))));
9900 -- T'Output (Strm'Access, E);
9903 Make_Attribute_Reference
(Loc
,
9904 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
9905 Attribute_Name
=> Name_Output
,
9906 Expressions
=> New_List
(
9907 Make_Attribute_Reference
(Loc
,
9908 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
9909 Attribute_Name
=> Name_Access
),
9910 New_Occurrence_Of
(Expr_Parameter
, Loc
))));
9913 -- BS_To_Any (Strm, A);
9916 Make_Procedure_Call_Statement
(Loc
,
9917 Name
=> New_Occurrence_Of
(RTE
(RE_BS_To_Any
), Loc
),
9918 Parameter_Associations
=> New_List
(
9919 New_Occurrence_Of
(Strm
, Loc
),
9920 New_Occurrence_Of
(Any
, Loc
))));
9923 -- Release_Buffer (Strm);
9926 Make_Procedure_Call_Statement
(Loc
,
9927 Name
=> New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
9928 Parameter_Associations
=> New_List
(
9929 New_Occurrence_Of
(Strm
, Loc
))));
9933 Append_To
(Decls
, Any_Decl
);
9935 if Present
(Result_TC
) then
9937 Make_Procedure_Call_Statement
(Loc
,
9938 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
9939 Parameter_Associations
=> New_List
(
9940 New_Occurrence_Of
(Any
, Loc
),
9945 Make_Simple_Return_Statement
(Loc
,
9946 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
9949 Make_Subprogram_Body
(Loc
,
9950 Specification
=> Spec
,
9951 Declarations
=> Decls
,
9952 Handled_Statement_Sequence
=>
9953 Make_Handled_Sequence_Of_Statements
(Loc
,
9954 Statements
=> Stms
));
9955 end Build_To_Any_Function
;
9957 -------------------------
9958 -- Build_TypeCode_Call --
9959 -------------------------
9961 function Build_TypeCode_Call
9964 Decls
: List_Id
) return Node_Id
9966 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
9967 -- The full view, if Typ is private; the completion,
9968 -- if Typ is incomplete.
9970 Fnam
: Entity_Id
:= Empty
;
9971 Lib_RE
: RE_Id
:= RE_Null
;
9975 -- Special case System.PolyORB.Interface.Any: its primitives have
9976 -- not been set yet, so can't call Find_Inherited_TSS.
9978 if Typ
= RTE
(RE_Any
) then
9979 Fnam
:= RTE
(RE_TC_Any
);
9982 -- First simple case where the TypeCode is present
9983 -- in the type's TSS.
9985 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_TypeCode
);
9989 if Sloc
(U_Type
) <= Standard_Location
then
9991 -- Do not try to build alias typecodes for subtypes from
9994 U_Type
:= Base_Type
(U_Type
);
9997 if U_Type
= Standard_Boolean
then
10000 elsif U_Type
= Standard_Character
then
10003 elsif U_Type
= Standard_Wide_Character
then
10004 Lib_RE
:= RE_TC_WC
;
10006 elsif U_Type
= Standard_Wide_Wide_Character
then
10007 Lib_RE
:= RE_TC_WWC
;
10009 -- Floating point types
10011 elsif U_Type
= Standard_Short_Float
then
10012 Lib_RE
:= RE_TC_SF
;
10014 elsif U_Type
= Standard_Float
then
10017 elsif U_Type
= Standard_Long_Float
then
10018 Lib_RE
:= RE_TC_LF
;
10020 elsif U_Type
= Standard_Long_Long_Float
then
10021 Lib_RE
:= RE_TC_LLF
;
10023 -- Integer types (walk back to the base type)
10025 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
10026 Lib_RE
:= RE_TC_SSI
;
10028 elsif U_Type
= Etype
(Standard_Short_Integer
) then
10029 Lib_RE
:= RE_TC_SI
;
10031 elsif U_Type
= Etype
(Standard_Integer
) then
10034 elsif U_Type
= Etype
(Standard_Long_Integer
) then
10035 Lib_RE
:= RE_TC_LI
;
10037 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
10038 Lib_RE
:= RE_TC_LLI
;
10040 -- Unsigned integer types
10042 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
10043 Lib_RE
:= RE_TC_SSU
;
10045 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
10046 Lib_RE
:= RE_TC_SU
;
10048 elsif U_Type
= RTE
(RE_Unsigned
) then
10051 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
10052 Lib_RE
:= RE_TC_LU
;
10054 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
10055 Lib_RE
:= RE_TC_LLU
;
10057 elsif U_Type
= Standard_String
then
10058 Lib_RE
:= RE_TC_String
;
10060 -- Other (non-primitive) types
10066 Build_TypeCode_Function
(Loc
, U_Type
, Decl
, Fnam
);
10067 Append_To
(Decls
, Decl
);
10071 if Lib_RE
/= RE_Null
then
10072 Fnam
:= RTE
(Lib_RE
);
10076 -- Call the function
10079 Make_Function_Call
(Loc
, Name
=> New_Occurrence_Of
(Fnam
, Loc
));
10081 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10083 Set_Etype
(Expr
, RTE
(RE_TypeCode
));
10086 end Build_TypeCode_Call
;
10088 -----------------------------
10089 -- Build_TypeCode_Function --
10090 -----------------------------
10092 procedure Build_TypeCode_Function
10095 Decl
: out Node_Id
;
10096 Fnam
: out Entity_Id
)
10099 Decls
: constant List_Id
:= New_List
;
10100 Stms
: constant List_Id
:= New_List
;
10102 TCNam
: constant Entity_Id
:=
10103 Make_Stream_Procedure_Function_Name
(Loc
,
10104 Typ
, Name_uTypeCode
);
10106 Parameters
: List_Id
;
10108 procedure Add_String_Parameter
10110 Parameter_List
: List_Id
);
10111 -- Add a literal for S to Parameters
10113 procedure Add_TypeCode_Parameter
10114 (TC_Node
: Node_Id
;
10115 Parameter_List
: List_Id
);
10116 -- Add the typecode for Typ to Parameters
10118 procedure Add_Long_Parameter
10119 (Expr_Node
: Node_Id
;
10120 Parameter_List
: List_Id
);
10121 -- Add a signed long integer expression to Parameters
10123 procedure Initialize_Parameter_List
10124 (Name_String
: String_Id
;
10125 Repo_Id_String
: String_Id
;
10126 Parameter_List
: out List_Id
);
10127 -- Return a list that contains the first two parameters
10128 -- for a parameterized typecode: name and repository id.
10130 function Make_Constructed_TypeCode
10132 Parameters
: List_Id
) return Node_Id
;
10133 -- Call TC_Build with the given kind and parameters
10135 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
);
10136 -- Make a return statement that calls TC_Build with the given
10137 -- typecode kind, and the constructed parameters list.
10139 procedure Return_Alias_TypeCode
(Base_TypeCode
: Node_Id
);
10140 -- Return a typecode that is a TC_Alias for the given typecode
10142 --------------------------
10143 -- Add_String_Parameter --
10144 --------------------------
10146 procedure Add_String_Parameter
10148 Parameter_List
: List_Id
)
10151 Append_To
(Parameter_List
,
10152 Make_Function_Call
(Loc
,
10153 Name
=> New_Occurrence_Of
(RTE
(RE_TA_String
), Loc
),
10154 Parameter_Associations
=> New_List
(
10155 Make_String_Literal
(Loc
, S
))));
10156 end Add_String_Parameter
;
10158 ----------------------------
10159 -- Add_TypeCode_Parameter --
10160 ----------------------------
10162 procedure Add_TypeCode_Parameter
10163 (TC_Node
: Node_Id
;
10164 Parameter_List
: List_Id
)
10167 Append_To
(Parameter_List
,
10168 Make_Function_Call
(Loc
,
10169 Name
=> New_Occurrence_Of
(RTE
(RE_TA_TC
), Loc
),
10170 Parameter_Associations
=> New_List
(TC_Node
)));
10171 end Add_TypeCode_Parameter
;
10173 ------------------------
10174 -- Add_Long_Parameter --
10175 ------------------------
10177 procedure Add_Long_Parameter
10178 (Expr_Node
: Node_Id
;
10179 Parameter_List
: List_Id
)
10182 Append_To
(Parameter_List
,
10183 Make_Function_Call
(Loc
,
10184 Name
=> New_Occurrence_Of
(RTE
(RE_TA_LI
), Loc
),
10185 Parameter_Associations
=> New_List
(Expr_Node
)));
10186 end Add_Long_Parameter
;
10188 -------------------------------
10189 -- Initialize_Parameter_List --
10190 -------------------------------
10192 procedure Initialize_Parameter_List
10193 (Name_String
: String_Id
;
10194 Repo_Id_String
: String_Id
;
10195 Parameter_List
: out List_Id
)
10198 Parameter_List
:= New_List
;
10199 Add_String_Parameter
(Name_String
, Parameter_List
);
10200 Add_String_Parameter
(Repo_Id_String
, Parameter_List
);
10201 end Initialize_Parameter_List
;
10203 ---------------------------
10204 -- Return_Alias_TypeCode --
10205 ---------------------------
10207 procedure Return_Alias_TypeCode
10208 (Base_TypeCode
: Node_Id
)
10211 Add_TypeCode_Parameter
(Base_TypeCode
, Parameters
);
10212 Return_Constructed_TypeCode
(RTE
(RE_TC_Alias
));
10213 end Return_Alias_TypeCode
;
10215 -------------------------------
10216 -- Make_Constructed_TypeCode --
10217 -------------------------------
10219 function Make_Constructed_TypeCode
10221 Parameters
: List_Id
) return Node_Id
10223 Constructed_TC
: constant Node_Id
:=
10224 Make_Function_Call
(Loc
,
10226 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
10227 Parameter_Associations
=> New_List
(
10228 New_Occurrence_Of
(Kind
, Loc
),
10229 Make_Aggregate
(Loc
,
10230 Expressions
=> Parameters
)));
10232 Set_Etype
(Constructed_TC
, RTE
(RE_TypeCode
));
10233 return Constructed_TC
;
10234 end Make_Constructed_TypeCode
;
10236 ---------------------------------
10237 -- Return_Constructed_TypeCode --
10238 ---------------------------------
10240 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
) is
10243 Make_Simple_Return_Statement
(Loc
,
10245 Make_Constructed_TypeCode
(Kind
, Parameters
)));
10246 end Return_Constructed_TypeCode
;
10252 procedure TC_Rec_Add_Process_Element
10255 Counter
: in out Int
;
10259 procedure TC_Append_Record_Traversal
is
10260 new Append_Record_Traversal
(
10262 Add_Process_Element
=> TC_Rec_Add_Process_Element
);
10264 --------------------------------
10265 -- TC_Rec_Add_Process_Element --
10266 --------------------------------
10268 procedure TC_Rec_Add_Process_Element
10271 Counter
: in out Int
;
10275 pragma Warnings
(Off
);
10276 pragma Unreferenced
(Any
, Counter
, Rec
);
10277 pragma Warnings
(On
);
10280 if Nkind
(Field
) = N_Defining_Identifier
then
10282 -- A regular component
10284 Add_TypeCode_Parameter
10285 (Build_TypeCode_Call
(Loc
, Etype
(Field
), Decls
), Params
);
10286 Get_Name_String
(Chars
(Field
));
10287 Add_String_Parameter
(String_From_Name_Buffer
, Params
);
10294 Discriminant_Type
: constant Entity_Id
:=
10295 Etype
(Name
(Field
));
10297 Is_Enum
: constant Boolean :=
10298 Is_Enumeration_Type
(Discriminant_Type
);
10300 Union_TC_Params
: List_Id
;
10302 U_Name
: constant Name_Id
:=
10303 New_External_Name
(Chars
(Typ
), 'V', -1);
10305 Name_Str
: String_Id
;
10306 Struct_TC_Params
: List_Id
;
10310 Default
: constant Node_Id
:=
10311 Make_Integer_Literal
(Loc
, -1);
10313 Dummy_Counter
: Int
:= 0;
10315 Choice_Index
: Int
:= 0;
10317 procedure Add_Params_For_Variant_Components
;
10318 -- Add a struct TypeCode and a corresponding member name
10319 -- to the union parameter list.
10321 -- Ordering of declarations is a complete mess in this
10322 -- area, it is supposed to be types/varibles, then
10323 -- subprogram specs, then subprogram bodies ???
10325 ---------------------------------------
10326 -- Add_Params_For_Variant_Components --
10327 ---------------------------------------
10329 procedure Add_Params_For_Variant_Components
10331 S_Name
: constant Name_Id
:=
10332 New_External_Name
(U_Name
, 'S', -1);
10335 Get_Name_String
(S_Name
);
10336 Name_Str
:= String_From_Name_Buffer
;
10337 Initialize_Parameter_List
10338 (Name_Str
, Name_Str
, Struct_TC_Params
);
10340 -- Build struct parameters
10342 TC_Append_Record_Traversal
(Struct_TC_Params
,
10343 Component_List
(Variant
),
10347 Add_TypeCode_Parameter
10348 (Make_Constructed_TypeCode
10349 (RTE
(RE_TC_Struct
), Struct_TC_Params
),
10352 Add_String_Parameter
(Name_Str
, Union_TC_Params
);
10353 end Add_Params_For_Variant_Components
;
10356 Get_Name_String
(U_Name
);
10357 Name_Str
:= String_From_Name_Buffer
;
10359 Initialize_Parameter_List
10360 (Name_Str
, Name_Str
, Union_TC_Params
);
10362 -- Add union in enclosing parameter list
10364 Add_TypeCode_Parameter
10365 (Make_Constructed_TypeCode
10366 (RTE
(RE_TC_Union
), Union_TC_Params
),
10369 Add_String_Parameter
(Name_Str
, Params
);
10371 -- Build union parameters
10373 Add_TypeCode_Parameter
10374 (Build_TypeCode_Call
10375 (Loc
, Discriminant_Type
, Decls
),
10378 Add_Long_Parameter
(Default
, Union_TC_Params
);
10380 Variant
:= First_Non_Pragma
(Variants
(Field
));
10381 while Present
(Variant
) loop
10382 Choice
:= First
(Discrete_Choices
(Variant
));
10383 while Present
(Choice
) loop
10384 case Nkind
(Choice
) is
10387 L
: constant Uint
:=
10388 Expr_Value
(Low_Bound
(Choice
));
10389 H
: constant Uint
:=
10390 Expr_Value
(High_Bound
(Choice
));
10392 -- 3.8.1(8) guarantees that the bounds of
10393 -- this range are static.
10400 Expr
:= New_Occurrence_Of
(
10401 Get_Enum_Lit_From_Pos
(
10402 Discriminant_Type
, J
, Loc
), Loc
);
10405 Make_Integer_Literal
(Loc
, J
);
10407 Append_To
(Union_TC_Params
,
10408 Build_To_Any_Call
(Expr
, Decls
));
10410 Add_Params_For_Variant_Components
;
10415 when N_Others_Choice
=>
10417 -- This variant possess a default choice.
10418 -- We must therefore set the default
10419 -- parameter to the current choice index. The
10420 -- default parameter is by construction the
10421 -- fourth in the Union_TC_Params list.
10424 Default_Node
: constant Node_Id
:=
10425 Pick
(Union_TC_Params
, 4);
10427 New_Default_Node
: constant Node_Id
:=
10428 Make_Function_Call
(Loc
,
10431 (RTE
(RE_TA_LI
), Loc
),
10432 Parameter_Associations
=>
10434 Make_Integer_Literal
10435 (Loc
, Choice_Index
)));
10441 Remove
(Default_Node
);
10444 -- Add a placeholder member label
10445 -- for the default case.
10446 -- It must be of the discriminant type.
10449 Exp
: constant Node_Id
:=
10450 Make_Attribute_Reference
(Loc
,
10451 Prefix
=> New_Occurrence_Of
10452 (Discriminant_Type
, Loc
),
10453 Attribute_Name
=> Name_First
);
10455 Set_Etype
(Exp
, Discriminant_Type
);
10456 Append_To
(Union_TC_Params
,
10457 Build_To_Any_Call
(Exp
, Decls
));
10460 Add_Params_For_Variant_Components
;
10464 -- Case of an explicit choice
10467 Exp
: constant Node_Id
:=
10468 New_Copy_Tree
(Choice
);
10470 Append_To
(Union_TC_Params
,
10471 Build_To_Any_Call
(Exp
, Decls
));
10474 Add_Params_For_Variant_Components
;
10478 Choice_Index
:= Choice_Index
+ 1;
10481 Next_Non_Pragma
(Variant
);
10485 end TC_Rec_Add_Process_Element
;
10487 Type_Name_Str
: String_Id
;
10488 Type_Repo_Id_Str
: String_Id
;
10491 if Is_Itype
(Typ
) then
10492 Build_TypeCode_Function
10494 Typ
=> Etype
(Typ
),
10503 Make_Function_Specification
(Loc
,
10504 Defining_Unit_Name
=> Fnam
,
10505 Parameter_Specifications
=> Empty_List
,
10506 Result_Definition
=>
10507 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
10509 Build_Name_And_Repository_Id
(Typ
,
10510 Name_Str
=> Type_Name_Str
, Repo_Id_Str
=> Type_Repo_Id_Str
);
10512 Initialize_Parameter_List
10513 (Type_Name_Str
, Type_Repo_Id_Str
, Parameters
);
10515 if Has_Stream_Attribute_Definition
10516 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
10518 Has_Stream_Attribute_Definition
10519 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
10521 -- If user-defined stream attributes are specified for this
10522 -- type, use them and transmit data as an opaque sequence of
10523 -- stream elements.
10525 Return_Alias_TypeCode
10526 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10528 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
10529 Return_Alias_TypeCode
(
10530 Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10532 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
10533 Return_Alias_TypeCode
(
10534 Build_TypeCode_Call
(Loc
,
10535 Find_Numeric_Representation
(Typ
), Decls
));
10537 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
10539 -- Record typecodes are encoded as follows:
10543 -- | [Repository Id]
10545 -- Then for each discriminant:
10547 -- | [Discriminant Type Code]
10548 -- | [Discriminant Name]
10551 -- Then for each component:
10553 -- | [Component Type Code]
10554 -- | [Component Name]
10557 -- Variants components type codes are encoded as follows:
10561 -- | [Repository Id]
10562 -- | [Discriminant Type Code]
10563 -- | [Index of Default Variant Part or -1 for no default]
10565 -- Then for each Variant Part :
10570 -- | | [Variant Part Name]
10571 -- | | [Variant Part Repository Id]
10573 -- | Then for each VP component:
10574 -- | | [VP component Typecode]
10575 -- | | [VP component Name]
10581 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
10582 Return_Alias_TypeCode
10583 (Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10587 Disc
: Entity_Id
:= Empty
;
10588 Rdef
: constant Node_Id
:=
10589 Type_Definition
(Declaration_Node
(Typ
));
10590 Dummy_Counter
: Int
:= 0;
10593 -- Construct the discriminants typecodes
10595 if Has_Discriminants
(Typ
) then
10596 Disc
:= First_Discriminant
(Typ
);
10599 while Present
(Disc
) loop
10600 Add_TypeCode_Parameter
(
10601 Build_TypeCode_Call
(Loc
, Etype
(Disc
), Decls
),
10603 Get_Name_String
(Chars
(Disc
));
10604 Add_String_Parameter
(
10605 String_From_Name_Buffer
,
10607 Next_Discriminant
(Disc
);
10610 -- then the components typecodes
10612 TC_Append_Record_Traversal
10613 (Parameters
, Component_List
(Rdef
),
10614 Empty
, Dummy_Counter
);
10615 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10619 elsif Is_Array_Type
(Typ
) then
10621 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10622 Inner_TypeCode
: Node_Id
;
10623 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10624 Indx
: Node_Id
:= First_Index
(Typ
);
10628 Build_TypeCode_Call
(Loc
, Component_Type
(Typ
), Decls
);
10630 for J
in 1 .. Ndim
loop
10631 if Constrained
then
10632 Inner_TypeCode
:= Make_Constructed_TypeCode
10633 (RTE
(RE_TC_Array
), New_List
(
10634 Build_To_Any_Call
(
10635 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10636 Make_Attribute_Reference
(Loc
,
10637 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
10638 Attribute_Name
=> Name_Length
,
10639 Expressions
=> New_List
(
10640 Make_Integer_Literal
(Loc
,
10641 Intval
=> Ndim
- J
+ 1)))),
10643 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10646 -- Unconstrained case: add low bound for each
10649 Add_TypeCode_Parameter
10650 (Build_TypeCode_Call
(Loc
, Etype
(Indx
), Decls
),
10652 Get_Name_String
(New_External_Name
('L', J
));
10653 Add_String_Parameter
(
10654 String_From_Name_Buffer
,
10658 Inner_TypeCode
:= Make_Constructed_TypeCode
10659 (RTE
(RE_TC_Sequence
), New_List
(
10660 Build_To_Any_Call
(
10661 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10662 Make_Integer_Literal
(Loc
, 0)),
10664 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10668 if Constrained
then
10669 Return_Alias_TypeCode
(Inner_TypeCode
);
10671 Add_TypeCode_Parameter
(Inner_TypeCode
, Parameters
);
10673 Store_String_Char
('V');
10674 Add_String_Parameter
(End_String
, Parameters
);
10675 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10680 -- Default: type is represented as an opaque sequence of bytes
10682 Return_Alias_TypeCode
10683 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10687 Make_Subprogram_Body
(Loc
,
10688 Specification
=> Spec
,
10689 Declarations
=> Decls
,
10690 Handled_Statement_Sequence
=>
10691 Make_Handled_Sequence_Of_Statements
(Loc
,
10692 Statements
=> Stms
));
10693 end Build_TypeCode_Function
;
10695 ---------------------------------
10696 -- Find_Numeric_Representation --
10697 ---------------------------------
10699 function Find_Numeric_Representation
10700 (Typ
: Entity_Id
) return Entity_Id
10702 FST
: constant Entity_Id
:= First_Subtype
(Typ
);
10703 P_Size
: constant Uint
:= Esize
(FST
);
10706 if Is_Unsigned_Type
(Typ
) then
10707 if P_Size
<= Standard_Short_Short_Integer_Size
then
10708 return RTE
(RE_Short_Short_Unsigned
);
10710 elsif P_Size
<= Standard_Short_Integer_Size
then
10711 return RTE
(RE_Short_Unsigned
);
10713 elsif P_Size
<= Standard_Integer_Size
then
10714 return RTE
(RE_Unsigned
);
10716 elsif P_Size
<= Standard_Long_Integer_Size
then
10717 return RTE
(RE_Long_Unsigned
);
10720 return RTE
(RE_Long_Long_Unsigned
);
10723 elsif Is_Integer_Type
(Typ
) then
10724 if P_Size
<= Standard_Short_Short_Integer_Size
then
10725 return Standard_Short_Short_Integer
;
10727 elsif P_Size
<= Standard_Short_Integer_Size
then
10728 return Standard_Short_Integer
;
10730 elsif P_Size
<= Standard_Integer_Size
then
10731 return Standard_Integer
;
10733 elsif P_Size
<= Standard_Long_Integer_Size
then
10734 return Standard_Long_Integer
;
10737 return Standard_Long_Long_Integer
;
10740 elsif Is_Floating_Point_Type
(Typ
) then
10741 if P_Size
<= Standard_Short_Float_Size
then
10742 return Standard_Short_Float
;
10744 elsif P_Size
<= Standard_Float_Size
then
10745 return Standard_Float
;
10747 elsif P_Size
<= Standard_Long_Float_Size
then
10748 return Standard_Long_Float
;
10751 return Standard_Long_Long_Float
;
10755 raise Program_Error
;
10758 -- TBD: fixed point types???
10759 -- TBverified numeric types with a biased representation???
10761 end Find_Numeric_Representation
;
10763 ---------------------------
10764 -- Append_Array_Traversal --
10765 ---------------------------
10767 procedure Append_Array_Traversal
10770 Counter
: Entity_Id
:= Empty
;
10773 Loc
: constant Source_Ptr
:= Sloc
(Subprogram
);
10774 Typ
: constant Entity_Id
:= Etype
(Arry
);
10775 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10776 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10778 Inner_Any
, Inner_Counter
: Entity_Id
;
10780 Loop_Stm
: Node_Id
;
10781 Inner_Stmts
: constant List_Id
:= New_List
;
10784 if Depth
> Ndim
then
10786 -- Processing for one element of an array
10789 Element_Expr
: constant Node_Id
:=
10790 Make_Indexed_Component
(Loc
,
10791 New_Occurrence_Of
(Arry
, Loc
),
10794 Set_Etype
(Element_Expr
, Component_Type
(Typ
));
10795 Add_Process_Element
(Stmts
,
10797 Counter
=> Counter
,
10798 Datum
=> Element_Expr
);
10804 Append_To
(Indices
,
10805 Make_Identifier
(Loc
, New_External_Name
('L', Depth
)));
10807 if not Constrained
or else Depth
> 1 then
10808 Inner_Any
:= Make_Defining_Identifier
(Loc
,
10809 New_External_Name
('A', Depth
));
10810 Set_Etype
(Inner_Any
, RTE
(RE_Any
));
10812 Inner_Any
:= Empty
;
10815 if Present
(Counter
) then
10816 Inner_Counter
:= Make_Defining_Identifier
(Loc
,
10817 New_External_Name
('J', Depth
));
10819 Inner_Counter
:= Empty
;
10823 Loop_Any
: Node_Id
:= Inner_Any
;
10826 -- For the first dimension of a constrained array, we add
10827 -- elements directly in the corresponding Any; there is no
10828 -- intervening inner Any.
10830 if No
(Loop_Any
) then
10834 Append_Array_Traversal
(Inner_Stmts
,
10836 Counter
=> Inner_Counter
,
10837 Depth
=> Depth
+ 1);
10841 Make_Implicit_Loop_Statement
(Subprogram
,
10842 Iteration_Scheme
=>
10843 Make_Iteration_Scheme
(Loc
,
10844 Loop_Parameter_Specification
=>
10845 Make_Loop_Parameter_Specification
(Loc
,
10846 Defining_Identifier
=>
10847 Make_Defining_Identifier
(Loc
,
10848 Chars
=> New_External_Name
('L', Depth
)),
10850 Discrete_Subtype_Definition
=>
10851 Make_Attribute_Reference
(Loc
,
10852 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10853 Attribute_Name
=> Name_Range
,
10855 Expressions
=> New_List
(
10856 Make_Integer_Literal
(Loc
, Depth
))))),
10857 Statements
=> Inner_Stmts
);
10860 Decls
: constant List_Id
:= New_List
;
10861 Dimen_Stmts
: constant List_Id
:= New_List
;
10862 Length_Node
: Node_Id
;
10864 Inner_Any_TypeCode
: constant Entity_Id
:=
10865 Make_Defining_Identifier
(Loc
,
10866 New_External_Name
('T', Depth
));
10868 Inner_Any_TypeCode_Expr
: Node_Id
;
10872 if Constrained
then
10873 Inner_Any_TypeCode_Expr
:=
10874 Make_Function_Call
(Loc
,
10875 Name
=> New_Occurrence_Of
(RTE
(RE_Get_TC
), Loc
),
10876 Parameter_Associations
=> New_List
(
10877 New_Occurrence_Of
(Any
, Loc
)));
10879 Inner_Any_TypeCode_Expr
:=
10880 Make_Function_Call
(Loc
,
10882 New_Occurrence_Of
(RTE
(RE_Any_Member_Type
), Loc
),
10883 Parameter_Associations
=> New_List
(
10884 New_Occurrence_Of
(Any
, Loc
),
10885 Make_Integer_Literal
(Loc
, Ndim
)));
10888 Inner_Any_TypeCode_Expr
:=
10889 Make_Function_Call
(Loc
,
10890 Name
=> New_Occurrence_Of
(RTE
(RE_Content_Type
), Loc
),
10891 Parameter_Associations
=> New_List
(
10892 Make_Identifier
(Loc
,
10893 Chars
=> New_External_Name
('T', Depth
- 1))));
10897 Make_Object_Declaration
(Loc
,
10898 Defining_Identifier
=> Inner_Any_TypeCode
,
10899 Constant_Present
=> True,
10900 Object_Definition
=> New_Occurrence_Of
(
10901 RTE
(RE_TypeCode
), Loc
),
10902 Expression
=> Inner_Any_TypeCode_Expr
));
10904 if Present
(Inner_Any
) then
10906 Make_Object_Declaration
(Loc
,
10907 Defining_Identifier
=> Inner_Any
,
10908 Object_Definition
=>
10909 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
10911 Make_Function_Call
(Loc
,
10913 New_Occurrence_Of
(
10914 RTE
(RE_Create_Any
), Loc
),
10915 Parameter_Associations
=> New_List
(
10916 New_Occurrence_Of
(Inner_Any_TypeCode
, Loc
)))));
10919 if Present
(Inner_Counter
) then
10921 Make_Object_Declaration
(Loc
,
10922 Defining_Identifier
=> Inner_Counter
,
10923 Object_Definition
=>
10924 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
10926 Make_Integer_Literal
(Loc
, 0)));
10929 if not Constrained
then
10930 Length_Node
:= Make_Attribute_Reference
(Loc
,
10931 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10932 Attribute_Name
=> Name_Length
,
10934 New_List
(Make_Integer_Literal
(Loc
, Depth
)));
10935 Set_Etype
(Length_Node
, RTE
(RE_Long_Unsigned
));
10937 Add_Process_Element
(Dimen_Stmts
,
10938 Datum
=> Length_Node
,
10940 Counter
=> Inner_Counter
);
10943 -- Loop_Stm does appropriate processing for each element
10946 Append_To
(Dimen_Stmts
, Loop_Stm
);
10948 -- Link outer and inner any
10950 if Present
(Inner_Any
) then
10951 Add_Process_Element
(Dimen_Stmts
,
10953 Counter
=> Counter
,
10954 Datum
=> New_Occurrence_Of
(Inner_Any
, Loc
));
10958 Make_Block_Statement
(Loc
,
10961 Handled_Statement_Sequence
=>
10962 Make_Handled_Sequence_Of_Statements
(Loc
,
10963 Statements
=> Dimen_Stmts
)));
10965 end Append_Array_Traversal
;
10967 -----------------------------------------
10968 -- Make_Stream_Procedure_Function_Name --
10969 -----------------------------------------
10971 function Make_Stream_Procedure_Function_Name
10974 Nam
: Name_Id
) return Entity_Id
10977 -- For tagged types, we use a canonical name so that it matches
10978 -- the primitive spec. For all other cases, we use a serialized
10979 -- name so that multiple generations of the same procedure do not
10982 if Is_Tagged_Type
(Typ
) then
10983 return Make_Defining_Identifier
(Loc
, Nam
);
10986 Make_Defining_Identifier
(Loc
,
10988 New_External_Name
(Nam
, ' ', Increment_Serial_Number
));
10990 end Make_Stream_Procedure_Function_Name
;
10993 -----------------------------------
10994 -- Reserve_NamingContext_Methods --
10995 -----------------------------------
10997 procedure Reserve_NamingContext_Methods
is
10998 Str_Resolve
: constant String := "resolve";
11000 Name_Buffer
(1 .. Str_Resolve
'Length) := Str_Resolve
;
11001 Name_Len
:= Str_Resolve
'Length;
11002 Overload_Counter_Table
.Set
(Name_Find
, 1);
11003 end Reserve_NamingContext_Methods
;
11005 end PolyORB_Support
;
11007 -------------------------------
11008 -- RACW_Type_Is_Asynchronous --
11009 -------------------------------
11011 procedure RACW_Type_Is_Asynchronous
(RACW_Type
: Entity_Id
) is
11012 Asynchronous_Flag
: constant Entity_Id
:=
11013 Asynchronous_Flags_Table
.Get
(RACW_Type
);
11015 Replace
(Expression
(Parent
(Asynchronous_Flag
)),
11016 New_Occurrence_Of
(Standard_True
, Sloc
(Asynchronous_Flag
)));
11017 end RACW_Type_Is_Asynchronous
;
11019 -------------------------
11020 -- RCI_Package_Locator --
11021 -------------------------
11023 function RCI_Package_Locator
11025 Package_Spec
: Node_Id
) return Node_Id
11028 Pkg_Name
: String_Id
;
11031 Get_Library_Unit_Name_String
(Package_Spec
);
11032 Pkg_Name
:= String_From_Name_Buffer
;
11034 Make_Package_Instantiation
(Loc
,
11035 Defining_Unit_Name
=>
11036 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
11038 New_Occurrence_Of
(RTE
(RE_RCI_Locator
), Loc
),
11039 Generic_Associations
=> New_List
(
11040 Make_Generic_Association
(Loc
,
11042 Make_Identifier
(Loc
, Name_RCI_Name
),
11043 Explicit_Generic_Actual_Parameter
=>
11044 Make_String_Literal
(Loc
,
11045 Strval
=> Pkg_Name
)),
11046 Make_Generic_Association
(Loc
,
11048 Make_Identifier
(Loc
, Name_Version
),
11049 Explicit_Generic_Actual_Parameter
=>
11050 Make_Attribute_Reference
(Loc
,
11052 New_Occurrence_Of
(Defining_Entity
(Package_Spec
), Loc
),
11056 RCI_Locator_Table
.Set
(Defining_Unit_Name
(Package_Spec
),
11057 Defining_Unit_Name
(Inst
));
11059 end RCI_Package_Locator
;
11061 -----------------------------------------------
11062 -- Remote_Types_Tagged_Full_View_Encountered --
11063 -----------------------------------------------
11065 procedure Remote_Types_Tagged_Full_View_Encountered
11066 (Full_View
: Entity_Id
)
11068 Stub_Elements
: constant Stub_Structure
:=
11069 Stubs_Table
.Get
(Full_View
);
11072 -- For an RACW encountered before the freeze point of its designated
11073 -- type, the stub type is generated at the point of the RACW declaration
11074 -- but the primitives are generated only once the designated type is
11075 -- frozen. That freeze can occur in another scope, for example when the
11076 -- RACW is declared in a nested package. In that case we need to
11077 -- reestablish the stub type's scope prior to generating its primitive
11080 if Stub_Elements
/= Empty_Stub_Structure
then
11082 Saved_Scope
: constant Entity_Id
:= Current_Scope
;
11083 Stubs_Scope
: constant Entity_Id
:=
11084 Scope
(Stub_Elements
.Stub_Type
);
11087 if Current_Scope
/= Stubs_Scope
then
11088 Push_Scope
(Stubs_Scope
);
11091 Add_RACW_Primitive_Declarations_And_Bodies
11093 Stub_Elements
.RPC_Receiver_Decl
,
11094 Stub_Elements
.Body_Decls
);
11096 if Current_Scope
/= Saved_Scope
then
11101 end Remote_Types_Tagged_Full_View_Encountered
;
11103 -------------------
11104 -- Scope_Of_Spec --
11105 -------------------
11107 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
is
11108 Unit_Name
: Node_Id
;
11111 Unit_Name
:= Defining_Unit_Name
(Spec
);
11112 while Nkind
(Unit_Name
) /= N_Defining_Identifier
loop
11113 Unit_Name
:= Defining_Identifier
(Unit_Name
);
11119 ----------------------
11120 -- Set_Renaming_TSS --
11121 ----------------------
11123 procedure Set_Renaming_TSS
11126 TSS_Nam
: TSS_Name_Type
)
11128 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
11129 Spec
: constant Node_Id
:= Parent
(Nam
);
11131 TSS_Node
: constant Node_Id
:=
11132 Make_Subprogram_Renaming_Declaration
(Loc
,
11134 Copy_Specification
(Loc
,
11136 New_Name
=> Make_TSS_Name
(Typ
, TSS_Nam
)),
11137 Name
=> New_Occurrence_Of
(Nam
, Loc
));
11139 Snam
: constant Entity_Id
:=
11140 Defining_Unit_Name
(Specification
(TSS_Node
));
11143 if Nkind
(Spec
) = N_Function_Specification
then
11144 Set_Ekind
(Snam
, E_Function
);
11145 Set_Etype
(Snam
, Entity
(Result_Definition
(Spec
)));
11147 Set_Ekind
(Snam
, E_Procedure
);
11148 Set_Etype
(Snam
, Standard_Void_Type
);
11151 Set_TSS
(Typ
, Snam
);
11152 end Set_Renaming_TSS
;
11154 ----------------------------------------------
11155 -- Specific_Add_Obj_RPC_Receiver_Completion --
11156 ----------------------------------------------
11158 procedure Specific_Add_Obj_RPC_Receiver_Completion
11161 RPC_Receiver
: Entity_Id
;
11162 Stub_Elements
: Stub_Structure
)
11165 case Get_PCS_Name
is
11166 when Name_PolyORB_DSA
=>
11167 PolyORB_Support
.Add_Obj_RPC_Receiver_Completion
(Loc
,
11168 Decls
, RPC_Receiver
, Stub_Elements
);
11170 GARLIC_Support
.Add_Obj_RPC_Receiver_Completion
(Loc
,
11171 Decls
, RPC_Receiver
, Stub_Elements
);
11173 end Specific_Add_Obj_RPC_Receiver_Completion
;
11175 --------------------------------
11176 -- Specific_Add_RACW_Features --
11177 --------------------------------
11179 procedure Specific_Add_RACW_Features
11180 (RACW_Type
: Entity_Id
;
11182 Stub_Type
: Entity_Id
;
11183 Stub_Type_Access
: Entity_Id
;
11184 RPC_Receiver_Decl
: Node_Id
;
11185 Body_Decls
: List_Id
)
11188 case Get_PCS_Name
is
11189 when Name_PolyORB_DSA
=>
11190 PolyORB_Support
.Add_RACW_Features
11199 GARLIC_Support
.Add_RACW_Features
11206 end Specific_Add_RACW_Features
;
11208 --------------------------------
11209 -- Specific_Add_RAST_Features --
11210 --------------------------------
11212 procedure Specific_Add_RAST_Features
11213 (Vis_Decl
: Node_Id
;
11214 RAS_Type
: Entity_Id
)
11217 case Get_PCS_Name
is
11218 when Name_PolyORB_DSA
=>
11219 PolyORB_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
11221 GARLIC_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
11223 end Specific_Add_RAST_Features
;
11225 --------------------------------------------------
11226 -- Specific_Add_Receiving_Stubs_To_Declarations --
11227 --------------------------------------------------
11229 procedure Specific_Add_Receiving_Stubs_To_Declarations
11230 (Pkg_Spec
: Node_Id
;
11235 case Get_PCS_Name
is
11236 when Name_PolyORB_DSA
=>
11237 PolyORB_Support
.Add_Receiving_Stubs_To_Declarations
11238 (Pkg_Spec
, Decls
, Stmts
);
11240 GARLIC_Support
.Add_Receiving_Stubs_To_Declarations
11241 (Pkg_Spec
, Decls
, Stmts
);
11243 end Specific_Add_Receiving_Stubs_To_Declarations
;
11245 ------------------------------------------
11246 -- Specific_Build_General_Calling_Stubs --
11247 ------------------------------------------
11249 procedure Specific_Build_General_Calling_Stubs
11251 Statements
: List_Id
;
11252 Target
: RPC_Target
;
11253 Subprogram_Id
: Node_Id
;
11254 Asynchronous
: Node_Id
:= Empty
;
11255 Is_Known_Asynchronous
: Boolean := False;
11256 Is_Known_Non_Asynchronous
: Boolean := False;
11257 Is_Function
: Boolean;
11259 Stub_Type
: Entity_Id
:= Empty
;
11260 RACW_Type
: Entity_Id
:= Empty
;
11264 case Get_PCS_Name
is
11265 when Name_PolyORB_DSA
=>
11266 PolyORB_Support
.Build_General_Calling_Stubs
11272 Is_Known_Asynchronous
,
11273 Is_Known_Non_Asynchronous
,
11281 GARLIC_Support
.Build_General_Calling_Stubs
11285 Target
.RPC_Receiver
,
11288 Is_Known_Asynchronous
,
11289 Is_Known_Non_Asynchronous
,
11296 end Specific_Build_General_Calling_Stubs
;
11298 --------------------------------------
11299 -- Specific_Build_RPC_Receiver_Body --
11300 --------------------------------------
11302 procedure Specific_Build_RPC_Receiver_Body
11303 (RPC_Receiver
: Entity_Id
;
11304 Request
: out Entity_Id
;
11305 Subp_Id
: out Entity_Id
;
11306 Subp_Index
: out Entity_Id
;
11307 Stmts
: out List_Id
;
11308 Decl
: out Node_Id
)
11311 case Get_PCS_Name
is
11312 when Name_PolyORB_DSA
=>
11313 PolyORB_Support
.Build_RPC_Receiver_Body
11322 GARLIC_Support
.Build_RPC_Receiver_Body
11330 end Specific_Build_RPC_Receiver_Body
;
11332 --------------------------------
11333 -- Specific_Build_Stub_Target --
11334 --------------------------------
11336 function Specific_Build_Stub_Target
11339 RCI_Locator
: Entity_Id
;
11340 Controlling_Parameter
: Entity_Id
) return RPC_Target
11343 case Get_PCS_Name
is
11344 when Name_PolyORB_DSA
=>
11345 return PolyORB_Support
.Build_Stub_Target
(Loc
,
11346 Decls
, RCI_Locator
, Controlling_Parameter
);
11349 return GARLIC_Support
.Build_Stub_Target
(Loc
,
11350 Decls
, RCI_Locator
, Controlling_Parameter
);
11352 end Specific_Build_Stub_Target
;
11354 ------------------------------
11355 -- Specific_Build_Stub_Type --
11356 ------------------------------
11358 procedure Specific_Build_Stub_Type
11359 (RACW_Type
: Entity_Id
;
11360 Stub_Type
: Entity_Id
;
11361 Stub_Type_Decl
: out Node_Id
;
11362 RPC_Receiver_Decl
: out Node_Id
)
11365 case Get_PCS_Name
is
11366 when Name_PolyORB_DSA
=>
11367 PolyORB_Support
.Build_Stub_Type
(
11368 RACW_Type
, Stub_Type
,
11369 Stub_Type_Decl
, RPC_Receiver_Decl
);
11372 GARLIC_Support
.Build_Stub_Type
(
11373 RACW_Type
, Stub_Type
,
11374 Stub_Type_Decl
, RPC_Receiver_Decl
);
11376 end Specific_Build_Stub_Type
;
11378 function Specific_Build_Subprogram_Receiving_Stubs
11379 (Vis_Decl
: Node_Id
;
11380 Asynchronous
: Boolean;
11381 Dynamically_Asynchronous
: Boolean := False;
11382 Stub_Type
: Entity_Id
:= Empty
;
11383 RACW_Type
: Entity_Id
:= Empty
;
11384 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
11387 case Get_PCS_Name
is
11388 when Name_PolyORB_DSA
=>
11389 return PolyORB_Support
.Build_Subprogram_Receiving_Stubs
11392 Dynamically_Asynchronous
,
11398 return GARLIC_Support
.Build_Subprogram_Receiving_Stubs
11401 Dynamically_Asynchronous
,
11406 end Specific_Build_Subprogram_Receiving_Stubs
;
11408 -------------------------------
11409 -- Transmit_As_Unconstrained --
11410 -------------------------------
11412 function Transmit_As_Unconstrained
(Typ
: Entity_Id
) return Boolean is
11415 not (Is_Elementary_Type
(Typ
) or else Is_Constrained
(Typ
))
11416 or else (Is_Access_Type
(Typ
) and then Can_Never_Be_Null
(Typ
));
11417 end Transmit_As_Unconstrained
;
11419 --------------------------
11420 -- Underlying_RACW_Type --
11421 --------------------------
11423 function Underlying_RACW_Type
(RAS_Typ
: Entity_Id
) return Entity_Id
is
11424 Record_Type
: Entity_Id
;
11427 if Ekind
(RAS_Typ
) = E_Record_Type
then
11428 Record_Type
:= RAS_Typ
;
11430 pragma Assert
(Present
(Equivalent_Type
(RAS_Typ
)));
11431 Record_Type
:= Equivalent_Type
(RAS_Typ
);
11435 Etype
(Subtype_Indication
11436 (Component_Definition
11437 (First
(Component_Items
11440 (Declaration_Node
(Record_Type
))))))));
11441 end Underlying_RACW_Type
;