1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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 Snames
; use Snames
;
47 with Stand
; use Stand
;
48 with Stringt
; use Stringt
;
49 with Tbuild
; use Tbuild
;
50 with Ttypes
; use Ttypes
;
51 with Uintp
; use Uintp
;
53 with GNAT
.HTable
; use GNAT
.HTable
;
55 package body Exp_Dist
is
57 -- The following model has been used to implement distributed objects:
58 -- given a designated type D and a RACW type R, then a record of the
61 -- type Stub is tagged record
62 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
65 -- is built. This type has two properties:
67 -- 1) Since it has the same structure than RACW_Stub_Type, it can be
68 -- converted to and from this type to make it suitable for
69 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
70 -- to avoid memory leaks when the same remote object arrive on the
71 -- same partition through several paths;
73 -- 2) It also has the same dispatching table as the designated type D,
74 -- and thus can be used as an object designated by a value of type
75 -- R on any partition other than the one on which the object has
76 -- been created, since only dispatching calls will be performed and
77 -- the fields themselves will not be used. We call Derive_Subprograms
78 -- to fake half a derivation to ensure that the subprograms do have
79 -- the same dispatching table.
81 First_RCI_Subprogram_Id
: constant := 2;
82 -- RCI subprograms are numbered starting at 2. The RCI receiver for
83 -- an RCI package can thus identify calls received through remote
84 -- access-to-subprogram dereferences by the fact that they have a
85 -- (primitive) subprogram id of 0, and 1 is used for the internal
86 -- RAS information lookup operation. (This is for the Garlic code
87 -- generation, where subprograms are identified by numbers; in the
88 -- PolyORB version, they are identified by name, with a numeric suffix
91 type Hash_Index
is range 0 .. 50;
93 -----------------------
94 -- Local subprograms --
95 -----------------------
97 function Hash
(F
: Entity_Id
) return Hash_Index
;
98 -- DSA expansion associates stubs to distributed object types using
99 -- a hash table on entity ids.
101 function Hash
(F
: Name_Id
) return Hash_Index
;
102 -- The generation of subprogram identifiers requires an overload counter
103 -- to be associated with each remote subprogram names. These counters
104 -- are maintained in a hash table on name ids.
106 type Subprogram_Identifiers
is record
107 Str_Identifier
: String_Id
;
108 Int_Identifier
: Int
;
111 package Subprogram_Identifier_Table
is
112 new Simple_HTable
(Header_Num
=> Hash_Index
,
113 Element
=> Subprogram_Identifiers
,
114 No_Element
=> (No_String
, 0),
118 -- Mapping between a remote subprogram and the corresponding
119 -- subprogram identifiers.
121 package Overload_Counter_Table
is
122 new Simple_HTable
(Header_Num
=> Hash_Index
,
128 -- Mapping between a subprogram name and an integer that
129 -- counts the number of defining subprogram names with that
130 -- Name_Id encountered so far in a given context (an interface).
132 function Get_Subprogram_Ids
(Def
: Entity_Id
) return Subprogram_Identifiers
;
133 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
;
134 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
;
135 -- Given a subprogram defined in a RCI package, get its distribution
136 -- subprogram identifiers (the distribution identifiers are a unique
137 -- subprogram number, and the non-qualified subprogram name, in the
138 -- casing used for the subprogram declaration; if the name is overloaded,
139 -- a double underscore and a serial number are appended.
141 -- The integer identifier is used to perform remote calls with GARLIC;
142 -- the string identifier is used in the case of PolyORB.
144 -- Although the PolyORB DSA receiving stubs will make a caseless comparison
145 -- when receiving a call, the calling stubs will create requests with the
146 -- exact casing of the defining unit name of the called subprogram, so as
147 -- to allow calls to subprograms on distributed nodes that do distinguish
150 -- NOTE: Another design would be to allow a representation clause on
151 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
153 pragma Warnings
(Off
, Get_Subprogram_Id
);
154 -- One homonym only is unreferenced (specific to the GARLIC version)
156 procedure Add_RAS_Dereference_TSS
(N
: Node_Id
);
157 -- Add a subprogram body for RAS Dereference TSS
159 procedure Add_RAS_Proxy_And_Analyze
162 All_Calls_Remote_E
: Entity_Id
;
163 Proxy_Object_Addr
: out Entity_Id
);
164 -- Add the proxy type required, on the receiving (server) side, to handle
165 -- calls to the subprogram declared by Vis_Decl through a remote access
166 -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma
167 -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type
168 -- is appended to Decls. Proxy_Object_Addr is a constant of type
169 -- System.Address that designates an instance of the proxy object.
171 function Build_Remote_Subprogram_Proxy_Type
173 ACR_Expression
: Node_Id
) return Node_Id
;
174 -- Build and return a tagged record type definition for an RCI
175 -- subprogram proxy type.
176 -- ACR_Expression is use as the initialization value for
177 -- the All_Calls_Remote component.
179 function Build_Get_Unique_RP_Call
182 Stub_Type
: Entity_Id
) return List_Id
;
183 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
184 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
185 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
187 function Build_Subprogram_Calling_Stubs
190 Asynchronous
: Boolean;
191 Dynamically_Asynchronous
: Boolean := False;
192 Stub_Type
: Entity_Id
:= Empty
;
193 RACW_Type
: Entity_Id
:= Empty
;
194 Locator
: Entity_Id
:= Empty
;
195 New_Name
: Name_Id
:= No_Name
) return Node_Id
;
196 -- Build the calling stub for a given subprogram with the subprogram ID
197 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
198 -- parameters of this type will be marshalled instead of the object
199 -- itself. It will then be converted into Stub_Type before performing
200 -- the real call. If Dynamically_Asynchronous is True, then it will be
201 -- computed at run time whether the call is asynchronous or not.
202 -- Otherwise, the value of the formal Asynchronous will be used.
203 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
204 -- New_Name is given, then it will be used instead of the original name.
206 function Build_RPC_Receiver_Specification
207 (RPC_Receiver
: Entity_Id
;
208 Request_Parameter
: Entity_Id
) return Node_Id
;
209 -- Make a subprogram specification for an RPC receiver, with the given
210 -- defining unit name and formal parameter.
212 function Build_Ordered_Parameters_List
(Spec
: Node_Id
) return List_Id
;
213 -- Return an ordered parameter list: unconstrained parameters are put
214 -- at the beginning of the list and constrained ones are put after. If
215 -- there are no parameters, an empty list is returned. Special case:
216 -- the controlling formal of the equivalent RACW operation for a RAS
217 -- type is always left in first position.
219 procedure Add_Calling_Stubs_To_Declarations
222 -- Add calling stubs to the declarative part
224 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean;
225 -- Return True if nothing prevents the program whose specification is
226 -- given to be asynchronous (i.e. no out parameter).
228 function Pack_Entity_Into_Stream_Access
232 Etyp
: Entity_Id
:= Empty
) return Node_Id
;
233 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
234 -- then Etype (Object) will be used if present. If the type is
235 -- constrained, then 'Write will be used to output the object,
236 -- If the type is unconstrained, 'Output will be used.
238 function Pack_Node_Into_Stream
242 Etyp
: Entity_Id
) return Node_Id
;
243 -- Similar to above, with an arbitrary node instead of an entity
245 function Pack_Node_Into_Stream_Access
249 Etyp
: Entity_Id
) return Node_Id
;
250 -- Similar to above, with Stream instead of Stream'Access
252 function Make_Selected_Component
255 Selector_Name
: Name_Id
) return Node_Id
;
256 -- Return a selected_component whose prefix denotes the given entity,
257 -- and with the given Selector_Name.
259 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
;
260 -- Return the scope represented by a given spec
262 procedure Set_Renaming_TSS
265 TSS_Nam
: TSS_Name_Type
);
266 -- Create a renaming declaration of subprogram Nam,
267 -- and register it as a TSS for Typ with name TSS_Nam.
269 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean;
270 -- Return True if the current parameter needs an extra formal to reflect
271 -- its constrained status.
273 function Is_RACW_Controlling_Formal
274 (Parameter
: Node_Id
;
275 Stub_Type
: Entity_Id
) return Boolean;
276 -- Return True if the current parameter is a controlling formal argument
277 -- of type Stub_Type or access to Stub_Type.
279 procedure Declare_Create_NVList
284 -- Append the declaration of NVList to Decls, and its
285 -- initialization to Stmts.
287 function Add_Parameter_To_NVList
290 Parameter
: Entity_Id
;
291 Constrained
: Boolean;
292 RACW_Ctrl
: Boolean := False;
293 Any
: Entity_Id
) return Node_Id
;
294 -- Return a call to Add_Item to add the Any corresponding to the designated
295 -- formal Parameter (with the indicated Constrained status) to NVList.
296 -- RACW_Ctrl must be set to True for controlling formals of distributed
297 -- object primitive operations.
303 -- This record describes various tree fragments associated with the
304 -- generation of RACW calling stubs. One such record exists for every
305 -- distributed object type, i.e. each tagged type that is the designated
306 -- type of one or more RACW type.
308 type Stub_Structure
is record
309 Stub_Type
: Entity_Id
;
310 -- Stub type: this type has the same primitive operations as the
311 -- designated types, but the provided bodies for these operations
312 -- a remote call to an actual target object potentially located on
313 -- another partition; each value of the stub type encapsulates a
314 -- reference to a remote object.
316 Stub_Type_Access
: Entity_Id
;
317 -- A local access type designating the stub type (this is not an RACW
320 RPC_Receiver_Decl
: Node_Id
;
321 -- Declaration for the RPC receiver entity associated with the
322 -- designated type. As an exception, for the case of an RACW that
323 -- implements a RAS, no object RPC receiver is generated. Instead,
324 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
325 -- would have been inserted.
327 Body_Decls
: List_Id
;
328 -- List of subprogram bodies to be included in generated code: bodies
329 -- for the RACW's stream attributes, and for the primitive operations
332 RACW_Type
: Entity_Id
;
333 -- One of the RACW types designating this distributed object type
334 -- (they are all interchangeable; we use any one of them in order to
335 -- avoid having to create various anonymous access types).
339 Empty_Stub_Structure
: constant Stub_Structure
:=
340 (Empty
, Empty
, Empty
, No_List
, Empty
);
342 package Stubs_Table
is
343 new Simple_HTable
(Header_Num
=> Hash_Index
,
344 Element
=> Stub_Structure
,
345 No_Element
=> Empty_Stub_Structure
,
349 -- Mapping between a RACW designated type and its stub type
351 package Asynchronous_Flags_Table
is
352 new Simple_HTable
(Header_Num
=> Hash_Index
,
353 Element
=> Entity_Id
,
358 -- Mapping between a RACW type and a constant having the value True
359 -- if the RACW is asynchronous and False otherwise.
361 package RCI_Locator_Table
is
362 new Simple_HTable
(Header_Num
=> Hash_Index
,
363 Element
=> Entity_Id
,
368 -- Mapping between a RCI package on which All_Calls_Remote applies and
369 -- the generic instantiation of RCI_Locator for this package.
371 package RCI_Calling_Stubs_Table
is
372 new Simple_HTable
(Header_Num
=> Hash_Index
,
373 Element
=> Entity_Id
,
378 -- Mapping between a RCI subprogram and the corresponding calling stubs
380 procedure Add_Stub_Type
381 (Designated_Type
: Entity_Id
;
382 RACW_Type
: Entity_Id
;
384 Stub_Type
: out Entity_Id
;
385 Stub_Type_Access
: out Entity_Id
;
386 RPC_Receiver_Decl
: out Node_Id
;
387 Body_Decls
: out List_Id
;
388 Existing
: out Boolean);
389 -- Add the declaration of the stub type, the access to stub type and the
390 -- object RPC receiver at the end of Decls. If these already exist,
391 -- then nothing is added in the tree but the right values are returned
392 -- anyhow and Existing is set to True.
394 function Get_And_Reset_RACW_Bodies
(RACW_Type
: Entity_Id
) return List_Id
;
395 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
396 -- structure table, reset it to No_List, and return the previous value.
398 procedure Add_RACW_Asynchronous_Flag
399 (Declarations
: List_Id
;
400 RACW_Type
: Entity_Id
);
401 -- Declare a boolean constant associated with RACW_Type whose value
402 -- indicates at run time whether a pragma Asynchronous applies to it.
404 procedure Assign_Subprogram_Identifier
408 -- Determine the distribution subprogram identifier to
409 -- be used for remote subprogram Def, return it in Id and
410 -- store it in a hash table for later retrieval by
411 -- Get_Subprogram_Id. Spn is the subprogram number.
413 function RCI_Package_Locator
415 Package_Spec
: Node_Id
) return Node_Id
;
416 -- Instantiate the generic package RCI_Locator in order to locate the
417 -- RCI package whose spec is given as argument.
419 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
;
420 -- Surround a node N by a tag check, as in:
424 -- when E : Ada.Tags.Tag_Error =>
425 -- Raise_Exception (Program_Error'Identity,
426 -- Exception_Message (E));
429 function Input_With_Tag_Check
431 Var_Type
: Entity_Id
;
432 Stream
: Node_Id
) return Node_Id
;
433 -- Return a function with the following form:
434 -- function R return Var_Type is
436 -- return Var_Type'Input (S);
438 -- when E : Ada.Tags.Tag_Error =>
439 -- Raise_Exception (Program_Error'Identity,
440 -- Exception_Message (E));
443 procedure Build_Actual_Object_Declaration
449 -- Build the declaration of an object with the given defining identifier,
450 -- initialized with Expr if provided, to serve as actual parameter in a
451 -- server stub. If Variable is true, the declared object will be a variable
452 -- (case of an out or in out formal), else it will be a constant. Object's
453 -- Ekind is set accordingly. The declaration, as well as any other
454 -- declarations it requires, are appended to Decls.
456 --------------------------------------------
457 -- Hooks for PCS-specific code generation --
458 --------------------------------------------
460 -- Part of the code generation circuitry for distribution needs to be
461 -- tailored for each implementation of the PCS. For each routine that
462 -- needs to be specialized, a Specific_<routine> wrapper is created,
463 -- which calls the corresponding <routine> in package
464 -- <pcs_implementation>_Support.
466 procedure Specific_Add_RACW_Features
467 (RACW_Type
: Entity_Id
;
469 Stub_Type
: Entity_Id
;
470 Stub_Type_Access
: Entity_Id
;
471 RPC_Receiver_Decl
: Node_Id
;
472 Body_Decls
: List_Id
);
473 -- Add declaration for TSSs for a given RACW type. The declarations are
474 -- added just after the declaration of the RACW type itself, while the
475 -- bodies are inserted at the end of Body_Decls. Runtime-specific ancillary
476 -- subprogram for Add_RACW_Features.
478 procedure Specific_Add_RAST_Features
480 RAS_Type
: Entity_Id
);
481 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
482 -- subprogram for Add_RAST_Features.
484 -- An RPC_Target record is used during construction of calling stubs
485 -- to pass PCS-specific tree fragments corresponding to the information
486 -- necessary to locate the target of a remote subprogram call.
488 type RPC_Target
(PCS_Kind
: PCS_Names
) is record
490 when Name_PolyORB_DSA
=>
492 -- An expression whose value is a PolyORB reference to the target
496 Partition
: Entity_Id
;
497 -- A variable containing the Partition_ID of the target parition
499 RPC_Receiver
: Node_Id
;
500 -- An expression whose value is the address of the target RPC
505 procedure Specific_Build_General_Calling_Stubs
507 Statements
: List_Id
;
509 Subprogram_Id
: Node_Id
;
510 Asynchronous
: Node_Id
:= Empty
;
511 Is_Known_Asynchronous
: Boolean := False;
512 Is_Known_Non_Asynchronous
: Boolean := False;
513 Is_Function
: Boolean;
515 Stub_Type
: Entity_Id
:= Empty
;
516 RACW_Type
: Entity_Id
:= Empty
;
518 -- Build calling stubs for general purpose. The parameters are:
519 -- Decls : a place to put declarations
520 -- Statements : a place to put statements
521 -- Target : PCS-specific target information (see details
522 -- in RPC_Target declaration).
523 -- Subprogram_Id : a node containing the subprogram ID
524 -- Asynchronous : True if an APC must be made instead of an RPC.
525 -- The value needs not be supplied if one of the
526 -- Is_Known_... is True.
527 -- Is_Known_Async... : True if we know that this is asynchronous
528 -- Is_Known_Non_A... : True if we know that this is not asynchronous
529 -- Spec : a node with a Parameter_Specifications and
530 -- a Result_Definition if applicable
531 -- Stub_Type : in case of RACW stubs, parameters of type access
532 -- to Stub_Type will be marshalled using the
533 -- address of the object (the addr field) rather
534 -- than using the 'Write on the stub itself
535 -- Nod : used to provide sloc for generated code
537 function Specific_Build_Stub_Target
540 RCI_Locator
: Entity_Id
;
541 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
542 -- Build call target information nodes for use within calling stubs. In the
543 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
544 -- for an RACW, Controlling_Parameter is the entity for the controlling
545 -- formal parameter used to determine the location of the target of the
546 -- call. Decls provides a location where variable declarations can be
547 -- appended to construct the necessary values.
549 procedure Specific_Build_Stub_Type
550 (RACW_Type
: Entity_Id
;
551 Stub_Type
: Entity_Id
;
552 Stub_Type_Decl
: out Node_Id
;
553 RPC_Receiver_Decl
: out Node_Id
);
554 -- Build a type declaration for the stub type associated with an RACW
555 -- type, and the necessary RPC receiver, if applicable. PCS-specific
556 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
557 -- is generated, then RPC_Receiver_Decl is set to Empty.
559 procedure Specific_Build_RPC_Receiver_Body
560 (RPC_Receiver
: Entity_Id
;
561 Request
: out Entity_Id
;
562 Subp_Id
: out Entity_Id
;
563 Subp_Index
: out Entity_Id
;
566 -- Make a subprogram body for an RPC receiver, with the given
567 -- defining unit name. On return:
568 -- - Subp_Id is the subprogram identifier from the PCS.
569 -- - Subp_Index is the index in the list of subprograms
570 -- used for dispatching (a variable of type Subprogram_Id).
571 -- - Stmts is the place where the request dispatching
572 -- statements can occur,
573 -- - Decl is the subprogram body declaration.
575 function Specific_Build_Subprogram_Receiving_Stubs
577 Asynchronous
: Boolean;
578 Dynamically_Asynchronous
: Boolean := False;
579 Stub_Type
: Entity_Id
:= Empty
;
580 RACW_Type
: Entity_Id
:= Empty
;
581 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
582 -- Build the receiving stub for a given subprogram. The subprogram
583 -- declaration is also built by this procedure, and the value returned
584 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
585 -- found in the specification, then its address is read from the stream
586 -- instead of the object itself and converted into an access to
587 -- class-wide type before doing the real call using any of the RACW type
588 -- pointing on the designated type.
590 procedure Specific_Add_Obj_RPC_Receiver_Completion
593 RPC_Receiver
: Entity_Id
;
594 Stub_Elements
: Stub_Structure
);
595 -- Add the necessary code to Decls after the completion of generation
596 -- of the RACW RPC receiver described by Stub_Elements.
598 procedure Specific_Add_Receiving_Stubs_To_Declarations
602 -- Add receiving stubs to the declarative part of an RCI unit
604 package GARLIC_Support
is
606 -- Support for generating DSA code that uses the GARLIC PCS
608 -- The subprograms below provide the GARLIC versions of the
609 -- corresponding Specific_<subprogram> routine declared above.
611 procedure Add_RACW_Features
612 (RACW_Type
: Entity_Id
;
613 Stub_Type
: Entity_Id
;
614 Stub_Type_Access
: Entity_Id
;
615 RPC_Receiver_Decl
: Node_Id
;
616 Body_Decls
: List_Id
);
618 procedure Add_RAST_Features
620 RAS_Type
: Entity_Id
);
622 procedure Build_General_Calling_Stubs
624 Statements
: List_Id
;
625 Target_Partition
: Entity_Id
; -- From RPC_Target
626 Target_RPC_Receiver
: Node_Id
; -- From RPC_Target
627 Subprogram_Id
: Node_Id
;
628 Asynchronous
: Node_Id
:= Empty
;
629 Is_Known_Asynchronous
: Boolean := False;
630 Is_Known_Non_Asynchronous
: Boolean := False;
631 Is_Function
: Boolean;
633 Stub_Type
: Entity_Id
:= Empty
;
634 RACW_Type
: Entity_Id
:= Empty
;
637 function Build_Stub_Target
640 RCI_Locator
: Entity_Id
;
641 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
643 procedure Build_Stub_Type
644 (RACW_Type
: Entity_Id
;
645 Stub_Type
: Entity_Id
;
646 Stub_Type_Decl
: out Node_Id
;
647 RPC_Receiver_Decl
: out Node_Id
);
649 function Build_Subprogram_Receiving_Stubs
651 Asynchronous
: Boolean;
652 Dynamically_Asynchronous
: Boolean := False;
653 Stub_Type
: Entity_Id
:= Empty
;
654 RACW_Type
: Entity_Id
:= Empty
;
655 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
657 procedure Add_Obj_RPC_Receiver_Completion
660 RPC_Receiver
: Entity_Id
;
661 Stub_Elements
: Stub_Structure
);
663 procedure Add_Receiving_Stubs_To_Declarations
668 procedure Build_RPC_Receiver_Body
669 (RPC_Receiver
: Entity_Id
;
670 Request
: out Entity_Id
;
671 Subp_Id
: out Entity_Id
;
672 Subp_Index
: out Entity_Id
;
678 package PolyORB_Support
is
680 -- Support for generating DSA code that uses the PolyORB PCS
682 -- The subprograms below provide the PolyORB versions of the
683 -- corresponding Specific_<subprogram> routine declared above.
685 procedure Add_RACW_Features
686 (RACW_Type
: Entity_Id
;
688 Stub_Type
: Entity_Id
;
689 Stub_Type_Access
: Entity_Id
;
690 RPC_Receiver_Decl
: Node_Id
;
691 Body_Decls
: List_Id
);
693 procedure Add_RAST_Features
695 RAS_Type
: Entity_Id
);
697 procedure Build_General_Calling_Stubs
699 Statements
: List_Id
;
700 Target_Object
: Node_Id
; -- From RPC_Target
701 Subprogram_Id
: Node_Id
;
702 Asynchronous
: Node_Id
:= Empty
;
703 Is_Known_Asynchronous
: Boolean := False;
704 Is_Known_Non_Asynchronous
: Boolean := False;
705 Is_Function
: Boolean;
707 Stub_Type
: Entity_Id
:= Empty
;
708 RACW_Type
: Entity_Id
:= Empty
;
711 function Build_Stub_Target
714 RCI_Locator
: Entity_Id
;
715 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
717 procedure Build_Stub_Type
718 (RACW_Type
: Entity_Id
;
719 Stub_Type
: Entity_Id
;
720 Stub_Type_Decl
: out Node_Id
;
721 RPC_Receiver_Decl
: out Node_Id
);
723 function Build_Subprogram_Receiving_Stubs
725 Asynchronous
: Boolean;
726 Dynamically_Asynchronous
: Boolean := False;
727 Stub_Type
: Entity_Id
:= Empty
;
728 RACW_Type
: Entity_Id
:= Empty
;
729 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
731 procedure Add_Obj_RPC_Receiver_Completion
734 RPC_Receiver
: Entity_Id
;
735 Stub_Elements
: Stub_Structure
);
737 procedure Add_Receiving_Stubs_To_Declarations
742 procedure Build_RPC_Receiver_Body
743 (RPC_Receiver
: Entity_Id
;
744 Request
: out Entity_Id
;
745 Subp_Id
: out Entity_Id
;
746 Subp_Index
: out Entity_Id
;
750 procedure Reserve_NamingContext_Methods
;
751 -- Mark the method names for interface NamingContext as already used in
752 -- the overload table, so no clashes occur with user code (with the
753 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
754 -- their methods to be accessed as objects, for the implementation of
755 -- remote access-to-subprogram types).
759 -- Routines to build distribtion helper subprograms for user-defined
760 -- types. For implementation of the Distributed systems annex (DSA)
761 -- over the PolyORB generic middleware components, it is necessary to
762 -- generate several supporting subprograms for each application data
763 -- type used in inter-partition communication. These subprograms are:
765 -- A Typecode function returning a high-level description of the
768 -- Two conversion functions allowing conversion of values of the
769 -- type from and to the generic data containers used by PolyORB.
770 -- These generic containers are called 'Any' type values after the
771 -- CORBA terminology, and hence the conversion subprograms are
772 -- named To_Any and From_Any.
774 function Build_From_Any_Call
777 Decls
: List_Id
) return Node_Id
;
778 -- Build call to From_Any attribute function of type Typ with
779 -- expression N as actual parameter. Decls is the declarations list
780 -- for an appropriate enclosing scope of the point where the call
781 -- will be inserted; if the From_Any attribute for Typ needs to be
782 -- generated at this point, its declaration is appended to Decls.
784 procedure Build_From_Any_Function
788 Fnam
: out Entity_Id
);
789 -- Build From_Any attribute function for Typ. Loc is the reference
790 -- location for generated nodes, Typ is the type for which the
791 -- conversion function is generated. On return, Decl and Fnam contain
792 -- the declaration and entity for the newly-created function.
794 function Build_To_Any_Call
796 Decls
: List_Id
) return Node_Id
;
797 -- Build call to To_Any attribute function with expression as actual
798 -- parameter. Decls is the declarations list for an appropriate
799 -- enclosing scope of the point where the call will be inserted; if
800 -- the To_Any attribute for Typ needs to be generated at this point,
801 -- its declaration is appended to Decls.
803 procedure Build_To_Any_Function
807 Fnam
: out Entity_Id
);
808 -- Build To_Any attribute function for Typ. Loc is the reference
809 -- location for generated nodes, Typ is the type for which the
810 -- conversion function is generated. On return, Decl and Fnam contain
811 -- the declaration and entity for the newly-created function.
813 function Build_TypeCode_Call
816 Decls
: List_Id
) return Node_Id
;
817 -- Build call to TypeCode attribute function for Typ. Decls is the
818 -- declarations list for an appropriate enclosing scope of the point
819 -- where the call will be inserted; if the To_Any attribute for Typ
820 -- needs to be generated at this point, its declaration is appended
823 procedure Build_TypeCode_Function
827 Fnam
: out Entity_Id
);
828 -- Build TypeCode attribute function for Typ. Loc is the reference
829 -- location for generated nodes, Typ is the type for which the
830 -- conversion function is generated. On return, Decl and Fnam contain
831 -- the declaration and entity for the newly-created function.
833 procedure Build_Name_And_Repository_Id
835 Name_Str
: out String_Id
;
836 Repo_Id_Str
: out String_Id
);
837 -- In the PolyORB distribution model, each distributed object type
838 -- and each distributed operation has a globally unique identifier,
839 -- its Repository Id. This subprogram builds and returns two strings
840 -- for entity E (a distributed object type or operation): one
841 -- containing the name of E, the second containing its repository id.
847 ------------------------------------
848 -- Local variables and structures --
849 ------------------------------------
852 -- Needs comments ???
854 Output_From_Constrained
: constant array (Boolean) of Name_Id
:=
855 (False => Name_Output
,
857 -- The attribute to choose depending on the fact that the parameter
858 -- is constrained or not. There is no such thing as Input_From_Constrained
859 -- since this require separate mechanisms ('Input is a function while
860 -- 'Read is a procedure).
862 ---------------------------------------
863 -- Add_Calling_Stubs_To_Declarations --
864 ---------------------------------------
866 procedure Add_Calling_Stubs_To_Declarations
870 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
871 -- Subprogram id 0 is reserved for calls received from
872 -- remote access-to-subprogram dereferences.
874 Current_Declaration
: Node_Id
;
875 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
876 RCI_Instantiation
: Node_Id
;
877 Subp_Stubs
: Node_Id
;
878 Subp_Str
: String_Id
;
881 -- The first thing added is an instantiation of the generic package
882 -- System.Partition_Interface.RCI_Locator with the name of this remote
883 -- package. This will act as an interface with the name server to
884 -- determine the Partition_ID and the RPC_Receiver for the receiver
887 RCI_Instantiation
:= RCI_Package_Locator
(Loc
, Pkg_Spec
);
888 RCI_Cache
:= Defining_Unit_Name
(RCI_Instantiation
);
890 Append_To
(Decls
, RCI_Instantiation
);
891 Analyze
(RCI_Instantiation
);
893 -- For each subprogram declaration visible in the spec, we do build a
894 -- body. We also increment a counter to assign a different Subprogram_Id
895 -- to each subprograms. The receiving stubs processing do use the same
896 -- mechanism and will thus assign the same Id and do the correct
899 Overload_Counter_Table
.Reset
;
900 PolyORB_Support
.Reserve_NamingContext_Methods
;
902 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
904 while Present
(Current_Declaration
) loop
905 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
906 and then Comes_From_Source
(Current_Declaration
)
908 Assign_Subprogram_Identifier
(
909 Defining_Unit_Name
(Specification
(Current_Declaration
)),
910 Current_Subprogram_Number
,
914 Build_Subprogram_Calling_Stubs
(
915 Vis_Decl
=> Current_Declaration
,
917 Build_Subprogram_Id
(Loc
,
918 Defining_Unit_Name
(Specification
(Current_Declaration
))),
920 Nkind
(Specification
(Current_Declaration
)) =
921 N_Procedure_Specification
923 Is_Asynchronous
(Defining_Unit_Name
(Specification
924 (Current_Declaration
))));
926 Append_To
(Decls
, Subp_Stubs
);
927 Analyze
(Subp_Stubs
);
929 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
932 Next
(Current_Declaration
);
934 end Add_Calling_Stubs_To_Declarations
;
936 -----------------------------
937 -- Add_Parameter_To_NVList --
938 -----------------------------
940 function Add_Parameter_To_NVList
943 Parameter
: Entity_Id
;
944 Constrained
: Boolean;
945 RACW_Ctrl
: Boolean := False;
946 Any
: Entity_Id
) return Node_Id
948 Parameter_Name_String
: String_Id
;
949 Parameter_Mode
: Node_Id
;
951 function Parameter_Passing_Mode
953 Parameter
: Entity_Id
;
954 Constrained
: Boolean) return Node_Id
;
955 -- Return an expression that denotes the parameter passing
956 -- mode to be used for Parameter in distribution stubs,
957 -- where Constrained is Parameter's constrained status.
959 ----------------------------
960 -- Parameter_Passing_Mode --
961 ----------------------------
963 function Parameter_Passing_Mode
965 Parameter
: Entity_Id
;
966 Constrained
: Boolean) return Node_Id
971 if Out_Present
(Parameter
) then
972 if In_Present
(Parameter
)
973 or else not Constrained
975 -- Unconstrained formals must be translated
976 -- to 'in' or 'inout', not 'out', because
977 -- they need to be constrained by the actual.
979 Lib_RE
:= RE_Mode_Inout
;
981 Lib_RE
:= RE_Mode_Out
;
985 Lib_RE
:= RE_Mode_In
;
988 return New_Occurrence_Of
(RTE
(Lib_RE
), Loc
);
989 end Parameter_Passing_Mode
;
991 -- Start of processing for Add_Parameter_To_NVList
994 if Nkind
(Parameter
) = N_Defining_Identifier
then
995 Get_Name_String
(Chars
(Parameter
));
997 Get_Name_String
(Chars
(Defining_Identifier
(Parameter
)));
1000 Parameter_Name_String
:= String_From_Name_Buffer
;
1002 if RACW_Ctrl
or else Nkind
(Parameter
) = N_Defining_Identifier
then
1004 -- When the parameter passed to Add_Parameter_To_NVList is an
1005 -- Extra_Constrained parameter, Parameter is an N_Defining_
1006 -- Identifier, instead of a complete N_Parameter_Specification.
1007 -- Thus, we explicitly set 'in' mode in this case.
1009 Parameter_Mode
:= New_Occurrence_Of
(RTE
(RE_Mode_In
), Loc
);
1013 Parameter_Passing_Mode
(Loc
, Parameter
, Constrained
);
1017 Make_Procedure_Call_Statement
(Loc
,
1020 (RTE
(RE_NVList_Add_Item
), Loc
),
1021 Parameter_Associations
=> New_List
(
1022 New_Occurrence_Of
(NVList
, Loc
),
1023 Make_Function_Call
(Loc
,
1026 (RTE
(RE_To_PolyORB_String
), Loc
),
1027 Parameter_Associations
=> New_List
(
1028 Make_String_Literal
(Loc
,
1029 Strval
=> Parameter_Name_String
))),
1030 New_Occurrence_Of
(Any
, Loc
),
1032 end Add_Parameter_To_NVList
;
1034 --------------------------------
1035 -- Add_RACW_Asynchronous_Flag --
1036 --------------------------------
1038 procedure Add_RACW_Asynchronous_Flag
1039 (Declarations
: List_Id
;
1040 RACW_Type
: Entity_Id
)
1042 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1044 Asynchronous_Flag
: constant Entity_Id
:=
1045 Make_Defining_Identifier
(Loc
,
1046 New_External_Name
(Chars
(RACW_Type
), 'A'));
1049 -- Declare the asynchronous flag. This flag will be changed to True
1050 -- whenever it is known that the RACW type is asynchronous.
1052 Append_To
(Declarations
,
1053 Make_Object_Declaration
(Loc
,
1054 Defining_Identifier
=> Asynchronous_Flag
,
1055 Constant_Present
=> True,
1056 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
1057 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
1059 Asynchronous_Flags_Table
.Set
(RACW_Type
, Asynchronous_Flag
);
1060 end Add_RACW_Asynchronous_Flag
;
1062 -----------------------
1063 -- Add_RACW_Features --
1064 -----------------------
1066 procedure Add_RACW_Features
(RACW_Type
: Entity_Id
) is
1067 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
1068 Same_Scope
: constant Boolean := Scope
(Desig
) = Scope
(RACW_Type
);
1072 Body_Decls
: List_Id
;
1074 Stub_Type
: Entity_Id
;
1075 Stub_Type_Access
: Entity_Id
;
1076 RPC_Receiver_Decl
: Node_Id
;
1079 -- True when appropriate stubs have already been generated (this is the
1080 -- case when another RACW with the same designated type has already been
1081 -- encountered, in which case we reuse the previous stubs rather than
1082 -- generating new ones).
1085 if not Expander_Active
then
1089 -- Mark the current package declaration as containing an RACW, so that
1090 -- the bodies for the calling stubs and the RACW stream subprograms
1091 -- are attached to the tree when the corresponding body is encountered.
1093 Set_Has_RACW
(Current_Scope
);
1095 -- Look for place to declare the RACW stub type and RACW operations
1101 -- Case of declaring the RACW in the same package as its designated
1102 -- type: we know that the designated type is a private type, so we
1103 -- use the private declarations list.
1105 Pkg_Spec
:= Package_Specification_Of_Scope
(Current_Scope
);
1107 if Present
(Private_Declarations
(Pkg_Spec
)) then
1108 Decls
:= Private_Declarations
(Pkg_Spec
);
1110 Decls
:= Visible_Declarations
(Pkg_Spec
);
1115 -- Case of declaring the RACW in another package than its designated
1116 -- type: use the private declarations list if present; otherwise
1117 -- use the visible declarations.
1119 Decls
:= List_Containing
(Declaration_Node
(RACW_Type
));
1123 -- If we were unable to find the declarations, that means that the
1124 -- completion of the type was missing. We can safely return and let the
1125 -- error be caught by the semantic analysis.
1132 (Designated_Type
=> Desig
,
1133 RACW_Type
=> RACW_Type
,
1135 Stub_Type
=> Stub_Type
,
1136 Stub_Type_Access
=> Stub_Type_Access
,
1137 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1138 Body_Decls
=> Body_Decls
,
1139 Existing
=> Existing
);
1141 Add_RACW_Asynchronous_Flag
1142 (Declarations
=> Decls
,
1143 RACW_Type
=> RACW_Type
);
1145 Specific_Add_RACW_Features
1146 (RACW_Type
=> RACW_Type
,
1148 Stub_Type
=> Stub_Type
,
1149 Stub_Type_Access
=> Stub_Type_Access
,
1150 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1151 Body_Decls
=> Body_Decls
);
1153 if not Same_Scope
and then not Existing
then
1155 -- The RACW has been declared in another scope than the designated
1156 -- type and has not been handled by another RACW in the same package
1157 -- as the first one, so add primitives for the stub type here.
1159 Validate_RACW_Primitives
(RACW_Type
);
1160 Add_RACW_Primitive_Declarations_And_Bodies
1161 (Designated_Type
=> Desig
,
1162 Insertion_Node
=> RPC_Receiver_Decl
,
1163 Body_Decls
=> Body_Decls
);
1166 -- Validate_RACW_Primitives will be called when the designated type
1167 -- is frozen, see Exp_Ch3.Freeze_Type.
1169 -- ??? Shouldn't we have a pragma Assert (not Is_Frozen (Desig))?
1171 Add_Access_Type_To_Process
(E
=> Desig
, A
=> RACW_Type
);
1173 end Add_RACW_Features
;
1175 ------------------------------------------------
1176 -- Add_RACW_Primitive_Declarations_And_Bodies --
1177 ------------------------------------------------
1179 procedure Add_RACW_Primitive_Declarations_And_Bodies
1180 (Designated_Type
: Entity_Id
;
1181 Insertion_Node
: Node_Id
;
1182 Body_Decls
: List_Id
)
1184 Loc
: constant Source_Ptr
:= Sloc
(Insertion_Node
);
1185 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1186 -- the declarations are recognized as belonging to the current package.
1188 Stub_Elements
: constant Stub_Structure
:=
1189 Stubs_Table
.Get
(Designated_Type
);
1191 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
1193 Is_RAS
: constant Boolean :=
1194 not Comes_From_Source
(Stub_Elements
.RACW_Type
);
1195 -- Case of the RACW generated to implement a remote access-to-
1198 Build_Bodies
: constant Boolean :=
1199 In_Extended_Main_Code_Unit
(Stub_Elements
.Stub_Type
);
1200 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1201 -- only when the main unit is the unit that contains the stub type.
1203 Current_Insertion_Node
: Node_Id
:= Insertion_Node
;
1205 RPC_Receiver
: Entity_Id
;
1206 RPC_Receiver_Statements
: List_Id
;
1207 RPC_Receiver_Case_Alternatives
: constant List_Id
:= New_List
;
1208 RPC_Receiver_Elsif_Parts
: List_Id
;
1209 RPC_Receiver_Request
: Entity_Id
;
1210 RPC_Receiver_Subp_Id
: Entity_Id
;
1211 RPC_Receiver_Subp_Index
: Entity_Id
;
1213 Subp_Str
: String_Id
;
1215 Current_Primitive_Elmt
: Elmt_Id
;
1216 Current_Primitive
: Entity_Id
;
1217 Current_Primitive_Body
: Node_Id
;
1218 Current_Primitive_Spec
: Node_Id
;
1219 Current_Primitive_Decl
: Node_Id
;
1220 Current_Primitive_Number
: Int
:= 0;
1221 Current_Primitive_Alias
: Node_Id
;
1222 Current_Receiver
: Entity_Id
;
1223 Current_Receiver_Body
: Node_Id
;
1224 RPC_Receiver_Decl
: Node_Id
;
1225 Possibly_Asynchronous
: Boolean;
1228 if not Expander_Active
then
1234 Make_Defining_Identifier
(Loc
,
1235 Chars
=> New_Internal_Name
('P'));
1236 Specific_Build_RPC_Receiver_Body
1237 (RPC_Receiver
=> RPC_Receiver
,
1238 Request
=> RPC_Receiver_Request
,
1239 Subp_Id
=> RPC_Receiver_Subp_Id
,
1240 Subp_Index
=> RPC_Receiver_Subp_Index
,
1241 Stmts
=> RPC_Receiver_Statements
,
1242 Decl
=> RPC_Receiver_Decl
);
1244 if Get_PCS_Name
= Name_PolyORB_DSA
then
1246 -- For the case of PolyORB, we need to map a textual operation
1247 -- name into a primitive index. Currently we do so using a simple
1248 -- sequence of string comparisons.
1250 RPC_Receiver_Elsif_Parts
:= New_List
;
1254 -- Build callers, receivers for every primitive operations and a RPC
1255 -- receiver for this type.
1257 if Present
(Primitive_Operations
(Designated_Type
)) then
1258 Overload_Counter_Table
.Reset
;
1260 Current_Primitive_Elmt
:=
1261 First_Elmt
(Primitive_Operations
(Designated_Type
));
1262 while Current_Primitive_Elmt
/= No_Elmt
loop
1263 Current_Primitive
:= Node
(Current_Primitive_Elmt
);
1265 -- Copy the primitive of all the parents, except predefined ones
1266 -- that are not remotely dispatching.
1268 if Chars
(Current_Primitive
) /= Name_uSize
1269 and then Chars
(Current_Primitive
) /= Name_uAlignment
1271 (Is_TSS
(Current_Primitive
, TSS_Deep_Finalize
) or else
1272 Is_TSS
(Current_Primitive
, TSS_Stream_Input
) or else
1273 Is_TSS
(Current_Primitive
, TSS_Stream_Output
) or else
1274 Is_TSS
(Current_Primitive
, TSS_Stream_Read
) or else
1275 Is_TSS
(Current_Primitive
, TSS_Stream_Write
))
1277 -- The first thing to do is build an up-to-date copy of the
1278 -- spec with all the formals referencing Designated_Type
1279 -- transformed into formals referencing Stub_Type. Since this
1280 -- primitive may have been inherited, go back the alias chain
1281 -- until the real primitive has been found.
1283 Current_Primitive_Alias
:= Current_Primitive
;
1284 while Present
(Alias
(Current_Primitive_Alias
)) loop
1286 (Current_Primitive_Alias
1287 /= Alias
(Current_Primitive_Alias
));
1288 Current_Primitive_Alias
:= Alias
(Current_Primitive_Alias
);
1291 -- Copy the spec from the original declaration for the purpose
1292 -- of declaring an overriding subprogram: we need to replace
1293 -- the type of each controlling formal with Stub_Type. The
1294 -- primitive may have been declared for Designated_Type or
1295 -- inherited from some ancestor type for which we do not have
1296 -- an easily determined Entity_Id. We have no systematic way
1297 -- of knowing which type to substitute Stub_Type for. Instead,
1298 -- Copy_Specification relies on the flag Is_Controlling_Formal
1299 -- to determine which formals to change.
1301 Current_Primitive_Spec
:=
1302 Copy_Specification
(Loc
,
1303 Spec
=> Parent
(Current_Primitive_Alias
),
1304 Ctrl_Type
=> Stub_Elements
.Stub_Type
);
1306 Current_Primitive_Decl
:=
1307 Make_Subprogram_Declaration
(Loc
,
1308 Specification
=> Current_Primitive_Spec
);
1310 Insert_After_And_Analyze
(Current_Insertion_Node
,
1311 Current_Primitive_Decl
);
1312 Current_Insertion_Node
:= Current_Primitive_Decl
;
1314 Possibly_Asynchronous
:=
1315 Nkind
(Current_Primitive_Spec
) = N_Procedure_Specification
1316 and then Could_Be_Asynchronous
(Current_Primitive_Spec
);
1318 Assign_Subprogram_Identifier
(
1319 Defining_Unit_Name
(Current_Primitive_Spec
),
1320 Current_Primitive_Number
,
1323 if Build_Bodies
then
1324 Current_Primitive_Body
:=
1325 Build_Subprogram_Calling_Stubs
1326 (Vis_Decl
=> Current_Primitive_Decl
,
1328 Build_Subprogram_Id
(Loc
,
1329 Defining_Unit_Name
(Current_Primitive_Spec
)),
1330 Asynchronous
=> Possibly_Asynchronous
,
1331 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1332 Stub_Type
=> Stub_Elements
.Stub_Type
,
1333 RACW_Type
=> Stub_Elements
.RACW_Type
);
1334 Append_To
(Body_Decls
, Current_Primitive_Body
);
1336 -- Analyzing the body here would cause the Stub type to
1337 -- be frozen, thus preventing subsequent primitive
1338 -- declarations. For this reason, it will be analyzed
1339 -- later in the regular flow (and in the context of the
1340 -- appropriate unit body, see Append_RACW_Bodies).
1344 -- Build the receiver stubs
1346 if Build_Bodies
and then not Is_RAS
then
1347 Current_Receiver_Body
:=
1348 Specific_Build_Subprogram_Receiving_Stubs
1349 (Vis_Decl
=> Current_Primitive_Decl
,
1350 Asynchronous
=> Possibly_Asynchronous
,
1351 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1352 Stub_Type
=> Stub_Elements
.Stub_Type
,
1353 RACW_Type
=> Stub_Elements
.RACW_Type
,
1354 Parent_Primitive
=> Current_Primitive
);
1356 Current_Receiver
:= Defining_Unit_Name
(
1357 Specification
(Current_Receiver_Body
));
1359 Append_To
(Body_Decls
, Current_Receiver_Body
);
1361 -- Add a case alternative to the receiver
1363 if Get_PCS_Name
= Name_PolyORB_DSA
then
1364 Append_To
(RPC_Receiver_Elsif_Parts
,
1365 Make_Elsif_Part
(Loc
,
1367 Make_Function_Call
(Loc
,
1370 RTE
(RE_Caseless_String_Eq
), Loc
),
1371 Parameter_Associations
=> New_List
(
1372 New_Occurrence_Of
(RPC_Receiver_Subp_Id
, Loc
),
1373 Make_String_Literal
(Loc
, Subp_Str
))),
1374 Then_Statements
=> New_List
(
1375 Make_Assignment_Statement
(Loc
,
1376 Name
=> New_Occurrence_Of
(
1377 RPC_Receiver_Subp_Index
, Loc
),
1379 Make_Integer_Literal
(Loc
,
1380 Current_Primitive_Number
)))));
1383 Append_To
(RPC_Receiver_Case_Alternatives
,
1384 Make_Case_Statement_Alternative
(Loc
,
1385 Discrete_Choices
=> New_List
(
1386 Make_Integer_Literal
(Loc
, Current_Primitive_Number
)),
1388 Statements
=> New_List
(
1389 Make_Procedure_Call_Statement
(Loc
,
1391 New_Occurrence_Of
(Current_Receiver
, Loc
),
1392 Parameter_Associations
=> New_List
(
1393 New_Occurrence_Of
(RPC_Receiver_Request
, Loc
))))));
1396 -- Increment the index of current primitive
1398 Current_Primitive_Number
:= Current_Primitive_Number
+ 1;
1401 Next_Elmt
(Current_Primitive_Elmt
);
1405 -- Build the case statement and the heart of the subprogram
1407 if Build_Bodies
and then not Is_RAS
then
1408 if Get_PCS_Name
= Name_PolyORB_DSA
1409 and then Present
(First
(RPC_Receiver_Elsif_Parts
))
1411 Append_To
(RPC_Receiver_Statements
,
1412 Make_Implicit_If_Statement
(Designated_Type
,
1413 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
1414 Then_Statements
=> New_List
,
1415 Elsif_Parts
=> RPC_Receiver_Elsif_Parts
));
1418 Append_To
(RPC_Receiver_Case_Alternatives
,
1419 Make_Case_Statement_Alternative
(Loc
,
1420 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1421 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
1423 Append_To
(RPC_Receiver_Statements
,
1424 Make_Case_Statement
(Loc
,
1426 New_Occurrence_Of
(RPC_Receiver_Subp_Index
, Loc
),
1427 Alternatives
=> RPC_Receiver_Case_Alternatives
));
1429 Append_To
(Body_Decls
, RPC_Receiver_Decl
);
1430 Specific_Add_Obj_RPC_Receiver_Completion
(Loc
,
1431 Body_Decls
, RPC_Receiver
, Stub_Elements
);
1433 -- Do not analyze RPC receiver body at this stage since it references
1434 -- subprograms that have not been analyzed yet. It will be analyzed in
1435 -- the regular flow (see Append_RACW_Bodies).
1438 end Add_RACW_Primitive_Declarations_And_Bodies
;
1440 -----------------------------
1441 -- Add_RAS_Dereference_TSS --
1442 -----------------------------
1444 procedure Add_RAS_Dereference_TSS
(N
: Node_Id
) is
1445 Loc
: constant Source_Ptr
:= Sloc
(N
);
1447 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
1448 RAS_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
1449 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(RAS_Type
);
1450 RACW_Type
: constant Entity_Id
:= Underlying_RACW_Type
(RAS_Type
);
1451 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
1453 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
1454 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
1456 RACW_Primitive_Name
: Node_Id
;
1458 Proc
: constant Entity_Id
:=
1459 Make_Defining_Identifier
(Loc
,
1460 Chars
=> Make_TSS_Name
(RAS_Type
, TSS_RAS_Dereference
));
1462 Proc_Spec
: Node_Id
;
1463 Param_Specs
: List_Id
;
1464 Param_Assoc
: constant List_Id
:= New_List
;
1465 Stmts
: constant List_Id
:= New_List
;
1467 RAS_Parameter
: constant Entity_Id
:=
1468 Make_Defining_Identifier
(Loc
,
1469 Chars
=> New_Internal_Name
('P'));
1471 Is_Function
: constant Boolean :=
1472 Nkind
(Type_Def
) = N_Access_Function_Definition
;
1474 Is_Degenerate
: Boolean;
1475 -- Set to True if the subprogram_specification for this RAS has an
1476 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1478 Spec
: constant Node_Id
:= Type_Def
;
1480 Current_Parameter
: Node_Id
;
1482 -- Start of processing for Add_RAS_Dereference_TSS
1485 -- The Dereference TSS for a remote access-to-subprogram type has the
1488 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1491 -- This is called whenever a value of a RAS type is dereferenced
1493 -- First construct a list of parameter specifications:
1495 -- The first formal is the RAS values
1497 Param_Specs
:= New_List
(
1498 Make_Parameter_Specification
(Loc
,
1499 Defining_Identifier
=> RAS_Parameter
,
1502 New_Occurrence_Of
(Fat_Type
, Loc
)));
1504 -- The following formals are copied from the type declaration
1506 Is_Degenerate
:= False;
1507 Current_Parameter
:= First
(Parameter_Specifications
(Type_Def
));
1508 Parameters
: while Present
(Current_Parameter
) loop
1509 if Nkind
(Parameter_Type
(Current_Parameter
)) =
1512 Is_Degenerate
:= True;
1515 Append_To
(Param_Specs
,
1516 Make_Parameter_Specification
(Loc
,
1517 Defining_Identifier
=>
1518 Make_Defining_Identifier
(Loc
,
1519 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))),
1520 In_Present
=> In_Present
(Current_Parameter
),
1521 Out_Present
=> Out_Present
(Current_Parameter
),
1523 New_Copy_Tree
(Parameter_Type
(Current_Parameter
)),
1525 New_Copy_Tree
(Expression
(Current_Parameter
))));
1527 Append_To
(Param_Assoc
,
1528 Make_Identifier
(Loc
,
1529 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))));
1531 Next
(Current_Parameter
);
1532 end loop Parameters
;
1534 if Is_Degenerate
then
1535 Prepend_To
(Param_Assoc
, New_Occurrence_Of
(RAS_Parameter
, Loc
));
1537 -- Generate a dummy body. This code will never actually be executed,
1538 -- because null is the only legal value for a degenerate RAS type.
1539 -- For legality's sake (in order to avoid generating a function that
1540 -- does not contain a return statement), we include a dummy recursive
1541 -- call on the TSS itself.
1544 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Explicit_Raise
));
1545 RACW_Primitive_Name
:= New_Occurrence_Of
(Proc
, Loc
);
1548 -- For a normal RAS type, we cast the RAS formal to the corresponding
1549 -- tagged type, and perform a dispatching call to its Call primitive
1552 Prepend_To
(Param_Assoc
,
1553 Unchecked_Convert_To
(RACW_Type
,
1554 New_Occurrence_Of
(RAS_Parameter
, Loc
)));
1556 RACW_Primitive_Name
:=
1557 Make_Selected_Component
(Loc
,
1558 Prefix
=> Scope
(RACW_Type
),
1559 Selector_Name
=> Name_uCall
);
1564 Make_Simple_Return_Statement
(Loc
,
1566 Make_Function_Call
(Loc
,
1567 Name
=> RACW_Primitive_Name
,
1568 Parameter_Associations
=> Param_Assoc
)));
1572 Make_Procedure_Call_Statement
(Loc
,
1573 Name
=> RACW_Primitive_Name
,
1574 Parameter_Associations
=> Param_Assoc
));
1577 -- Build the complete subprogram
1581 Make_Function_Specification
(Loc
,
1582 Defining_Unit_Name
=> Proc
,
1583 Parameter_Specifications
=> Param_Specs
,
1584 Result_Definition
=>
1586 Entity
(Result_Definition
(Spec
)), Loc
));
1588 Set_Ekind
(Proc
, E_Function
);
1590 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
1594 Make_Procedure_Specification
(Loc
,
1595 Defining_Unit_Name
=> Proc
,
1596 Parameter_Specifications
=> Param_Specs
);
1598 Set_Ekind
(Proc
, E_Procedure
);
1599 Set_Etype
(Proc
, Standard_Void_Type
);
1603 Make_Subprogram_Body
(Loc
,
1604 Specification
=> Proc_Spec
,
1605 Declarations
=> New_List
,
1606 Handled_Statement_Sequence
=>
1607 Make_Handled_Sequence_Of_Statements
(Loc
,
1608 Statements
=> Stmts
)));
1610 Set_TSS
(Fat_Type
, Proc
);
1611 end Add_RAS_Dereference_TSS
;
1613 -------------------------------
1614 -- Add_RAS_Proxy_And_Analyze --
1615 -------------------------------
1617 procedure Add_RAS_Proxy_And_Analyze
1620 All_Calls_Remote_E
: Entity_Id
;
1621 Proxy_Object_Addr
: out Entity_Id
)
1623 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
1625 Subp_Name
: constant Entity_Id
:=
1626 Defining_Unit_Name
(Specification
(Vis_Decl
));
1628 Pkg_Name
: constant Entity_Id
:=
1629 Make_Defining_Identifier
(Loc
,
1631 New_External_Name
(Chars
(Subp_Name
), 'P', -1));
1633 Proxy_Type
: constant Entity_Id
:=
1634 Make_Defining_Identifier
(Loc
,
1637 Related_Id
=> Chars
(Subp_Name
),
1640 Proxy_Type_Full_View
: constant Entity_Id
:=
1641 Make_Defining_Identifier
(Loc
,
1642 Chars
(Proxy_Type
));
1644 Subp_Decl_Spec
: constant Node_Id
:=
1645 Build_RAS_Primitive_Specification
1646 (Subp_Spec
=> Specification
(Vis_Decl
),
1647 Remote_Object_Type
=> Proxy_Type
);
1649 Subp_Body_Spec
: constant Node_Id
:=
1650 Build_RAS_Primitive_Specification
1651 (Subp_Spec
=> Specification
(Vis_Decl
),
1652 Remote_Object_Type
=> Proxy_Type
);
1654 Vis_Decls
: constant List_Id
:= New_List
;
1655 Pvt_Decls
: constant List_Id
:= New_List
;
1656 Actuals
: constant List_Id
:= New_List
;
1658 Perform_Call
: Node_Id
;
1661 -- type subpP is tagged limited private;
1663 Append_To
(Vis_Decls
,
1664 Make_Private_Type_Declaration
(Loc
,
1665 Defining_Identifier
=> Proxy_Type
,
1666 Tagged_Present
=> True,
1667 Limited_Present
=> True));
1669 -- [subprogram] Call
1670 -- (Self : access subpP;
1671 -- ...other-formals...)
1674 Append_To
(Vis_Decls
,
1675 Make_Subprogram_Declaration
(Loc
,
1676 Specification
=> Subp_Decl_Spec
));
1678 -- A : constant System.Address;
1680 Proxy_Object_Addr
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1682 Append_To
(Vis_Decls
,
1683 Make_Object_Declaration
(Loc
,
1684 Defining_Identifier
=>
1688 Object_Definition
=>
1689 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
1693 -- type subpP is tagged limited record
1694 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1698 Append_To
(Pvt_Decls
,
1699 Make_Full_Type_Declaration
(Loc
,
1700 Defining_Identifier
=>
1701 Proxy_Type_Full_View
,
1703 Build_Remote_Subprogram_Proxy_Type
(Loc
,
1704 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
))));
1706 -- Trick semantic analysis into swapping the public and full view when
1707 -- freezing the public view.
1709 Set_Comes_From_Source
(Proxy_Type_Full_View
, True);
1712 -- (Self : access O;
1713 -- ...other-formals...) is
1715 -- P (...other-formals...);
1719 -- (Self : access O;
1720 -- ...other-formals...)
1723 -- return F (...other-formals...);
1726 if Nkind
(Subp_Decl_Spec
) = N_Procedure_Specification
then
1728 Make_Procedure_Call_Statement
(Loc
,
1730 New_Occurrence_Of
(Subp_Name
, Loc
),
1731 Parameter_Associations
=>
1735 Make_Simple_Return_Statement
(Loc
,
1737 Make_Function_Call
(Loc
,
1739 New_Occurrence_Of
(Subp_Name
, Loc
),
1740 Parameter_Associations
=>
1744 Formal
:= First
(Parameter_Specifications
(Subp_Decl_Spec
));
1745 pragma Assert
(Present
(Formal
));
1748 exit when No
(Formal
);
1750 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1753 -- O : aliased subpP;
1755 Append_To
(Pvt_Decls
,
1756 Make_Object_Declaration
(Loc
,
1757 Defining_Identifier
=>
1758 Make_Defining_Identifier
(Loc
,
1762 Object_Definition
=>
1763 New_Occurrence_Of
(Proxy_Type
, Loc
)));
1765 -- A : constant System.Address := O'Address;
1767 Append_To
(Pvt_Decls
,
1768 Make_Object_Declaration
(Loc
,
1769 Defining_Identifier
=>
1770 Make_Defining_Identifier
(Loc
,
1771 Chars
(Proxy_Object_Addr
)),
1774 Object_Definition
=>
1775 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
1777 Make_Attribute_Reference
(Loc
,
1778 Prefix
=> New_Occurrence_Of
(
1779 Defining_Identifier
(Last
(Pvt_Decls
)), Loc
),
1784 Make_Package_Declaration
(Loc
,
1785 Specification
=> Make_Package_Specification
(Loc
,
1786 Defining_Unit_Name
=> Pkg_Name
,
1787 Visible_Declarations
=> Vis_Decls
,
1788 Private_Declarations
=> Pvt_Decls
,
1789 End_Label
=> Empty
)));
1790 Analyze
(Last
(Decls
));
1793 Make_Package_Body
(Loc
,
1794 Defining_Unit_Name
=>
1795 Make_Defining_Identifier
(Loc
,
1797 Declarations
=> New_List
(
1798 Make_Subprogram_Body
(Loc
,
1801 Declarations
=> New_List
,
1802 Handled_Statement_Sequence
=>
1803 Make_Handled_Sequence_Of_Statements
(Loc
,
1804 Statements
=> New_List
(Perform_Call
))))));
1805 Analyze
(Last
(Decls
));
1806 end Add_RAS_Proxy_And_Analyze
;
1808 -----------------------
1809 -- Add_RAST_Features --
1810 -----------------------
1812 procedure Add_RAST_Features
(Vis_Decl
: Node_Id
) is
1813 RAS_Type
: constant Entity_Id
:=
1814 Equivalent_Type
(Defining_Identifier
(Vis_Decl
));
1816 pragma Assert
(No
(TSS
(RAS_Type
, TSS_RAS_Access
)));
1817 Add_RAS_Dereference_TSS
(Vis_Decl
);
1818 Specific_Add_RAST_Features
(Vis_Decl
, RAS_Type
);
1819 end Add_RAST_Features
;
1825 procedure Add_Stub_Type
1826 (Designated_Type
: Entity_Id
;
1827 RACW_Type
: Entity_Id
;
1829 Stub_Type
: out Entity_Id
;
1830 Stub_Type_Access
: out Entity_Id
;
1831 RPC_Receiver_Decl
: out Node_Id
;
1832 Body_Decls
: out List_Id
;
1833 Existing
: out Boolean)
1835 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1837 Stub_Elements
: constant Stub_Structure
:=
1838 Stubs_Table
.Get
(Designated_Type
);
1839 Stub_Type_Decl
: Node_Id
;
1840 Stub_Type_Access_Decl
: Node_Id
;
1843 if Stub_Elements
/= Empty_Stub_Structure
then
1844 Stub_Type
:= Stub_Elements
.Stub_Type
;
1845 Stub_Type_Access
:= Stub_Elements
.Stub_Type_Access
;
1846 RPC_Receiver_Decl
:= Stub_Elements
.RPC_Receiver_Decl
;
1847 Body_Decls
:= Stub_Elements
.Body_Decls
;
1854 Make_Defining_Identifier
(Loc
,
1855 Chars
=> New_Internal_Name
('S'));
1857 Make_Defining_Identifier
(Loc
,
1858 Chars
=> New_External_Name
1859 (Related_Id
=> Chars
(Stub_Type
), Suffix
=> 'A'));
1861 Specific_Build_Stub_Type
1862 (RACW_Type
, Stub_Type
,
1863 Stub_Type_Decl
, RPC_Receiver_Decl
);
1865 Stub_Type_Access_Decl
:=
1866 Make_Full_Type_Declaration
(Loc
,
1867 Defining_Identifier
=> Stub_Type_Access
,
1869 Make_Access_To_Object_Definition
(Loc
,
1870 All_Present
=> True,
1871 Subtype_Indication
=> New_Occurrence_Of
(Stub_Type
, Loc
)));
1873 Append_To
(Decls
, Stub_Type_Decl
);
1874 Analyze
(Last
(Decls
));
1875 Append_To
(Decls
, Stub_Type_Access_Decl
);
1876 Analyze
(Last
(Decls
));
1878 -- This is in no way a type derivation, but we fake it to make sure that
1879 -- the dispatching table gets built with the corresponding primitive
1880 -- operations at the right place.
1882 Derive_Subprograms
(Parent_Type
=> Designated_Type
,
1883 Derived_Type
=> Stub_Type
);
1885 if Present
(RPC_Receiver_Decl
) then
1886 Append_To
(Decls
, RPC_Receiver_Decl
);
1888 RPC_Receiver_Decl
:= Last
(Decls
);
1891 Body_Decls
:= New_List
;
1893 Stubs_Table
.Set
(Designated_Type
,
1894 (Stub_Type
=> Stub_Type
,
1895 Stub_Type_Access
=> Stub_Type_Access
,
1896 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1897 Body_Decls
=> Body_Decls
,
1898 RACW_Type
=> RACW_Type
));
1901 ------------------------
1902 -- Append_RACW_Bodies --
1903 ------------------------
1905 procedure Append_RACW_Bodies
(Decls
: List_Id
; Spec_Id
: Entity_Id
) is
1908 E
:= First_Entity
(Spec_Id
);
1909 while Present
(E
) loop
1910 if Is_Remote_Access_To_Class_Wide_Type
(E
) then
1911 Append_List_To
(Decls
, Get_And_Reset_RACW_Bodies
(E
));
1916 end Append_RACW_Bodies
;
1918 ----------------------------------
1919 -- Assign_Subprogram_Identifier --
1920 ----------------------------------
1922 procedure Assign_Subprogram_Identifier
1927 N
: constant Name_Id
:= Chars
(Def
);
1929 Overload_Order
: constant Int
:=
1930 Overload_Counter_Table
.Get
(N
) + 1;
1933 Overload_Counter_Table
.Set
(N
, Overload_Order
);
1935 Get_Name_String
(N
);
1937 -- Homonym handling: as in Exp_Dbug, but much simpler,
1938 -- because the only entities for which we have to generate
1939 -- names here need only to be disambiguated within their
1942 if Overload_Order
> 1 then
1943 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 2) := "__";
1944 Name_Len
:= Name_Len
+ 2;
1945 Add_Nat_To_Name_Buffer
(Overload_Order
);
1948 Id
:= String_From_Name_Buffer
;
1949 Subprogram_Identifier_Table
.Set
(Def
,
1950 Subprogram_Identifiers
'(Str_Identifier => Id, Int_Identifier => Spn));
1951 end Assign_Subprogram_Identifier;
1953 -------------------------------------
1954 -- Build_Actual_Object_Declaration --
1955 -------------------------------------
1957 procedure Build_Actual_Object_Declaration
1958 (Object : Entity_Id;
1964 Loc : constant Source_Ptr := Sloc (Object);
1966 -- Declare a temporary object for the actual, possibly initialized with
1967 -- a 'Input
/From_Any call
.
1969 -- Complication arises in the case of limited types, for which such a
1970 -- declaration is illegal in Ada 95. In that case, we first generate a
1971 -- renaming declaration of the 'Input call, and then if needed we
1972 -- generate an overlaid non-constant view.
1974 if Ada_Version
<= Ada_95
1975 and then Is_Limited_Type
(Etyp
)
1976 and then Present
(Expr
)
1979 -- Object : Etyp renames <func-call>
1982 Make_Object_Renaming_Declaration
(Loc
,
1983 Defining_Identifier
=> Object
,
1984 Subtype_Mark
=> New_Occurrence_Of
(Etyp
, Loc
),
1989 -- The name defined by the renaming declaration denotes a
1990 -- constant view; create a non-constant object at the same address
1991 -- to be used as the actual.
1994 Constant_Object
: constant Entity_Id
:=
1995 Make_Defining_Identifier
(Loc
,
1996 New_Internal_Name
('P'));
1998 Set_Defining_Identifier
1999 (Last
(Decls
), Constant_Object
);
2001 -- We have an unconstrained Etyp: build the actual constrained
2002 -- subtype for the value we just read from the stream.
2004 -- suubtype S is <actual subtype of Constant_Object>;
2007 Build_Actual_Subtype
(Etyp
,
2008 New_Occurrence_Of
(Constant_Object
, Loc
)));
2013 Make_Object_Declaration
(Loc
,
2014 Defining_Identifier
=> Object
,
2015 Object_Definition
=>
2017 (Defining_Identifier
(Last
(Decls
)), Loc
)));
2018 Set_Ekind
(Object
, E_Variable
);
2020 -- Suppress default initialization:
2021 -- pragma Import (Ada, Object);
2025 Chars
=> Name_Import
,
2026 Pragma_Argument_Associations
=> New_List
(
2027 Make_Pragma_Argument_Association
(Loc
,
2028 Chars
=> Name_Convention
,
2029 Expression
=> Make_Identifier
(Loc
, Name_Ada
)),
2030 Make_Pragma_Argument_Association
(Loc
,
2031 Chars
=> Name_Entity
,
2032 Expression
=> New_Occurrence_Of
(Object
, Loc
)))));
2034 -- for Object'Address use Constant_Object'Address;
2037 Make_Attribute_Definition_Clause
(Loc
,
2038 Name
=> New_Occurrence_Of
(Object
, Loc
),
2039 Chars
=> Name_Address
,
2041 Make_Attribute_Reference
(Loc
,
2043 New_Occurrence_Of
(Constant_Object
, Loc
),
2051 -- General case of a regular object declaration. Object is flagged
2052 -- constant unless it has mode out or in out, to allow the backend
2053 -- to optimize where possible.
2055 -- Object : [constant] Etyp [:= <expr>];
2058 Make_Object_Declaration
(Loc
,
2059 Defining_Identifier
=> Object
,
2060 Constant_Present
=> Present
(Expr
) and then not Variable
,
2061 Object_Definition
=>
2062 New_Occurrence_Of
(Etyp
, Loc
),
2063 Expression
=> Expr
));
2065 if Constant_Present
(Last
(Decls
)) then
2066 Set_Ekind
(Object
, E_Constant
);
2068 Set_Ekind
(Object
, E_Variable
);
2071 end Build_Actual_Object_Declaration
;
2073 ------------------------------
2074 -- Build_Get_Unique_RP_Call --
2075 ------------------------------
2077 function Build_Get_Unique_RP_Call
2079 Pointer
: Entity_Id
;
2080 Stub_Type
: Entity_Id
) return List_Id
2084 Make_Procedure_Call_Statement
(Loc
,
2086 New_Occurrence_Of
(RTE
(RE_Get_Unique_Remote_Pointer
), Loc
),
2087 Parameter_Associations
=> New_List
(
2088 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2089 New_Occurrence_Of
(Pointer
, Loc
)))),
2091 Make_Assignment_Statement
(Loc
,
2093 Make_Selected_Component
(Loc
,
2095 New_Occurrence_Of
(Pointer
, Loc
),
2097 New_Occurrence_Of
(First_Tag_Component
2098 (Designated_Type
(Etype
(Pointer
))), Loc
)),
2100 Make_Attribute_Reference
(Loc
,
2102 New_Occurrence_Of
(Stub_Type
, Loc
),
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
;
2121 First_Parameter
: Node_Id
;
2122 For_RAS
: Boolean := False;
2125 if No
(Parameter_Specifications
(Spec
)) then
2129 Constrained_List
:= New_List
;
2130 Unconstrained_List
:= New_List
;
2131 First_Parameter
:= First
(Parameter_Specifications
(Spec
));
2133 if Nkind
(Parameter_Type
(First_Parameter
)) = N_Access_Definition
2134 and then Chars
(Defining_Identifier
(First_Parameter
)) = Name_uS
2139 -- Loop through the parameters and add them to the right list
2141 Current_Parameter
:= First_Parameter
;
2142 while Present
(Current_Parameter
) loop
2143 if (Nkind
(Parameter_Type
(Current_Parameter
)) = N_Access_Definition
2145 Is_Constrained
(Etype
(Parameter_Type
(Current_Parameter
)))
2147 Is_Elementary_Type
(Etype
(Parameter_Type
(Current_Parameter
))))
2148 and then not (For_RAS
and then Current_Parameter
= First_Parameter
)
2150 Append_To
(Constrained_List
, New_Copy
(Current_Parameter
));
2152 Append_To
(Unconstrained_List
, New_Copy
(Current_Parameter
));
2155 Next
(Current_Parameter
);
2158 -- Unconstrained parameters are returned first
2160 Append_List_To
(Unconstrained_List
, Constrained_List
);
2162 return Unconstrained_List
;
2163 end Build_Ordered_Parameters_List
;
2165 ----------------------------------
2166 -- Build_Passive_Partition_Stub --
2167 ----------------------------------
2169 procedure Build_Passive_Partition_Stub
(U
: Node_Id
) is
2171 Pkg_Name
: String_Id
;
2174 Loc
: constant Source_Ptr
:= Sloc
(U
);
2177 -- Verify that the implementation supports distribution, by accessing
2178 -- a type defined in the proper version of system.rpc
2181 Dist_OK
: Entity_Id
;
2182 pragma Warnings
(Off
, Dist_OK
);
2184 Dist_OK
:= RTE
(RE_Params_Stream_Type
);
2187 -- Use body if present, spec otherwise
2189 if Nkind
(U
) = N_Package_Declaration
then
2190 Pkg_Spec
:= Specification
(U
);
2191 L
:= Visible_Declarations
(Pkg_Spec
);
2193 Pkg_Spec
:= Parent
(Corresponding_Spec
(U
));
2194 L
:= Declarations
(U
);
2197 Get_Library_Unit_Name_String
(Pkg_Spec
);
2198 Pkg_Name
:= String_From_Name_Buffer
;
2200 Make_Procedure_Call_Statement
(Loc
,
2202 New_Occurrence_Of
(RTE
(RE_Register_Passive_Package
), Loc
),
2203 Parameter_Associations
=> New_List
(
2204 Make_String_Literal
(Loc
, Pkg_Name
),
2205 Make_Attribute_Reference
(Loc
,
2207 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
2212 end Build_Passive_Partition_Stub
;
2214 --------------------------------------
2215 -- Build_RPC_Receiver_Specification --
2216 --------------------------------------
2218 function Build_RPC_Receiver_Specification
2219 (RPC_Receiver
: Entity_Id
;
2220 Request_Parameter
: Entity_Id
) return Node_Id
2222 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
2225 Make_Procedure_Specification
(Loc
,
2226 Defining_Unit_Name
=> RPC_Receiver
,
2227 Parameter_Specifications
=> New_List
(
2228 Make_Parameter_Specification
(Loc
,
2229 Defining_Identifier
=> Request_Parameter
,
2231 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
2232 end Build_RPC_Receiver_Specification
;
2234 ----------------------------------------
2235 -- Build_Remote_Subprogram_Proxy_Type --
2236 ----------------------------------------
2238 function Build_Remote_Subprogram_Proxy_Type
2240 ACR_Expression
: Node_Id
) return Node_Id
2244 Make_Record_Definition
(Loc
,
2245 Tagged_Present
=> True,
2246 Limited_Present
=> True,
2248 Make_Component_List
(Loc
,
2250 Component_Items
=> New_List
(
2251 Make_Component_Declaration
(Loc
,
2252 Defining_Identifier
=>
2253 Make_Defining_Identifier
(Loc
,
2254 Name_All_Calls_Remote
),
2255 Component_Definition
=>
2256 Make_Component_Definition
(Loc
,
2257 Subtype_Indication
=>
2258 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
2262 Make_Component_Declaration
(Loc
,
2263 Defining_Identifier
=>
2264 Make_Defining_Identifier
(Loc
,
2266 Component_Definition
=>
2267 Make_Component_Definition
(Loc
,
2268 Subtype_Indication
=>
2269 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2271 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)),
2273 Make_Component_Declaration
(Loc
,
2274 Defining_Identifier
=>
2275 Make_Defining_Identifier
(Loc
,
2277 Component_Definition
=>
2278 Make_Component_Definition
(Loc
,
2279 Subtype_Indication
=>
2280 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))))));
2281 end Build_Remote_Subprogram_Proxy_Type
;
2283 ------------------------------------
2284 -- Build_Subprogram_Calling_Stubs --
2285 ------------------------------------
2287 function Build_Subprogram_Calling_Stubs
2288 (Vis_Decl
: Node_Id
;
2290 Asynchronous
: Boolean;
2291 Dynamically_Asynchronous
: Boolean := False;
2292 Stub_Type
: Entity_Id
:= Empty
;
2293 RACW_Type
: Entity_Id
:= Empty
;
2294 Locator
: Entity_Id
:= Empty
;
2295 New_Name
: Name_Id
:= No_Name
) return Node_Id
2297 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
2299 Decls
: constant List_Id
:= New_List
;
2300 Statements
: constant List_Id
:= New_List
;
2302 Subp_Spec
: Node_Id
;
2303 -- The specification of the body
2305 Controlling_Parameter
: Entity_Id
:= Empty
;
2307 Asynchronous_Expr
: Node_Id
:= Empty
;
2309 RCI_Locator
: Entity_Id
;
2311 Spec_To_Use
: Node_Id
;
2313 procedure Insert_Partition_Check
(Parameter
: Node_Id
);
2314 -- Check that the parameter has been elaborated on the same partition
2315 -- than the controlling parameter (E.4(19)).
2317 ----------------------------
2318 -- Insert_Partition_Check --
2319 ----------------------------
2321 procedure Insert_Partition_Check
(Parameter
: Node_Id
) is
2322 Parameter_Entity
: constant Entity_Id
:=
2323 Defining_Identifier
(Parameter
);
2325 -- The expression that will be built is of the form:
2327 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2328 -- raise Constraint_Error;
2331 -- We do not check that Parameter is in Stub_Type since such a check
2332 -- has been inserted at the point of call already (a tag check since
2333 -- we have multiple controlling operands).
2336 Make_Raise_Constraint_Error
(Loc
,
2340 Make_Function_Call
(Loc
,
2342 New_Occurrence_Of
(RTE
(RE_Same_Partition
), Loc
),
2343 Parameter_Associations
=>
2345 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2346 New_Occurrence_Of
(Parameter_Entity
, Loc
)),
2347 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2348 New_Occurrence_Of
(Controlling_Parameter
, Loc
))))),
2349 Reason
=> CE_Partition_Check_Failed
));
2350 end Insert_Partition_Check
;
2352 -- Start of processing for Build_Subprogram_Calling_Stubs
2355 Subp_Spec
:= Copy_Specification
(Loc
,
2356 Spec
=> Specification
(Vis_Decl
),
2357 New_Name
=> New_Name
);
2359 if Locator
= Empty
then
2360 RCI_Locator
:= RCI_Cache
;
2361 Spec_To_Use
:= Specification
(Vis_Decl
);
2363 RCI_Locator
:= Locator
;
2364 Spec_To_Use
:= Subp_Spec
;
2367 -- Find a controlling argument if we have a stub type. Also check
2368 -- if this subprogram can be made asynchronous.
2370 if Present
(Stub_Type
)
2371 and then Present
(Parameter_Specifications
(Spec_To_Use
))
2374 Current_Parameter
: Node_Id
:=
2375 First
(Parameter_Specifications
2378 while Present
(Current_Parameter
) loop
2380 Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
)
2382 if Controlling_Parameter
= Empty
then
2383 Controlling_Parameter
:=
2384 Defining_Identifier
(Current_Parameter
);
2386 Insert_Partition_Check
(Current_Parameter
);
2390 Next
(Current_Parameter
);
2395 pragma Assert
(No
(Stub_Type
) or else Present
(Controlling_Parameter
));
2397 if Dynamically_Asynchronous
then
2398 Asynchronous_Expr
:= Make_Selected_Component
(Loc
,
2399 Prefix
=> Controlling_Parameter
,
2400 Selector_Name
=> Name_Asynchronous
);
2403 Specific_Build_General_Calling_Stubs
2405 Statements
=> Statements
,
2406 Target
=> Specific_Build_Stub_Target
(Loc
,
2407 Decls
, RCI_Locator
, Controlling_Parameter
),
2408 Subprogram_Id
=> Subp_Id
,
2409 Asynchronous
=> Asynchronous_Expr
,
2410 Is_Known_Asynchronous
=> Asynchronous
2411 and then not Dynamically_Asynchronous
,
2412 Is_Known_Non_Asynchronous
2414 and then not Dynamically_Asynchronous
,
2415 Is_Function
=> Nkind
(Spec_To_Use
) =
2416 N_Function_Specification
,
2417 Spec
=> Spec_To_Use
,
2418 Stub_Type
=> Stub_Type
,
2419 RACW_Type
=> RACW_Type
,
2422 RCI_Calling_Stubs_Table
.Set
2423 (Defining_Unit_Name
(Specification
(Vis_Decl
)),
2424 Defining_Unit_Name
(Spec_To_Use
));
2427 Make_Subprogram_Body
(Loc
,
2428 Specification
=> Subp_Spec
,
2429 Declarations
=> Decls
,
2430 Handled_Statement_Sequence
=>
2431 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
));
2432 end Build_Subprogram_Calling_Stubs
;
2434 -------------------------
2435 -- Build_Subprogram_Id --
2436 -------------------------
2438 function Build_Subprogram_Id
2440 E
: Entity_Id
) return Node_Id
2443 if Get_Subprogram_Ids
(E
).Str_Identifier
= No_String
then
2445 Current_Declaration
: Node_Id
;
2446 Current_Subp
: Entity_Id
;
2447 Current_Subp_Str
: String_Id
;
2448 Current_Subp_Number
: Int
:= First_RCI_Subprogram_Id
;
2451 -- Build_Subprogram_Id is called outside of the context of
2452 -- generating calling or receiving stubs. Hence we are processing
2453 -- an 'Access attribute_reference for an RCI subprogram, for the
2454 -- purpose of obtaining a RAS value.
2457 (Is_Remote_Call_Interface
(Scope
(E
))
2459 (Nkind
(Parent
(E
)) = N_Procedure_Specification
2461 Nkind
(Parent
(E
)) = N_Function_Specification
));
2463 Current_Declaration
:=
2464 First
(Visible_Declarations
2465 (Package_Specification_Of_Scope
(Scope
(E
))));
2466 while Present
(Current_Declaration
) loop
2467 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
2468 and then Comes_From_Source
(Current_Declaration
)
2470 Current_Subp
:= Defining_Unit_Name
(Specification
(
2471 Current_Declaration
));
2473 Assign_Subprogram_Identifier
2474 (Current_Subp
, Current_Subp_Number
, Current_Subp_Str
);
2476 Current_Subp_Number
:= Current_Subp_Number
+ 1;
2479 Next
(Current_Declaration
);
2484 case Get_PCS_Name
is
2485 when Name_PolyORB_DSA
=>
2486 return Make_String_Literal
(Loc
, Get_Subprogram_Id
(E
));
2488 return Make_Integer_Literal
(Loc
, Get_Subprogram_Id
(E
));
2490 end Build_Subprogram_Id
;
2492 ------------------------
2493 -- Copy_Specification --
2494 ------------------------
2496 function Copy_Specification
2499 Ctrl_Type
: Entity_Id
:= Empty
;
2500 New_Name
: Name_Id
:= No_Name
) return Node_Id
2502 Parameters
: List_Id
:= No_List
;
2504 Current_Parameter
: Node_Id
;
2505 Current_Identifier
: Entity_Id
;
2506 Current_Type
: Node_Id
;
2508 Name_For_New_Spec
: Name_Id
;
2510 New_Identifier
: Entity_Id
;
2512 -- Comments needed in body below ???
2515 if New_Name
= No_Name
then
2516 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
2517 or else Nkind
(Spec
) = N_Procedure_Specification
);
2519 Name_For_New_Spec
:= Chars
(Defining_Unit_Name
(Spec
));
2521 Name_For_New_Spec
:= New_Name
;
2524 if Present
(Parameter_Specifications
(Spec
)) then
2525 Parameters
:= New_List
;
2526 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2527 while Present
(Current_Parameter
) loop
2528 Current_Identifier
:= Defining_Identifier
(Current_Parameter
);
2529 Current_Type
:= Parameter_Type
(Current_Parameter
);
2531 if Nkind
(Current_Type
) = N_Access_Definition
then
2532 if Present
(Ctrl_Type
) then
2533 pragma Assert
(Is_Controlling_Formal
(Current_Identifier
));
2535 Make_Access_Definition
(Loc
,
2536 Subtype_Mark
=> New_Occurrence_Of
(Ctrl_Type
, Loc
),
2537 Null_Exclusion_Present
=>
2538 Null_Exclusion_Present
(Current_Type
));
2542 Make_Access_Definition
(Loc
,
2544 New_Copy_Tree
(Subtype_Mark
(Current_Type
)),
2545 Null_Exclusion_Present
=>
2546 Null_Exclusion_Present
(Current_Type
));
2550 if Present
(Ctrl_Type
)
2551 and then Is_Controlling_Formal
(Current_Identifier
)
2553 Current_Type
:= New_Occurrence_Of
(Ctrl_Type
, Loc
);
2555 Current_Type
:= New_Copy_Tree
(Current_Type
);
2559 New_Identifier
:= Make_Defining_Identifier
(Loc
,
2560 Chars
(Current_Identifier
));
2562 Append_To
(Parameters
,
2563 Make_Parameter_Specification
(Loc
,
2564 Defining_Identifier
=> New_Identifier
,
2565 Parameter_Type
=> Current_Type
,
2566 In_Present
=> In_Present
(Current_Parameter
),
2567 Out_Present
=> Out_Present
(Current_Parameter
),
2569 New_Copy_Tree
(Expression
(Current_Parameter
))));
2571 -- For a regular formal parameter (that needs to be marshalled
2572 -- in the context of remote calls), set the Etype now, because
2573 -- marshalling processing might need it.
2575 if Is_Entity_Name
(Current_Type
) then
2576 Set_Etype
(New_Identifier
, Entity
(Current_Type
));
2578 -- Current_Type is an access definition, special processing
2579 -- (not requiring etype) will occur for marshalling.
2585 Next
(Current_Parameter
);
2589 case Nkind
(Spec
) is
2591 when N_Function_Specification | N_Access_Function_Definition
=>
2593 Make_Function_Specification
(Loc
,
2594 Defining_Unit_Name
=>
2595 Make_Defining_Identifier
(Loc
,
2596 Chars
=> Name_For_New_Spec
),
2597 Parameter_Specifications
=> Parameters
,
2598 Result_Definition
=>
2599 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
2601 when N_Procedure_Specification | N_Access_Procedure_Definition
=>
2603 Make_Procedure_Specification
(Loc
,
2604 Defining_Unit_Name
=>
2605 Make_Defining_Identifier
(Loc
,
2606 Chars
=> Name_For_New_Spec
),
2607 Parameter_Specifications
=> Parameters
);
2610 raise Program_Error
;
2612 end Copy_Specification
;
2614 -----------------------------
2615 -- Corresponding_Stub_Type --
2616 -----------------------------
2618 function Corresponding_Stub_Type
(RACW_Type
: Entity_Id
) return Entity_Id
is
2619 Desig
: constant Entity_Id
:=
2620 Etype
(Designated_Type
(RACW_Type
));
2621 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
2623 return Stub_Elements
.Stub_Type
;
2624 end Corresponding_Stub_Type
;
2626 ---------------------------
2627 -- Could_Be_Asynchronous --
2628 ---------------------------
2630 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean is
2631 Current_Parameter
: Node_Id
;
2634 if Present
(Parameter_Specifications
(Spec
)) then
2635 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2636 while Present
(Current_Parameter
) loop
2637 if Out_Present
(Current_Parameter
) then
2641 Next
(Current_Parameter
);
2646 end Could_Be_Asynchronous
;
2648 ---------------------------
2649 -- Declare_Create_NVList --
2650 ---------------------------
2652 procedure Declare_Create_NVList
2660 Make_Object_Declaration
(Loc
,
2661 Defining_Identifier
=> NVList
,
2662 Aliased_Present
=> False,
2663 Object_Definition
=>
2664 New_Occurrence_Of
(RTE
(RE_NVList_Ref
), Loc
)));
2667 Make_Procedure_Call_Statement
(Loc
,
2669 New_Occurrence_Of
(RTE
(RE_NVList_Create
), Loc
),
2670 Parameter_Associations
=> New_List
(
2671 New_Occurrence_Of
(NVList
, Loc
))));
2672 end Declare_Create_NVList
;
2674 ---------------------------------------------
2675 -- Expand_All_Calls_Remote_Subprogram_Call --
2676 ---------------------------------------------
2678 procedure Expand_All_Calls_Remote_Subprogram_Call
(N
: Node_Id
) is
2679 Called_Subprogram
: constant Entity_Id
:= Entity
(Name
(N
));
2680 RCI_Package
: constant Entity_Id
:= Scope
(Called_Subprogram
);
2681 Loc
: constant Source_Ptr
:= Sloc
(N
);
2682 RCI_Locator
: Node_Id
;
2683 RCI_Cache
: Entity_Id
;
2684 Calling_Stubs
: Node_Id
;
2685 E_Calling_Stubs
: Entity_Id
;
2688 E_Calling_Stubs
:= RCI_Calling_Stubs_Table
.Get
(Called_Subprogram
);
2690 if E_Calling_Stubs
= Empty
then
2691 RCI_Cache
:= RCI_Locator_Table
.Get
(RCI_Package
);
2693 if RCI_Cache
= Empty
then
2696 (Loc
, Specification
(Unit_Declaration_Node
(RCI_Package
)));
2697 Prepend_To
(Current_Sem_Unit_Declarations
, RCI_Locator
);
2699 -- The RCI_Locator package is inserted at the top level in the
2700 -- current unit, and must appear in the proper scope, so that it
2701 -- is not prematurely removed by the GCC back-end.
2704 Scop
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
2707 if Ekind
(Scop
) = E_Package_Body
then
2708 Push_Scope
(Spec_Entity
(Scop
));
2710 elsif Ekind
(Scop
) = E_Subprogram_Body
then
2712 (Corresponding_Spec
(Unit_Declaration_Node
(Scop
)));
2718 Analyze
(RCI_Locator
);
2722 RCI_Cache
:= Defining_Unit_Name
(RCI_Locator
);
2725 RCI_Locator
:= Parent
(RCI_Cache
);
2728 Calling_Stubs
:= Build_Subprogram_Calling_Stubs
2729 (Vis_Decl
=> Parent
(Parent
(Called_Subprogram
)),
2731 Build_Subprogram_Id
(Loc
, Called_Subprogram
),
2732 Asynchronous
=> Nkind
(N
) = N_Procedure_Call_Statement
2734 Is_Asynchronous
(Called_Subprogram
),
2735 Locator
=> RCI_Cache
,
2736 New_Name
=> New_Internal_Name
('S'));
2737 Insert_After
(RCI_Locator
, Calling_Stubs
);
2738 Analyze
(Calling_Stubs
);
2739 E_Calling_Stubs
:= Defining_Unit_Name
(Specification
(Calling_Stubs
));
2742 Rewrite
(Name
(N
), New_Occurrence_Of
(E_Calling_Stubs
, Loc
));
2743 end Expand_All_Calls_Remote_Subprogram_Call
;
2745 ---------------------------------
2746 -- Expand_Calling_Stubs_Bodies --
2747 ---------------------------------
2749 procedure Expand_Calling_Stubs_Bodies
(Unit_Node
: Node_Id
) is
2750 Spec
: constant Node_Id
:= Specification
(Unit_Node
);
2751 Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
2753 Push_Scope
(Scope_Of_Spec
(Spec
));
2754 Add_Calling_Stubs_To_Declarations
2755 (Specification
(Unit_Node
), Decls
);
2757 end Expand_Calling_Stubs_Bodies
;
2759 -----------------------------------
2760 -- Expand_Receiving_Stubs_Bodies --
2761 -----------------------------------
2763 procedure Expand_Receiving_Stubs_Bodies
(Unit_Node
: Node_Id
) is
2766 Stubs_Decls
: List_Id
;
2767 Stubs_Stmts
: List_Id
;
2770 if Nkind
(Unit_Node
) = N_Package_Declaration
then
2771 Spec
:= Specification
(Unit_Node
);
2772 Decls
:= Private_Declarations
(Spec
);
2775 Decls
:= Visible_Declarations
(Spec
);
2778 Push_Scope
(Scope_Of_Spec
(Spec
));
2779 Specific_Add_Receiving_Stubs_To_Declarations
(Spec
, Decls
, Decls
);
2783 Package_Specification_Of_Scope
(Corresponding_Spec
(Unit_Node
));
2784 Decls
:= Declarations
(Unit_Node
);
2786 Push_Scope
(Scope_Of_Spec
(Unit_Node
));
2787 Stubs_Decls
:= New_List
;
2788 Stubs_Stmts
:= New_List
;
2789 Specific_Add_Receiving_Stubs_To_Declarations
2790 (Spec
, Stubs_Decls
, Stubs_Stmts
);
2792 Insert_List_Before
(First
(Decls
), Stubs_Decls
);
2795 HSS_Stmts
: constant List_Id
:=
2796 Statements
(Handled_Statement_Sequence
(Unit_Node
));
2797 First_HSS_Stmt
: constant Node_Id
:= First
(HSS_Stmts
);
2799 if No
(First_HSS_Stmt
) then
2800 Append_List_To
(HSS_Stmts
, Stubs_Stmts
);
2802 Insert_List_Before
(First_HSS_Stmt
, Stubs_Stmts
);
2808 end Expand_Receiving_Stubs_Bodies
;
2810 --------------------
2811 -- GARLIC_Support --
2812 --------------------
2814 package body GARLIC_Support
is
2816 -- Local subprograms
2818 procedure Add_RACW_Read_Attribute
2819 (RACW_Type
: Entity_Id
;
2820 Stub_Type
: Entity_Id
;
2821 Stub_Type_Access
: Entity_Id
;
2822 Body_Decls
: List_Id
);
2823 -- Add Read attribute for the RACW type. The declaration and attribute
2824 -- definition clauses are inserted right after the declaration of
2825 -- RACW_Type, while the subprogram body is appended to Body_Decls.
2827 procedure Add_RACW_Write_Attribute
2828 (RACW_Type
: Entity_Id
;
2829 Stub_Type
: Entity_Id
;
2830 Stub_Type_Access
: Entity_Id
;
2831 RPC_Receiver
: Node_Id
;
2832 Body_Decls
: List_Id
);
2833 -- Same as above for the Write attribute
2835 function Stream_Parameter
return Node_Id
;
2836 function Result
return Node_Id
;
2837 function Object
return Node_Id
renames Result
;
2838 -- Functions to create occurrences of the formal parameter names of the
2839 -- 'Read and 'Write attributes.
2842 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2843 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2845 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
2846 -- Add a subprogram body for RAS Access TSS
2848 -------------------------------------
2849 -- Add_Obj_RPC_Receiver_Completion --
2850 -------------------------------------
2852 procedure Add_Obj_RPC_Receiver_Completion
2855 RPC_Receiver
: Entity_Id
;
2856 Stub_Elements
: Stub_Structure
) is
2858 -- The RPC receiver body should not be the completion of the
2859 -- declaration recorded in the stub structure, because then the
2860 -- occurrences of the formal parameters within the body should refer
2861 -- to the entities from the declaration, not from the completion, to
2862 -- which we do not have easy access. Instead, the RPC receiver body
2863 -- acts as its own declaration, and the RPC receiver declaration is
2864 -- completed by a renaming-as-body.
2867 Make_Subprogram_Renaming_Declaration
(Loc
,
2869 Copy_Specification
(Loc
,
2870 Specification
(Stub_Elements
.RPC_Receiver_Decl
)),
2871 Name
=> New_Occurrence_Of
(RPC_Receiver
, Loc
)));
2872 end Add_Obj_RPC_Receiver_Completion
;
2874 -----------------------
2875 -- Add_RACW_Features --
2876 -----------------------
2878 procedure Add_RACW_Features
2879 (RACW_Type
: Entity_Id
;
2880 Stub_Type
: Entity_Id
;
2881 Stub_Type_Access
: Entity_Id
;
2882 RPC_Receiver_Decl
: Node_Id
;
2883 Body_Decls
: List_Id
)
2885 RPC_Receiver
: Node_Id
;
2886 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
2889 Loc
:= Sloc
(RACW_Type
);
2893 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2894 -- of the corresponding distributed object type. We retrieve its
2895 -- address from the local proxy object.
2897 RPC_Receiver
:= Make_Selected_Component
(Loc
,
2899 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
), Object
),
2900 Selector_Name
=> Make_Identifier
(Loc
, Name_Receiver
));
2903 RPC_Receiver
:= Make_Attribute_Reference
(Loc
,
2904 Prefix
=> New_Occurrence_Of
(
2905 Defining_Unit_Name
(Specification
(RPC_Receiver_Decl
)), Loc
),
2906 Attribute_Name
=> Name_Address
);
2909 Add_RACW_Write_Attribute
(
2916 Add_RACW_Read_Attribute
(
2921 end Add_RACW_Features
;
2923 -----------------------------
2924 -- Add_RACW_Read_Attribute --
2925 -----------------------------
2927 procedure Add_RACW_Read_Attribute
2928 (RACW_Type
: Entity_Id
;
2929 Stub_Type
: Entity_Id
;
2930 Stub_Type_Access
: Entity_Id
;
2931 Body_Decls
: List_Id
)
2933 Proc_Decl
: Node_Id
;
2934 Attr_Decl
: Node_Id
;
2936 Body_Node
: Node_Id
;
2939 Statements
: List_Id
;
2940 Local_Statements
: List_Id
;
2941 Remote_Statements
: List_Id
;
2942 -- Various parts of the procedure
2944 Procedure_Name
: constant Name_Id
:=
2945 New_Internal_Name
('R');
2946 Source_Partition
: constant Entity_Id
:=
2947 Make_Defining_Identifier
2948 (Loc
, New_Internal_Name
('P'));
2949 Source_Receiver
: constant Entity_Id
:=
2950 Make_Defining_Identifier
2951 (Loc
, New_Internal_Name
('S'));
2952 Source_Address
: constant Entity_Id
:=
2953 Make_Defining_Identifier
2954 (Loc
, New_Internal_Name
('P'));
2955 Local_Stub
: constant Entity_Id
:=
2956 Make_Defining_Identifier
2957 (Loc
, New_Internal_Name
('L'));
2958 Stubbed_Result
: constant Entity_Id
:=
2959 Make_Defining_Identifier
2960 (Loc
, New_Internal_Name
('S'));
2961 Asynchronous_Flag
: constant Entity_Id
:=
2962 Asynchronous_Flags_Table
.Get
(RACW_Type
);
2963 pragma Assert
(Present
(Asynchronous_Flag
));
2965 -- Start of processing for Add_RACW_Read_Attribute
2968 -- Generate object declarations
2971 Make_Object_Declaration
(Loc
,
2972 Defining_Identifier
=> Source_Partition
,
2973 Object_Definition
=>
2974 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
)),
2976 Make_Object_Declaration
(Loc
,
2977 Defining_Identifier
=> Source_Receiver
,
2978 Object_Definition
=>
2979 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
2981 Make_Object_Declaration
(Loc
,
2982 Defining_Identifier
=> Source_Address
,
2983 Object_Definition
=>
2984 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
2986 Make_Object_Declaration
(Loc
,
2987 Defining_Identifier
=> Local_Stub
,
2988 Aliased_Present
=> True,
2989 Object_Definition
=> New_Occurrence_Of
(Stub_Type
, Loc
)),
2991 Make_Object_Declaration
(Loc
,
2992 Defining_Identifier
=> Stubbed_Result
,
2993 Object_Definition
=>
2994 New_Occurrence_Of
(Stub_Type_Access
, Loc
),
2996 Make_Attribute_Reference
(Loc
,
2998 New_Occurrence_Of
(Local_Stub
, Loc
),
3000 Name_Unchecked_Access
)));
3002 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3004 Statements
:= New_List
(
3005 Make_Attribute_Reference
(Loc
,
3007 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3008 Attribute_Name
=> Name_Read
,
3009 Expressions
=> New_List
(
3011 New_Occurrence_Of
(Source_Partition
, Loc
))),
3013 Make_Attribute_Reference
(Loc
,
3015 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3018 Expressions
=> New_List
(
3020 New_Occurrence_Of
(Source_Receiver
, Loc
))),
3022 Make_Attribute_Reference
(Loc
,
3024 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3027 Expressions
=> New_List
(
3029 New_Occurrence_Of
(Source_Address
, Loc
))));
3031 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3033 Set_Etype
(Stubbed_Result
, Stub_Type_Access
);
3035 -- If the Address is Null_Address, then return a null object
3037 Append_To
(Statements
,
3038 Make_Implicit_If_Statement
(RACW_Type
,
3041 Left_Opnd
=> New_Occurrence_Of
(Source_Address
, Loc
),
3042 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
3043 Then_Statements
=> New_List
(
3044 Make_Assignment_Statement
(Loc
,
3046 Expression
=> Make_Null
(Loc
)),
3047 Make_Simple_Return_Statement
(Loc
))));
3049 -- If the RACW denotes an object created on the current partition,
3050 -- Local_Statements will be executed. The real object will be used.
3052 Local_Statements
:= New_List
(
3053 Make_Assignment_Statement
(Loc
,
3056 Unchecked_Convert_To
(RACW_Type
,
3057 OK_Convert_To
(RTE
(RE_Address
),
3058 New_Occurrence_Of
(Source_Address
, Loc
)))));
3060 -- If the object is located on another partition, then a stub object
3061 -- will be created with all the information needed to rebuild the
3062 -- real object at the other end.
3064 Remote_Statements
:= New_List
(
3066 Make_Assignment_Statement
(Loc
,
3067 Name
=> Make_Selected_Component
(Loc
,
3068 Prefix
=> Stubbed_Result
,
3069 Selector_Name
=> Name_Origin
),
3071 New_Occurrence_Of
(Source_Partition
, Loc
)),
3073 Make_Assignment_Statement
(Loc
,
3074 Name
=> Make_Selected_Component
(Loc
,
3075 Prefix
=> Stubbed_Result
,
3076 Selector_Name
=> Name_Receiver
),
3078 New_Occurrence_Of
(Source_Receiver
, Loc
)),
3080 Make_Assignment_Statement
(Loc
,
3081 Name
=> Make_Selected_Component
(Loc
,
3082 Prefix
=> Stubbed_Result
,
3083 Selector_Name
=> Name_Addr
),
3085 New_Occurrence_Of
(Source_Address
, Loc
)));
3087 Append_To
(Remote_Statements
,
3088 Make_Assignment_Statement
(Loc
,
3089 Name
=> Make_Selected_Component
(Loc
,
3090 Prefix
=> Stubbed_Result
,
3091 Selector_Name
=> Name_Asynchronous
),
3093 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)));
3095 Append_List_To
(Remote_Statements
,
3096 Build_Get_Unique_RP_Call
(Loc
, Stubbed_Result
, Stub_Type
));
3097 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3098 -- set on the stub type if, and only if, the RACW type has a pragma
3099 -- Asynchronous. This is incorrect for RACWs that implement RAS
3100 -- types, because in that case the /designated subprogram/ (not the
3101 -- type) might be asynchronous, and that causes the stub to need to
3102 -- be asynchronous too. A solution is to transport a RAS as a struct
3103 -- containing a RACW and an asynchronous flag, and to properly alter
3104 -- the Asynchronous component in the stub type in the RAS's Input
3107 Append_To
(Remote_Statements
,
3108 Make_Assignment_Statement
(Loc
,
3110 Expression
=> Unchecked_Convert_To
(RACW_Type
,
3111 New_Occurrence_Of
(Stubbed_Result
, Loc
))));
3113 -- Distinguish between the local and remote cases, and execute the
3114 -- appropriate piece of code.
3116 Append_To
(Statements
,
3117 Make_Implicit_If_Statement
(RACW_Type
,
3121 Make_Function_Call
(Loc
,
3122 Name
=> New_Occurrence_Of
(
3123 RTE
(RE_Get_Local_Partition_Id
), Loc
)),
3124 Right_Opnd
=> New_Occurrence_Of
(Source_Partition
, Loc
)),
3125 Then_Statements
=> Local_Statements
,
3126 Else_Statements
=> Remote_Statements
));
3128 Build_Stream_Procedure
3129 (Loc
, RACW_Type
, Body_Node
,
3130 Make_Defining_Identifier
(Loc
, Procedure_Name
),
3131 Statements
, Outp
=> True);
3132 Set_Declarations
(Body_Node
, Decls
);
3134 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
3135 Copy_Specification
(Loc
, Specification
(Body_Node
)));
3138 Make_Attribute_Definition_Clause
(Loc
,
3139 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
3143 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
3145 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
3146 Insert_After
(Proc_Decl
, Attr_Decl
);
3147 Append_To
(Body_Decls
, Body_Node
);
3148 end Add_RACW_Read_Attribute
;
3150 ------------------------------
3151 -- Add_RACW_Write_Attribute --
3152 ------------------------------
3154 procedure Add_RACW_Write_Attribute
3155 (RACW_Type
: Entity_Id
;
3156 Stub_Type
: Entity_Id
;
3157 Stub_Type_Access
: Entity_Id
;
3158 RPC_Receiver
: Node_Id
;
3159 Body_Decls
: List_Id
)
3161 Body_Node
: Node_Id
;
3162 Proc_Decl
: Node_Id
;
3163 Attr_Decl
: Node_Id
;
3165 Statements
: List_Id
;
3166 Local_Statements
: List_Id
;
3167 Remote_Statements
: List_Id
;
3168 Null_Statements
: List_Id
;
3170 Procedure_Name
: constant Name_Id
:= New_Internal_Name
('R');
3173 -- Build the code fragment corresponding to the marshalling of a
3176 Local_Statements
:= New_List
(
3178 Pack_Entity_Into_Stream_Access
(Loc
,
3179 Stream
=> Stream_Parameter
,
3180 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
3182 Pack_Node_Into_Stream_Access
(Loc
,
3183 Stream
=> Stream_Parameter
,
3184 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
), RPC_Receiver
),
3185 Etyp
=> RTE
(RE_Unsigned_64
)),
3187 Pack_Node_Into_Stream_Access
(Loc
,
3188 Stream
=> Stream_Parameter
,
3189 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
),
3190 Make_Attribute_Reference
(Loc
,
3192 Make_Explicit_Dereference
(Loc
,
3194 Attribute_Name
=> Name_Address
)),
3195 Etyp
=> RTE
(RE_Unsigned_64
)));
3197 -- Build the code fragment corresponding to the marshalling of
3200 Remote_Statements
:= New_List
(
3202 Pack_Node_Into_Stream_Access
(Loc
,
3203 Stream
=> Stream_Parameter
,
3205 Make_Selected_Component
(Loc
,
3206 Prefix
=> Unchecked_Convert_To
(Stub_Type_Access
,
3209 Make_Identifier
(Loc
, Name_Origin
)),
3210 Etyp
=> RTE
(RE_Partition_ID
)),
3212 Pack_Node_Into_Stream_Access
(Loc
,
3213 Stream
=> Stream_Parameter
,
3215 Make_Selected_Component
(Loc
,
3216 Prefix
=> Unchecked_Convert_To
(Stub_Type_Access
,
3219 Make_Identifier
(Loc
, Name_Receiver
)),
3220 Etyp
=> RTE
(RE_Unsigned_64
)),
3222 Pack_Node_Into_Stream_Access
(Loc
,
3223 Stream
=> Stream_Parameter
,
3225 Make_Selected_Component
(Loc
,
3226 Prefix
=> Unchecked_Convert_To
(Stub_Type_Access
,
3229 Make_Identifier
(Loc
, Name_Addr
)),
3230 Etyp
=> RTE
(RE_Unsigned_64
)));
3232 -- Build code fragment corresponding to marshalling of a null object
3234 Null_Statements
:= New_List
(
3236 Pack_Entity_Into_Stream_Access
(Loc
,
3237 Stream
=> Stream_Parameter
,
3238 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
3240 Pack_Node_Into_Stream_Access
(Loc
,
3241 Stream
=> Stream_Parameter
,
3242 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
), RPC_Receiver
),
3243 Etyp
=> RTE
(RE_Unsigned_64
)),
3245 Pack_Node_Into_Stream_Access
(Loc
,
3246 Stream
=> Stream_Parameter
,
3247 Object
=> Make_Integer_Literal
(Loc
, Uint_0
),
3248 Etyp
=> RTE
(RE_Unsigned_64
)));
3250 Statements
:= New_List
(
3251 Make_Implicit_If_Statement
(RACW_Type
,
3254 Left_Opnd
=> Object
,
3255 Right_Opnd
=> Make_Null
(Loc
)),
3256 Then_Statements
=> Null_Statements
,
3257 Elsif_Parts
=> New_List
(
3258 Make_Elsif_Part
(Loc
,
3262 Make_Attribute_Reference
(Loc
,
3264 Attribute_Name
=> Name_Tag
),
3266 Make_Attribute_Reference
(Loc
,
3267 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
3268 Attribute_Name
=> Name_Tag
)),
3269 Then_Statements
=> Remote_Statements
)),
3270 Else_Statements
=> Local_Statements
));
3272 Build_Stream_Procedure
3273 (Loc
, RACW_Type
, Body_Node
,
3274 Make_Defining_Identifier
(Loc
, Procedure_Name
),
3275 Statements
, Outp
=> False);
3277 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
3278 Copy_Specification
(Loc
, Specification
(Body_Node
)));
3281 Make_Attribute_Definition_Clause
(Loc
,
3282 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
3283 Chars
=> Name_Write
,
3286 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
3288 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
3289 Insert_After
(Proc_Decl
, Attr_Decl
);
3290 Append_To
(Body_Decls
, Body_Node
);
3291 end Add_RACW_Write_Attribute
;
3293 ------------------------
3294 -- Add_RAS_Access_TSS --
3295 ------------------------
3297 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
3298 Loc
: constant Source_Ptr
:= Sloc
(N
);
3300 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
3301 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
3302 -- Ras_Type is the access to subprogram type while Fat_Type is the
3303 -- corresponding record type.
3305 RACW_Type
: constant Entity_Id
:=
3306 Underlying_RACW_Type
(Ras_Type
);
3307 Desig
: constant Entity_Id
:=
3308 Etype
(Designated_Type
(RACW_Type
));
3310 Stub_Elements
: constant Stub_Structure
:=
3311 Stubs_Table
.Get
(Desig
);
3312 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
3314 Proc
: constant Entity_Id
:=
3315 Make_Defining_Identifier
(Loc
,
3316 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
3318 Proc_Spec
: Node_Id
;
3320 -- Formal parameters
3322 Package_Name
: constant Entity_Id
:=
3323 Make_Defining_Identifier
(Loc
,
3327 Subp_Id
: constant Entity_Id
:=
3328 Make_Defining_Identifier
(Loc
,
3330 -- Target subprogram
3332 Asynch_P
: constant Entity_Id
:=
3333 Make_Defining_Identifier
(Loc
,
3334 Chars
=> Name_Asynchronous
);
3335 -- Is the procedure to which the 'Access applies asynchronous?
3337 All_Calls_Remote
: constant Entity_Id
:=
3338 Make_Defining_Identifier
(Loc
,
3339 Chars
=> Name_All_Calls_Remote
);
3340 -- True if an All_Calls_Remote pragma applies to the RCI unit
3341 -- that contains the subprogram.
3343 -- Common local variables
3345 Proc_Decls
: List_Id
;
3346 Proc_Statements
: List_Id
;
3348 Origin
: constant Entity_Id
:=
3349 Make_Defining_Identifier
(Loc
,
3350 Chars
=> New_Internal_Name
('P'));
3352 -- Additional local variables for the local case
3354 Proxy_Addr
: constant Entity_Id
:=
3355 Make_Defining_Identifier
(Loc
,
3356 Chars
=> New_Internal_Name
('P'));
3358 -- Additional local variables for the remote case
3360 Local_Stub
: constant Entity_Id
:=
3361 Make_Defining_Identifier
(Loc
,
3362 Chars
=> New_Internal_Name
('L'));
3364 Stub_Ptr
: constant Entity_Id
:=
3365 Make_Defining_Identifier
(Loc
,
3366 Chars
=> New_Internal_Name
('S'));
3369 (Field_Name
: Name_Id
;
3370 Value
: Node_Id
) return Node_Id
;
3371 -- Construct an assignment that sets the named component in the
3379 (Field_Name
: Name_Id
;
3380 Value
: Node_Id
) return Node_Id
3384 Make_Assignment_Statement
(Loc
,
3386 Make_Selected_Component
(Loc
,
3388 Selector_Name
=> Field_Name
),
3389 Expression
=> Value
);
3392 -- Start of processing for Add_RAS_Access_TSS
3395 Proc_Decls
:= New_List
(
3397 -- Common declarations
3399 Make_Object_Declaration
(Loc
,
3400 Defining_Identifier
=> Origin
,
3401 Constant_Present
=> True,
3402 Object_Definition
=>
3403 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3405 Make_Function_Call
(Loc
,
3407 New_Occurrence_Of
(RTE
(RE_Get_Active_Partition_Id
), Loc
),
3408 Parameter_Associations
=> New_List
(
3409 New_Occurrence_Of
(Package_Name
, Loc
)))),
3411 -- Declaration use only in the local case: proxy address
3413 Make_Object_Declaration
(Loc
,
3414 Defining_Identifier
=> Proxy_Addr
,
3415 Object_Definition
=>
3416 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3418 -- Declarations used only in the remote case: stub object and
3421 Make_Object_Declaration
(Loc
,
3422 Defining_Identifier
=> Local_Stub
,
3423 Aliased_Present
=> True,
3424 Object_Definition
=>
3425 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
3427 Make_Object_Declaration
(Loc
,
3428 Defining_Identifier
=>
3430 Object_Definition
=>
3431 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
3433 Make_Attribute_Reference
(Loc
,
3434 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
3435 Attribute_Name
=> Name_Unchecked_Access
)));
3437 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
3438 -- Build_Get_Unique_RP_Call needs this information
3440 -- Note: Here we assume that the Fat_Type is a record
3441 -- containing just a pointer to a proxy or stub object.
3443 Proc_Statements
:= New_List
(
3447 -- Get_RAS_Info (Pkg, Subp, PA);
3448 -- if Origin = Local_Partition_Id
3449 -- and then not All_Calls_Remote
3451 -- return Fat_Type!(PA);
3454 Make_Procedure_Call_Statement
(Loc
,
3456 New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
3457 Parameter_Associations
=> New_List
(
3458 New_Occurrence_Of
(Package_Name
, Loc
),
3459 New_Occurrence_Of
(Subp_Id
, Loc
),
3460 New_Occurrence_Of
(Proxy_Addr
, Loc
))),
3462 Make_Implicit_If_Statement
(N
,
3468 New_Occurrence_Of
(Origin
, Loc
),
3470 Make_Function_Call
(Loc
,
3472 RTE
(RE_Get_Local_Partition_Id
), Loc
))),
3475 New_Occurrence_Of
(All_Calls_Remote
, Loc
))),
3476 Then_Statements
=> New_List
(
3477 Make_Simple_Return_Statement
(Loc
,
3478 Unchecked_Convert_To
(Fat_Type
,
3479 OK_Convert_To
(RTE
(RE_Address
),
3480 New_Occurrence_Of
(Proxy_Addr
, Loc
)))))),
3482 Set_Field
(Name_Origin
,
3483 New_Occurrence_Of
(Origin
, Loc
)),
3485 Set_Field
(Name_Receiver
,
3486 Make_Function_Call
(Loc
,
3488 New_Occurrence_Of
(RTE
(RE_Get_RCI_Package_Receiver
), Loc
),
3489 Parameter_Associations
=> New_List
(
3490 New_Occurrence_Of
(Package_Name
, Loc
)))),
3492 Set_Field
(Name_Addr
, New_Occurrence_Of
(Proxy_Addr
, Loc
)),
3494 -- E.4.1(9) A remote call is asynchronous if it is a call to
3495 -- a procedure, or a call through a value of an access-to-procedure
3496 -- type, to which a pragma Asynchronous applies.
3498 -- Parameter Asynch_P is true when the procedure is asynchronous;
3499 -- Expression Asynch_T is true when the type is asynchronous.
3501 Set_Field
(Name_Asynchronous
,
3503 New_Occurrence_Of
(Asynch_P
, Loc
),
3504 New_Occurrence_Of
(Boolean_Literals
(
3505 Is_Asynchronous
(Ras_Type
)), Loc
))));
3507 Append_List_To
(Proc_Statements
,
3508 Build_Get_Unique_RP_Call
3509 (Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
3511 -- Return the newly created value
3513 Append_To
(Proc_Statements
,
3514 Make_Simple_Return_Statement
(Loc
,
3516 Unchecked_Convert_To
(Fat_Type
,
3517 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
3520 Make_Function_Specification
(Loc
,
3521 Defining_Unit_Name
=> Proc
,
3522 Parameter_Specifications
=> New_List
(
3523 Make_Parameter_Specification
(Loc
,
3524 Defining_Identifier
=> Package_Name
,
3526 New_Occurrence_Of
(Standard_String
, Loc
)),
3528 Make_Parameter_Specification
(Loc
,
3529 Defining_Identifier
=> Subp_Id
,
3531 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
)),
3533 Make_Parameter_Specification
(Loc
,
3534 Defining_Identifier
=> Asynch_P
,
3536 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3538 Make_Parameter_Specification
(Loc
,
3539 Defining_Identifier
=> All_Calls_Remote
,
3541 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
3543 Result_Definition
=>
3544 New_Occurrence_Of
(Fat_Type
, Loc
));
3546 -- Set the kind and return type of the function to prevent
3547 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3549 Set_Ekind
(Proc
, E_Function
);
3550 Set_Etype
(Proc
, Fat_Type
);
3553 Make_Subprogram_Body
(Loc
,
3554 Specification
=> Proc_Spec
,
3555 Declarations
=> Proc_Decls
,
3556 Handled_Statement_Sequence
=>
3557 Make_Handled_Sequence_Of_Statements
(Loc
,
3558 Statements
=> Proc_Statements
)));
3560 Set_TSS
(Fat_Type
, Proc
);
3561 end Add_RAS_Access_TSS
;
3563 -----------------------
3564 -- Add_RAST_Features --
3565 -----------------------
3567 procedure Add_RAST_Features
3568 (Vis_Decl
: Node_Id
;
3569 RAS_Type
: Entity_Id
)
3571 pragma Warnings
(Off
);
3572 pragma Unreferenced
(RAS_Type
);
3573 pragma Warnings
(On
);
3575 Add_RAS_Access_TSS
(Vis_Decl
);
3576 end Add_RAST_Features
;
3578 -----------------------------------------
3579 -- Add_Receiving_Stubs_To_Declarations --
3580 -----------------------------------------
3582 procedure Add_Receiving_Stubs_To_Declarations
3583 (Pkg_Spec
: Node_Id
;
3587 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
3589 Request_Parameter
: Node_Id
;
3591 Pkg_RPC_Receiver
: constant Entity_Id
:=
3592 Make_Defining_Identifier
(Loc
,
3593 New_Internal_Name
('H'));
3594 Pkg_RPC_Receiver_Statements
: List_Id
;
3595 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
3596 Pkg_RPC_Receiver_Body
: Node_Id
;
3597 -- A Pkg_RPC_Receiver is built to decode the request
3599 Lookup_RAS_Info
: constant Entity_Id
:=
3600 Make_Defining_Identifier
(Loc
,
3601 Chars
=> New_Internal_Name
('R'));
3602 -- A remote subprogram is created to allow peers to look up
3603 -- RAS information using subprogram ids.
3605 Subp_Id
: Entity_Id
;
3606 Subp_Index
: Entity_Id
;
3607 -- Subprogram_Id as read from the incoming stream
3609 Current_Declaration
: Node_Id
;
3610 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
3611 Current_Stubs
: Node_Id
;
3613 Subp_Info_Array
: constant Entity_Id
:=
3614 Make_Defining_Identifier
(Loc
,
3615 Chars
=> New_Internal_Name
('I'));
3617 Subp_Info_List
: constant List_Id
:= New_List
;
3619 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
3621 All_Calls_Remote_E
: Entity_Id
;
3622 Proxy_Object_Addr
: Entity_Id
;
3624 procedure Append_Stubs_To
3625 (RPC_Receiver_Cases
: List_Id
;
3627 Subprogram_Number
: Int
);
3628 -- Add one case to the specified RPC receiver case list
3629 -- associating Subprogram_Number with the subprogram declared
3630 -- by Declaration, for which we have receiving stubs in Stubs.
3632 ---------------------
3633 -- Append_Stubs_To --
3634 ---------------------
3636 procedure Append_Stubs_To
3637 (RPC_Receiver_Cases
: List_Id
;
3639 Subprogram_Number
: Int
)
3642 Append_To
(RPC_Receiver_Cases
,
3643 Make_Case_Statement_Alternative
(Loc
,
3645 New_List
(Make_Integer_Literal
(Loc
, Subprogram_Number
)),
3648 Make_Procedure_Call_Statement
(Loc
,
3651 Defining_Entity
(Stubs
), Loc
),
3652 Parameter_Associations
=> New_List
(
3653 New_Occurrence_Of
(Request_Parameter
, Loc
))))));
3654 end Append_Stubs_To
;
3656 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3659 -- Building receiving stubs consist in several operations:
3661 -- - a package RPC receiver must be built. This subprogram
3662 -- will get a Subprogram_Id from the incoming stream
3663 -- and will dispatch the call to the right subprogram;
3665 -- - a receiving stub for each subprogram visible in the package
3666 -- spec. This stub will read all the parameters from the stream,
3667 -- and put the result as well as the exception occurrence in the
3670 -- - a dummy package with an empty spec and a body made of an
3671 -- elaboration part, whose job is to register the receiving
3672 -- part of this RCI package on the name server. This is done
3673 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3675 Build_RPC_Receiver_Body
(
3676 RPC_Receiver
=> Pkg_RPC_Receiver
,
3677 Request
=> Request_Parameter
,
3679 Subp_Index
=> Subp_Index
,
3680 Stmts
=> Pkg_RPC_Receiver_Statements
,
3681 Decl
=> Pkg_RPC_Receiver_Body
);
3682 pragma Assert
(Subp_Id
= Subp_Index
);
3684 -- A null subp_id denotes a call through a RAS, in which case the
3685 -- next Uint_64 element in the stream is the address of the local
3686 -- proxy object, from which we can retrieve the actual subprogram id.
3688 Append_To
(Pkg_RPC_Receiver_Statements
,
3689 Make_Implicit_If_Statement
(Pkg_Spec
,
3692 New_Occurrence_Of
(Subp_Id
, Loc
),
3693 Make_Integer_Literal
(Loc
, 0)),
3694 Then_Statements
=> New_List
(
3695 Make_Assignment_Statement
(Loc
,
3697 New_Occurrence_Of
(Subp_Id
, Loc
),
3699 Make_Selected_Component
(Loc
,
3701 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
3702 OK_Convert_To
(RTE
(RE_Address
),
3703 Make_Attribute_Reference
(Loc
,
3705 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3708 Expressions
=> New_List
(
3709 Make_Selected_Component
(Loc
,
3710 Prefix
=> Request_Parameter
,
3711 Selector_Name
=> Name_Params
))))),
3713 Make_Identifier
(Loc
, Name_Subp_Id
))))));
3715 -- Build a subprogram for RAS information lookups
3717 Current_Declaration
:=
3718 Make_Subprogram_Declaration
(Loc
,
3720 Make_Function_Specification
(Loc
,
3721 Defining_Unit_Name
=>
3723 Parameter_Specifications
=> New_List
(
3724 Make_Parameter_Specification
(Loc
,
3725 Defining_Identifier
=>
3726 Make_Defining_Identifier
(Loc
, Name_Subp_Id
),
3730 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))),
3731 Result_Definition
=>
3732 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)));
3733 Append_To
(Decls
, Current_Declaration
);
3734 Analyze
(Current_Declaration
);
3736 Current_Stubs
:= Build_Subprogram_Receiving_Stubs
3737 (Vis_Decl
=> Current_Declaration
,
3738 Asynchronous
=> False);
3739 Append_To
(Decls
, Current_Stubs
);
3740 Analyze
(Current_Stubs
);
3742 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3745 Subprogram_Number
=> 1);
3747 -- For each subprogram, the receiving stub will be built and a
3748 -- case statement will be made on the Subprogram_Id to dispatch
3749 -- to the right subprogram.
3751 All_Calls_Remote_E
:= Boolean_Literals
(
3752 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
3754 Overload_Counter_Table
.Reset
;
3756 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
3757 while Present
(Current_Declaration
) loop
3758 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
3759 and then Comes_From_Source
(Current_Declaration
)
3762 Loc
: constant Source_Ptr
:=
3763 Sloc
(Current_Declaration
);
3764 -- While specifically processing Current_Declaration, use
3765 -- its Sloc as the location of all generated nodes.
3767 Subp_Def
: constant Entity_Id
:=
3769 (Specification
(Current_Declaration
));
3771 Subp_Val
: String_Id
;
3774 -- Build receiving stub
3777 Build_Subprogram_Receiving_Stubs
3778 (Vis_Decl
=> Current_Declaration
,
3780 Nkind
(Specification
(Current_Declaration
)) =
3781 N_Procedure_Specification
3782 and then Is_Asynchronous
(Subp_Def
));
3784 Append_To
(Decls
, Current_Stubs
);
3785 Analyze
(Current_Stubs
);
3789 Add_RAS_Proxy_And_Analyze
(Decls
,
3791 Current_Declaration
,
3792 All_Calls_Remote_E
=>
3794 Proxy_Object_Addr
=>
3797 -- Compute distribution identifier
3799 Assign_Subprogram_Identifier
(
3801 Current_Subprogram_Number
,
3804 pragma Assert
(Current_Subprogram_Number
=
3805 Get_Subprogram_Id
(Subp_Def
));
3807 -- Add subprogram descriptor (RCI_Subp_Info) to the
3808 -- subprograms table for this receiver. The aggregate
3809 -- below must be kept consistent with the declaration
3810 -- of type RCI_Subp_Info in System.Partition_Interface.
3812 Append_To
(Subp_Info_List
,
3813 Make_Component_Association
(Loc
,
3814 Choices
=> New_List
(
3815 Make_Integer_Literal
(Loc
,
3816 Current_Subprogram_Number
)),
3818 Make_Aggregate
(Loc
,
3819 Component_Associations
=> New_List
(
3820 Make_Component_Association
(Loc
,
3821 Choices
=> New_List
(
3822 Make_Identifier
(Loc
, Name_Addr
)),
3825 Proxy_Object_Addr
, Loc
))))));
3827 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3830 Subprogram_Number
=>
3831 Current_Subprogram_Number
);
3834 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
3837 Next
(Current_Declaration
);
3840 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3841 -- rather than raising an exception since we do not want someone
3842 -- to crash a remote partition by sending invalid subprogram ids.
3843 -- This is consistent with the other parts of the case statement
3844 -- since even in presence of incorrect parameters in the stream,
3845 -- every exception will be caught and (if the subprogram is not an
3846 -- APC) put into the result stream and sent away.
3848 Append_To
(Pkg_RPC_Receiver_Cases
,
3849 Make_Case_Statement_Alternative
(Loc
,
3851 New_List
(Make_Others_Choice
(Loc
)),
3853 New_List
(Make_Null_Statement
(Loc
))));
3855 Append_To
(Pkg_RPC_Receiver_Statements
,
3856 Make_Case_Statement
(Loc
,
3858 New_Occurrence_Of
(Subp_Id
, Loc
),
3859 Alternatives
=> Pkg_RPC_Receiver_Cases
));
3862 Make_Object_Declaration
(Loc
,
3863 Defining_Identifier
=> Subp_Info_Array
,
3864 Constant_Present
=> True,
3865 Aliased_Present
=> True,
3866 Object_Definition
=>
3867 Make_Subtype_Indication
(Loc
,
3869 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
3871 Make_Index_Or_Discriminant_Constraint
(Loc
,
3874 Low_Bound
=> Make_Integer_Literal
(Loc
,
3875 First_RCI_Subprogram_Id
),
3877 Make_Integer_Literal
(Loc
,
3878 First_RCI_Subprogram_Id
3879 + List_Length
(Subp_Info_List
) - 1)))))));
3881 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
3882 -- has zero length, and the declaration is for an empty array, in
3883 -- which case no initialization aggregate must be generated.
3885 if Present
(First
(Subp_Info_List
)) then
3886 Set_Expression
(Last
(Decls
),
3887 Make_Aggregate
(Loc
,
3888 Component_Associations
=> Subp_Info_List
));
3890 -- No initialization provided: remove CONSTANT so that the
3891 -- declaration is not an incomplete deferred constant.
3894 Set_Constant_Present
(Last
(Decls
), False);
3897 Analyze
(Last
(Decls
));
3900 Subp_Info_Addr
: Node_Id
;
3901 -- Return statement for Lookup_RAS_Info: address of the subprogram
3902 -- information record for the requested subprogram id.
3905 if Present
(First
(Subp_Info_List
)) then
3907 Make_Selected_Component
(Loc
,
3909 Make_Indexed_Component
(Loc
,
3911 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3912 Expressions
=> New_List
(
3913 Convert_To
(Standard_Integer
,
3914 Make_Identifier
(Loc
, Name_Subp_Id
)))),
3916 Make_Identifier
(Loc
, Name_Addr
));
3918 -- Case of no visible subprogram: just raise Constraint_Error, we
3919 -- know for sure we got junk from a remote partition.
3923 Make_Raise_Constraint_Error
(Loc
,
3924 Reason
=> CE_Range_Check_Failed
);
3925 Set_Etype
(Subp_Info_Addr
, RTE
(RE_Unsigned_64
));
3929 Make_Subprogram_Body
(Loc
,
3931 Copy_Specification
(Loc
, Parent
(Lookup_RAS_Info
)),
3934 Handled_Statement_Sequence
=>
3935 Make_Handled_Sequence_Of_Statements
(Loc
,
3936 Statements
=> New_List
(
3937 Make_Simple_Return_Statement
(Loc
,
3939 OK_Convert_To
(RTE
(RE_Unsigned_64
),
3940 Subp_Info_Addr
))))));
3943 Analyze
(Last
(Decls
));
3945 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
3946 Analyze
(Last
(Decls
));
3948 Get_Library_Unit_Name_String
(Pkg_Spec
);
3952 Append_To
(Register_Pkg_Actuals
,
3953 Make_String_Literal
(Loc
,
3954 Strval
=> String_From_Name_Buffer
));
3958 Append_To
(Register_Pkg_Actuals
,
3959 Make_Attribute_Reference
(Loc
,
3961 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
3963 Name_Unrestricted_Access
));
3967 Append_To
(Register_Pkg_Actuals
,
3968 Make_Attribute_Reference
(Loc
,
3970 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
3976 Append_To
(Register_Pkg_Actuals
,
3977 Make_Attribute_Reference
(Loc
,
3979 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3985 Append_To
(Register_Pkg_Actuals
,
3986 Make_Attribute_Reference
(Loc
,
3988 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3992 -- Generate the call
3995 Make_Procedure_Call_Statement
(Loc
,
3997 New_Occurrence_Of
(RTE
(RE_Register_Receiving_Stub
), Loc
),
3998 Parameter_Associations
=> Register_Pkg_Actuals
));
3999 Analyze
(Last
(Stmts
));
4000 end Add_Receiving_Stubs_To_Declarations
;
4002 ---------------------------------
4003 -- Build_General_Calling_Stubs --
4004 ---------------------------------
4006 procedure Build_General_Calling_Stubs
4008 Statements
: List_Id
;
4009 Target_Partition
: Entity_Id
;
4010 Target_RPC_Receiver
: Node_Id
;
4011 Subprogram_Id
: Node_Id
;
4012 Asynchronous
: Node_Id
:= Empty
;
4013 Is_Known_Asynchronous
: Boolean := False;
4014 Is_Known_Non_Asynchronous
: Boolean := False;
4015 Is_Function
: Boolean;
4017 Stub_Type
: Entity_Id
:= Empty
;
4018 RACW_Type
: Entity_Id
:= Empty
;
4021 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
4023 Stream_Parameter
: Node_Id
;
4024 -- Name of the stream used to transmit parameters to the
4027 Result_Parameter
: Node_Id
;
4028 -- Name of the result parameter (in non-APC cases) which get the
4029 -- result of the remote subprogram.
4031 Exception_Return_Parameter
: Node_Id
;
4032 -- Name of the parameter which will hold the exception sent by the
4033 -- remote subprogram.
4035 Current_Parameter
: Node_Id
;
4036 -- Current parameter being handled
4038 Ordered_Parameters_List
: constant List_Id
:=
4039 Build_Ordered_Parameters_List
(Spec
);
4041 Asynchronous_Statements
: List_Id
:= No_List
;
4042 Non_Asynchronous_Statements
: List_Id
:= No_List
;
4043 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4045 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4046 -- List of statements for extra formal parameters. It will appear
4047 -- after the regular statements for writing out parameters.
4049 pragma Warnings
(Off
);
4050 pragma Unreferenced
(RACW_Type
);
4051 -- Used only for the PolyORB case
4052 pragma Warnings
(On
);
4055 -- The general form of a calling stub for a given subprogram is:
4057 -- procedure X (...) is P : constant Partition_ID :=
4058 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4059 -- System.RPC.Params_Stream_Type (0); begin
4060 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4061 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4062 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4063 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4065 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4067 -- There are some variations: Do_APC is called for an asynchronous
4068 -- procedure and the part after the call is completely ommitted as
4069 -- well as the declaration of Result. For a function call, 'Input is
4070 -- always used to read the result even if it is constrained.
4073 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
4076 Make_Object_Declaration
(Loc
,
4077 Defining_Identifier
=> Stream_Parameter
,
4078 Aliased_Present
=> True,
4079 Object_Definition
=>
4080 Make_Subtype_Indication
(Loc
,
4082 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
4084 Make_Index_Or_Discriminant_Constraint
(Loc
,
4086 New_List
(Make_Integer_Literal
(Loc
, 0))))));
4088 if not Is_Known_Asynchronous
then
4090 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4093 Make_Object_Declaration
(Loc
,
4094 Defining_Identifier
=> Result_Parameter
,
4095 Aliased_Present
=> True,
4096 Object_Definition
=>
4097 Make_Subtype_Indication
(Loc
,
4099 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
4101 Make_Index_Or_Discriminant_Constraint
(Loc
,
4103 New_List
(Make_Integer_Literal
(Loc
, 0))))));
4105 Exception_Return_Parameter
:=
4106 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
4109 Make_Object_Declaration
(Loc
,
4110 Defining_Identifier
=> Exception_Return_Parameter
,
4111 Object_Definition
=>
4112 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
4115 Result_Parameter
:= Empty
;
4116 Exception_Return_Parameter
:= Empty
;
4119 -- Put first the RPC receiver corresponding to the remote package
4121 Append_To
(Statements
,
4122 Make_Attribute_Reference
(Loc
,
4124 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
4125 Attribute_Name
=> Name_Write
,
4126 Expressions
=> New_List
(
4127 Make_Attribute_Reference
(Loc
,
4129 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4132 Target_RPC_Receiver
)));
4134 -- Then put the Subprogram_Id of the subprogram we want to call in
4137 Append_To
(Statements
,
4138 Make_Attribute_Reference
(Loc
,
4140 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4143 Expressions
=> New_List
(
4144 Make_Attribute_Reference
(Loc
,
4146 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4147 Attribute_Name
=> Name_Access
),
4150 Current_Parameter
:= First
(Ordered_Parameters_List
);
4151 while Present
(Current_Parameter
) loop
4153 Typ
: constant Node_Id
:=
4154 Parameter_Type
(Current_Parameter
);
4156 Constrained
: Boolean;
4158 Extra_Parameter
: Entity_Id
;
4161 if Is_RACW_Controlling_Formal
4162 (Current_Parameter
, Stub_Type
)
4164 -- In the case of a controlling formal argument, we marshall
4165 -- its addr field rather than the local stub.
4167 Append_To
(Statements
,
4168 Pack_Node_Into_Stream
(Loc
,
4169 Stream
=> Stream_Parameter
,
4171 Make_Selected_Component
(Loc
,
4173 Defining_Identifier
(Current_Parameter
),
4174 Selector_Name
=> Name_Addr
),
4175 Etyp
=> RTE
(RE_Unsigned_64
)));
4178 Value
:= New_Occurrence_Of
4179 (Defining_Identifier
(Current_Parameter
), Loc
);
4181 -- Access type parameters are transmitted as in out
4182 -- parameters. However, a dereference is needed so that
4183 -- we marshall the designated object.
4185 if Nkind
(Typ
) = N_Access_Definition
then
4186 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4187 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4189 Etyp
:= Etype
(Typ
);
4193 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
4195 -- Any parameter but unconstrained out parameters are
4196 -- transmitted to the peer.
4198 if In_Present
(Current_Parameter
)
4199 or else not Out_Present
(Current_Parameter
)
4200 or else not Constrained
4202 Append_To
(Statements
,
4203 Make_Attribute_Reference
(Loc
,
4205 New_Occurrence_Of
(Etyp
, Loc
),
4207 Output_From_Constrained
(Constrained
),
4208 Expressions
=> New_List
(
4209 Make_Attribute_Reference
(Loc
,
4211 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4212 Attribute_Name
=> Name_Access
),
4217 -- If the current parameter has a dynamic constrained status,
4218 -- then this status is transmitted as well.
4219 -- This should be done for accessibility as well ???
4221 if Nkind
(Typ
) /= N_Access_Definition
4222 and then Need_Extra_Constrained
(Current_Parameter
)
4224 -- In this block, we do not use the extra formal that has
4225 -- been created because it does not exist at the time of
4226 -- expansion when building calling stubs for remote access
4227 -- to subprogram types. We create an extra variable of this
4228 -- type and push it in the stream after the regular
4231 Extra_Parameter
:= Make_Defining_Identifier
4232 (Loc
, New_Internal_Name
('P'));
4235 Make_Object_Declaration
(Loc
,
4236 Defining_Identifier
=> Extra_Parameter
,
4237 Constant_Present
=> True,
4238 Object_Definition
=>
4239 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4241 Make_Attribute_Reference
(Loc
,
4244 Defining_Identifier
(Current_Parameter
), Loc
),
4245 Attribute_Name
=> Name_Constrained
)));
4247 Append_To
(Extra_Formal_Statements
,
4248 Make_Attribute_Reference
(Loc
,
4250 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4253 Expressions
=> New_List
(
4254 Make_Attribute_Reference
(Loc
,
4256 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4259 New_Occurrence_Of
(Extra_Parameter
, Loc
))));
4262 Next
(Current_Parameter
);
4266 -- Append the formal statements list to the statements
4268 Append_List_To
(Statements
, Extra_Formal_Statements
);
4270 if not Is_Known_Non_Asynchronous
then
4272 -- Build the call to System.RPC.Do_APC
4274 Asynchronous_Statements
:= New_List
(
4275 Make_Procedure_Call_Statement
(Loc
,
4277 New_Occurrence_Of
(RTE
(RE_Do_Apc
), Loc
),
4278 Parameter_Associations
=> New_List
(
4279 New_Occurrence_Of
(Target_Partition
, Loc
),
4280 Make_Attribute_Reference
(Loc
,
4282 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4286 Asynchronous_Statements
:= No_List
;
4289 if not Is_Known_Asynchronous
then
4291 -- Build the call to System.RPC.Do_RPC
4293 Non_Asynchronous_Statements
:= New_List
(
4294 Make_Procedure_Call_Statement
(Loc
,
4296 New_Occurrence_Of
(RTE
(RE_Do_Rpc
), Loc
),
4297 Parameter_Associations
=> New_List
(
4298 New_Occurrence_Of
(Target_Partition
, Loc
),
4300 Make_Attribute_Reference
(Loc
,
4302 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4306 Make_Attribute_Reference
(Loc
,
4308 New_Occurrence_Of
(Result_Parameter
, Loc
),
4312 -- Read the exception occurrence from the result stream and
4313 -- reraise it. It does no harm if this is a Null_Occurrence since
4314 -- this does nothing.
4316 Append_To
(Non_Asynchronous_Statements
,
4317 Make_Attribute_Reference
(Loc
,
4319 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4324 Expressions
=> New_List
(
4325 Make_Attribute_Reference
(Loc
,
4327 New_Occurrence_Of
(Result_Parameter
, Loc
),
4330 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
4332 Append_To
(Non_Asynchronous_Statements
,
4333 Make_Procedure_Call_Statement
(Loc
,
4335 New_Occurrence_Of
(RTE
(RE_Reraise_Occurrence
), Loc
),
4336 Parameter_Associations
=> New_List
(
4337 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
4341 -- If this is a function call, then read the value and return
4342 -- it. The return value is written/read using 'Output/'Input.
4344 Append_To
(Non_Asynchronous_Statements
,
4345 Make_Tag_Check
(Loc
,
4346 Make_Simple_Return_Statement
(Loc
,
4348 Make_Attribute_Reference
(Loc
,
4351 Etype
(Result_Definition
(Spec
)), Loc
),
4353 Attribute_Name
=> Name_Input
,
4355 Expressions
=> New_List
(
4356 Make_Attribute_Reference
(Loc
,
4358 New_Occurrence_Of
(Result_Parameter
, Loc
),
4359 Attribute_Name
=> Name_Access
))))));
4362 -- Loop around parameters and assign out (or in out)
4363 -- parameters. In the case of RACW, controlling arguments
4364 -- cannot possibly have changed since they are remote, so we do
4365 -- not read them from the stream.
4367 Current_Parameter
:= First
(Ordered_Parameters_List
);
4368 while Present
(Current_Parameter
) loop
4370 Typ
: constant Node_Id
:=
4371 Parameter_Type
(Current_Parameter
);
4378 (Defining_Identifier
(Current_Parameter
), Loc
);
4380 if Nkind
(Typ
) = N_Access_Definition
then
4381 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4382 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4384 Etyp
:= Etype
(Typ
);
4387 if (Out_Present
(Current_Parameter
)
4388 or else Nkind
(Typ
) = N_Access_Definition
)
4389 and then Etyp
/= Stub_Type
4391 Append_To
(Non_Asynchronous_Statements
,
4392 Make_Attribute_Reference
(Loc
,
4394 New_Occurrence_Of
(Etyp
, Loc
),
4396 Attribute_Name
=> Name_Read
,
4398 Expressions
=> New_List
(
4399 Make_Attribute_Reference
(Loc
,
4401 New_Occurrence_Of
(Result_Parameter
, Loc
),
4408 Next
(Current_Parameter
);
4413 if Is_Known_Asynchronous
then
4414 Append_List_To
(Statements
, Asynchronous_Statements
);
4416 elsif Is_Known_Non_Asynchronous
then
4417 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
4420 pragma Assert
(Present
(Asynchronous
));
4421 Prepend_To
(Asynchronous_Statements
,
4422 Make_Attribute_Reference
(Loc
,
4423 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4424 Attribute_Name
=> Name_Write
,
4425 Expressions
=> New_List
(
4426 Make_Attribute_Reference
(Loc
,
4428 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4429 Attribute_Name
=> Name_Access
),
4430 New_Occurrence_Of
(Standard_True
, Loc
))));
4432 Prepend_To
(Non_Asynchronous_Statements
,
4433 Make_Attribute_Reference
(Loc
,
4434 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4435 Attribute_Name
=> Name_Write
,
4436 Expressions
=> New_List
(
4437 Make_Attribute_Reference
(Loc
,
4439 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4440 Attribute_Name
=> Name_Access
),
4441 New_Occurrence_Of
(Standard_False
, Loc
))));
4443 Append_To
(Statements
,
4444 Make_Implicit_If_Statement
(Nod
,
4445 Condition
=> Asynchronous
,
4446 Then_Statements
=> Asynchronous_Statements
,
4447 Else_Statements
=> Non_Asynchronous_Statements
));
4449 end Build_General_Calling_Stubs
;
4451 -----------------------------
4452 -- Build_RPC_Receiver_Body --
4453 -----------------------------
4455 procedure Build_RPC_Receiver_Body
4456 (RPC_Receiver
: Entity_Id
;
4457 Request
: out Entity_Id
;
4458 Subp_Id
: out Entity_Id
;
4459 Subp_Index
: out Entity_Id
;
4460 Stmts
: out List_Id
;
4463 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
4465 RPC_Receiver_Spec
: Node_Id
;
4466 RPC_Receiver_Decls
: List_Id
;
4469 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
4471 RPC_Receiver_Spec
:=
4472 Build_RPC_Receiver_Specification
4473 (RPC_Receiver
=> RPC_Receiver
,
4474 Request_Parameter
=> Request
);
4476 Subp_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4477 Subp_Index
:= Subp_Id
;
4479 -- Subp_Id may not be a constant, because in the case of the RPC
4480 -- receiver for an RCI package, when a call is received from a RAS
4481 -- dereference, it will be assigned during subsequent processing.
4483 RPC_Receiver_Decls
:= New_List
(
4484 Make_Object_Declaration
(Loc
,
4485 Defining_Identifier
=> Subp_Id
,
4486 Object_Definition
=>
4487 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4489 Make_Attribute_Reference
(Loc
,
4491 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4492 Attribute_Name
=> Name_Input
,
4493 Expressions
=> New_List
(
4494 Make_Selected_Component
(Loc
,
4496 Selector_Name
=> Name_Params
)))));
4501 Make_Subprogram_Body
(Loc
,
4502 Specification
=> RPC_Receiver_Spec
,
4503 Declarations
=> RPC_Receiver_Decls
,
4504 Handled_Statement_Sequence
=>
4505 Make_Handled_Sequence_Of_Statements
(Loc
,
4506 Statements
=> Stmts
));
4507 end Build_RPC_Receiver_Body
;
4509 -----------------------
4510 -- Build_Stub_Target --
4511 -----------------------
4513 function Build_Stub_Target
4516 RCI_Locator
: Entity_Id
;
4517 Controlling_Parameter
: Entity_Id
) return RPC_Target
4519 Target_Info
: RPC_Target
(PCS_Kind
=> Name_GARLIC_DSA
);
4521 Target_Info
.Partition
:=
4522 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4523 if Present
(Controlling_Parameter
) then
4525 Make_Object_Declaration
(Loc
,
4526 Defining_Identifier
=> Target_Info
.Partition
,
4527 Constant_Present
=> True,
4528 Object_Definition
=>
4529 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4532 Make_Selected_Component
(Loc
,
4533 Prefix
=> Controlling_Parameter
,
4534 Selector_Name
=> Name_Origin
)));
4536 Target_Info
.RPC_Receiver
:=
4537 Make_Selected_Component
(Loc
,
4538 Prefix
=> Controlling_Parameter
,
4539 Selector_Name
=> Name_Receiver
);
4543 Make_Object_Declaration
(Loc
,
4544 Defining_Identifier
=> Target_Info
.Partition
,
4545 Constant_Present
=> True,
4546 Object_Definition
=>
4547 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4550 Make_Function_Call
(Loc
,
4551 Name
=> Make_Selected_Component
(Loc
,
4553 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4555 Make_Identifier
(Loc
,
4556 Name_Get_Active_Partition_ID
)))));
4558 Target_Info
.RPC_Receiver
:=
4559 Make_Selected_Component
(Loc
,
4561 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4563 Make_Identifier
(Loc
, Name_Get_RCI_Package_Receiver
));
4566 end Build_Stub_Target
;
4568 ---------------------
4569 -- Build_Stub_Type --
4570 ---------------------
4572 procedure Build_Stub_Type
4573 (RACW_Type
: Entity_Id
;
4574 Stub_Type
: Entity_Id
;
4575 Stub_Type_Decl
: out Node_Id
;
4576 RPC_Receiver_Decl
: out Node_Id
)
4578 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
4579 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
4583 Make_Full_Type_Declaration
(Loc
,
4584 Defining_Identifier
=> Stub_Type
,
4586 Make_Record_Definition
(Loc
,
4587 Tagged_Present
=> True,
4588 Limited_Present
=> True,
4590 Make_Component_List
(Loc
,
4591 Component_Items
=> New_List
(
4593 Make_Component_Declaration
(Loc
,
4594 Defining_Identifier
=>
4595 Make_Defining_Identifier
(Loc
, Name_Origin
),
4596 Component_Definition
=>
4597 Make_Component_Definition
(Loc
,
4598 Aliased_Present
=> False,
4599 Subtype_Indication
=>
4601 RTE
(RE_Partition_ID
), Loc
))),
4603 Make_Component_Declaration
(Loc
,
4604 Defining_Identifier
=>
4605 Make_Defining_Identifier
(Loc
, Name_Receiver
),
4606 Component_Definition
=>
4607 Make_Component_Definition
(Loc
,
4608 Aliased_Present
=> False,
4609 Subtype_Indication
=>
4610 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4612 Make_Component_Declaration
(Loc
,
4613 Defining_Identifier
=>
4614 Make_Defining_Identifier
(Loc
, Name_Addr
),
4615 Component_Definition
=>
4616 Make_Component_Definition
(Loc
,
4617 Aliased_Present
=> False,
4618 Subtype_Indication
=>
4619 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4621 Make_Component_Declaration
(Loc
,
4622 Defining_Identifier
=>
4623 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
4624 Component_Definition
=>
4625 Make_Component_Definition
(Loc
,
4626 Aliased_Present
=> False,
4627 Subtype_Indication
=>
4629 Standard_Boolean
, Loc
)))))));
4632 RPC_Receiver_Decl
:= Empty
;
4635 RPC_Receiver_Request
: constant Entity_Id
:=
4636 Make_Defining_Identifier
(Loc
, Name_R
);
4638 RPC_Receiver_Decl
:=
4639 Make_Subprogram_Declaration
(Loc
,
4640 Build_RPC_Receiver_Specification
(
4641 RPC_Receiver
=> Make_Defining_Identifier
(Loc
,
4642 New_Internal_Name
('R')),
4643 Request_Parameter
=> RPC_Receiver_Request
));
4646 end Build_Stub_Type
;
4648 --------------------------------------
4649 -- Build_Subprogram_Receiving_Stubs --
4650 --------------------------------------
4652 function Build_Subprogram_Receiving_Stubs
4653 (Vis_Decl
: Node_Id
;
4654 Asynchronous
: Boolean;
4655 Dynamically_Asynchronous
: Boolean := False;
4656 Stub_Type
: Entity_Id
:= Empty
;
4657 RACW_Type
: Entity_Id
:= Empty
;
4658 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
4660 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
4662 Request_Parameter
: constant Entity_Id
:=
4663 Make_Defining_Identifier
(Loc
,
4664 New_Internal_Name
('R'));
4665 -- Formal parameter for receiving stubs: a descriptor for an incoming
4668 Decls
: constant List_Id
:= New_List
;
4669 -- All the parameters will get declared before calling the real
4670 -- subprograms. Also the out parameters will be declared.
4672 Statements
: constant List_Id
:= New_List
;
4674 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4675 -- Statements concerning extra formal parameters
4677 After_Statements
: constant List_Id
:= New_List
;
4678 -- Statements to be executed after the subprogram call
4680 Inner_Decls
: List_Id
:= No_List
;
4681 -- In case of a function, the inner declarations are needed since
4682 -- the result may be unconstrained.
4684 Excep_Handlers
: List_Id
:= No_List
;
4685 Excep_Choice
: Entity_Id
;
4686 Excep_Code
: List_Id
;
4688 Parameter_List
: constant List_Id
:= New_List
;
4689 -- List of parameters to be passed to the subprogram
4691 Current_Parameter
: Node_Id
;
4693 Ordered_Parameters_List
: constant List_Id
:=
4694 Build_Ordered_Parameters_List
4695 (Specification
(Vis_Decl
));
4697 Subp_Spec
: Node_Id
;
4698 -- Subprogram specification
4700 Called_Subprogram
: Node_Id
;
4701 -- The subprogram to call
4703 Null_Raise_Statement
: Node_Id
;
4705 Dynamic_Async
: Entity_Id
;
4708 if Present
(RACW_Type
) then
4709 Called_Subprogram
:= New_Occurrence_Of
(Parent_Primitive
, Loc
);
4711 Called_Subprogram
:=
4713 (Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
4716 if Dynamically_Asynchronous
then
4718 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
4720 Dynamic_Async
:= Empty
;
4723 if not Asynchronous
or Dynamically_Asynchronous
then
4725 -- The first statement after the subprogram call is a statement to
4726 -- write a Null_Occurrence into the result stream.
4728 Null_Raise_Statement
:=
4729 Make_Attribute_Reference
(Loc
,
4731 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4732 Attribute_Name
=> Name_Write
,
4733 Expressions
=> New_List
(
4734 Make_Selected_Component
(Loc
,
4735 Prefix
=> Request_Parameter
,
4736 Selector_Name
=> Name_Result
),
4737 New_Occurrence_Of
(RTE
(RE_Null_Occurrence
), Loc
)));
4739 if Dynamically_Asynchronous
then
4740 Null_Raise_Statement
:=
4741 Make_Implicit_If_Statement
(Vis_Decl
,
4743 Make_Op_Not
(Loc
, New_Occurrence_Of
(Dynamic_Async
, Loc
)),
4744 Then_Statements
=> New_List
(Null_Raise_Statement
));
4747 Append_To
(After_Statements
, Null_Raise_Statement
);
4750 -- Loop through every parameter and get its value from the stream. If
4751 -- the parameter is unconstrained, then the parameter is read using
4752 -- 'Input at the point of declaration.
4754 Current_Parameter
:= First
(Ordered_Parameters_List
);
4755 while Present
(Current_Parameter
) loop
4758 Constrained
: Boolean;
4760 Need_Extra_Constrained
: Boolean;
4761 -- True when an Extra_Constrained actual is required
4763 Object
: constant Entity_Id
:=
4764 Make_Defining_Identifier
(Loc
,
4765 New_Internal_Name
('P'));
4767 Expr
: Node_Id
:= Empty
;
4769 Is_Controlling_Formal
: constant Boolean :=
4770 Is_RACW_Controlling_Formal
4771 (Current_Parameter
, Stub_Type
);
4774 if Is_Controlling_Formal
then
4776 -- We have a controlling formal parameter. Read its address
4777 -- rather than a real object. The address is in Unsigned_64
4780 Etyp
:= RTE
(RE_Unsigned_64
);
4782 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
4786 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
4788 if In_Present
(Current_Parameter
)
4789 or else not Out_Present
(Current_Parameter
)
4790 or else not Constrained
4791 or else Is_Controlling_Formal
4793 -- If an input parameter is constrained, then the read of
4794 -- the parameter is deferred until the beginning of the
4795 -- subprogram body. If it is unconstrained, then an
4796 -- expression is built for the object declaration and the
4797 -- variable is set using 'Input instead of 'Read. Note that
4798 -- this deferral does not change the order in which the
4799 -- actuals are read because Build_Ordered_Parameter_List
4800 -- puts them unconstrained first.
4803 Append_To
(Statements
,
4804 Make_Attribute_Reference
(Loc
,
4805 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4806 Attribute_Name
=> Name_Read
,
4807 Expressions
=> New_List
(
4808 Make_Selected_Component
(Loc
,
4809 Prefix
=> Request_Parameter
,
4810 Selector_Name
=> Name_Params
),
4811 New_Occurrence_Of
(Object
, Loc
))));
4815 -- Build and append Input_With_Tag_Check function
4818 Input_With_Tag_Check
(Loc
,
4820 Stream
=> Make_Selected_Component
(Loc
,
4821 Prefix
=> Request_Parameter
,
4822 Selector_Name
=> Name_Params
)));
4824 -- Prepare function call expression
4826 Expr
:= Make_Function_Call
(Loc
,
4827 New_Occurrence_Of
(Defining_Unit_Name
4828 (Specification
(Last
(Decls
))), Loc
));
4832 Need_Extra_Constrained
:=
4833 Nkind
(Parameter_Type
(Current_Parameter
)) /=
4836 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
4838 Present
(Extra_Constrained
4839 (Defining_Identifier
(Current_Parameter
)));
4841 -- We may not associate an extra constrained actual to a
4842 -- constant object, so if one is needed, declare the actual
4843 -- as a variable even if it won't be modified.
4845 Build_Actual_Object_Declaration
4848 Variable
=> Need_Extra_Constrained
4849 or else Out_Present
(Current_Parameter
),
4853 -- An out parameter may be written back using a 'Write
4854 -- attribute instead of a 'Output because it has been
4855 -- constrained by the parameter given to the caller. Note that
4856 -- out controlling arguments in the case of a RACW are not put
4857 -- back in the stream because the pointer on them has not
4860 if Out_Present
(Current_Parameter
)
4862 Etype
(Parameter_Type
(Current_Parameter
)) /= Stub_Type
4864 Append_To
(After_Statements
,
4865 Make_Attribute_Reference
(Loc
,
4866 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4867 Attribute_Name
=> Name_Write
,
4868 Expressions
=> New_List
(
4869 Make_Selected_Component
(Loc
,
4870 Prefix
=> Request_Parameter
,
4871 Selector_Name
=> Name_Result
),
4872 New_Occurrence_Of
(Object
, Loc
))));
4875 -- For RACW controlling formals, the Etyp of Object is always
4876 -- an RACW, even if the parameter is not of an anonymous access
4877 -- type. In such case, we need to dereference it at call time.
4879 if Is_Controlling_Formal
then
4880 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
4883 Append_To
(Parameter_List
,
4884 Make_Parameter_Association
(Loc
,
4887 Defining_Identifier
(Current_Parameter
), Loc
),
4888 Explicit_Actual_Parameter
=>
4889 Make_Explicit_Dereference
(Loc
,
4890 Unchecked_Convert_To
(RACW_Type
,
4891 OK_Convert_To
(RTE
(RE_Address
),
4892 New_Occurrence_Of
(Object
, Loc
))))));
4895 Append_To
(Parameter_List
,
4896 Make_Parameter_Association
(Loc
,
4899 Defining_Identifier
(Current_Parameter
), Loc
),
4900 Explicit_Actual_Parameter
=>
4901 Unchecked_Convert_To
(RACW_Type
,
4902 OK_Convert_To
(RTE
(RE_Address
),
4903 New_Occurrence_Of
(Object
, Loc
)))));
4907 Append_To
(Parameter_List
,
4908 Make_Parameter_Association
(Loc
,
4911 Defining_Identifier
(Current_Parameter
), Loc
),
4912 Explicit_Actual_Parameter
=>
4913 New_Occurrence_Of
(Object
, Loc
)));
4916 -- If the current parameter needs an extra formal, then read it
4917 -- from the stream and set the corresponding semantic field in
4918 -- the variable. If the kind of the parameter identifier is
4919 -- E_Void, then this is a compiler generated parameter that
4920 -- doesn't need an extra constrained status.
4922 -- The case of Extra_Accessibility should also be handled ???
4924 if Need_Extra_Constrained
then
4926 Extra_Parameter
: constant Entity_Id
:=
4928 (Defining_Identifier
4929 (Current_Parameter
));
4931 Formal_Entity
: constant Entity_Id
:=
4932 Make_Defining_Identifier
4933 (Loc
, Chars
(Extra_Parameter
));
4935 Formal_Type
: constant Entity_Id
:=
4936 Etype
(Extra_Parameter
);
4940 Make_Object_Declaration
(Loc
,
4941 Defining_Identifier
=> Formal_Entity
,
4942 Object_Definition
=>
4943 New_Occurrence_Of
(Formal_Type
, Loc
)));
4945 Append_To
(Extra_Formal_Statements
,
4946 Make_Attribute_Reference
(Loc
,
4947 Prefix
=> New_Occurrence_Of
(
4949 Attribute_Name
=> Name_Read
,
4950 Expressions
=> New_List
(
4951 Make_Selected_Component
(Loc
,
4952 Prefix
=> Request_Parameter
,
4953 Selector_Name
=> Name_Params
),
4954 New_Occurrence_Of
(Formal_Entity
, Loc
))));
4956 -- Note: the call to Set_Extra_Constrained below relies
4957 -- on the fact that Object's Ekind has been set by
4958 -- Build_Actual_Object_Declaration.
4960 Set_Extra_Constrained
(Object
, Formal_Entity
);
4965 Next
(Current_Parameter
);
4968 -- Append the formal statements list at the end of regular statements
4970 Append_List_To
(Statements
, Extra_Formal_Statements
);
4972 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
4974 -- The remote subprogram is a function. We build an inner block to
4975 -- be able to hold a potentially unconstrained result in a
4979 Etyp
: constant Entity_Id
:=
4980 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
4981 Result
: constant Node_Id
:=
4982 Make_Defining_Identifier
(Loc
,
4983 New_Internal_Name
('R'));
4985 Inner_Decls
:= New_List
(
4986 Make_Object_Declaration
(Loc
,
4987 Defining_Identifier
=> Result
,
4988 Constant_Present
=> True,
4989 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
4991 Make_Function_Call
(Loc
,
4992 Name
=> Called_Subprogram
,
4993 Parameter_Associations
=> Parameter_List
)));
4995 if Is_Class_Wide_Type
(Etyp
) then
4997 -- For a remote call to a function with a class-wide type,
4998 -- check that the returned value satisfies the requirements
5001 Append_To
(Inner_Decls
,
5002 Make_Transportable_Check
(Loc
,
5003 New_Occurrence_Of
(Result
, Loc
)));
5007 Append_To
(After_Statements
,
5008 Make_Attribute_Reference
(Loc
,
5009 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5010 Attribute_Name
=> Name_Output
,
5011 Expressions
=> New_List
(
5012 Make_Selected_Component
(Loc
,
5013 Prefix
=> Request_Parameter
,
5014 Selector_Name
=> Name_Result
),
5015 New_Occurrence_Of
(Result
, Loc
))));
5018 Append_To
(Statements
,
5019 Make_Block_Statement
(Loc
,
5020 Declarations
=> Inner_Decls
,
5021 Handled_Statement_Sequence
=>
5022 Make_Handled_Sequence_Of_Statements
(Loc
,
5023 Statements
=> After_Statements
)));
5026 -- The remote subprogram is a procedure. We do not need any inner
5027 -- block in this case.
5029 if Dynamically_Asynchronous
then
5031 Make_Object_Declaration
(Loc
,
5032 Defining_Identifier
=> Dynamic_Async
,
5033 Object_Definition
=>
5034 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
5036 Append_To
(Statements
,
5037 Make_Attribute_Reference
(Loc
,
5038 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
5039 Attribute_Name
=> Name_Read
,
5040 Expressions
=> New_List
(
5041 Make_Selected_Component
(Loc
,
5042 Prefix
=> Request_Parameter
,
5043 Selector_Name
=> Name_Params
),
5044 New_Occurrence_Of
(Dynamic_Async
, Loc
))));
5047 Append_To
(Statements
,
5048 Make_Procedure_Call_Statement
(Loc
,
5049 Name
=> Called_Subprogram
,
5050 Parameter_Associations
=> Parameter_List
));
5052 Append_List_To
(Statements
, After_Statements
);
5055 if Asynchronous
and then not Dynamically_Asynchronous
then
5057 -- For an asynchronous procedure, add a null exception handler
5059 Excep_Handlers
:= New_List
(
5060 Make_Implicit_Exception_Handler
(Loc
,
5061 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5062 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
5065 -- In the other cases, if an exception is raised, then the
5066 -- exception occurrence is copied into the output stream and
5067 -- no other output parameter is written.
5070 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
5072 Excep_Code
:= New_List
(
5073 Make_Attribute_Reference
(Loc
,
5075 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
5076 Attribute_Name
=> Name_Write
,
5077 Expressions
=> New_List
(
5078 Make_Selected_Component
(Loc
,
5079 Prefix
=> Request_Parameter
,
5080 Selector_Name
=> Name_Result
),
5081 New_Occurrence_Of
(Excep_Choice
, Loc
))));
5083 if Dynamically_Asynchronous
then
5084 Excep_Code
:= New_List
(
5085 Make_Implicit_If_Statement
(Vis_Decl
,
5086 Condition
=> Make_Op_Not
(Loc
,
5087 New_Occurrence_Of
(Dynamic_Async
, Loc
)),
5088 Then_Statements
=> Excep_Code
));
5091 Excep_Handlers
:= New_List
(
5092 Make_Implicit_Exception_Handler
(Loc
,
5093 Choice_Parameter
=> Excep_Choice
,
5094 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5095 Statements
=> Excep_Code
));
5100 Make_Procedure_Specification
(Loc
,
5101 Defining_Unit_Name
=>
5102 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
5104 Parameter_Specifications
=> New_List
(
5105 Make_Parameter_Specification
(Loc
,
5106 Defining_Identifier
=> Request_Parameter
,
5108 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
5111 Make_Subprogram_Body
(Loc
,
5112 Specification
=> Subp_Spec
,
5113 Declarations
=> Decls
,
5114 Handled_Statement_Sequence
=>
5115 Make_Handled_Sequence_Of_Statements
(Loc
,
5116 Statements
=> Statements
,
5117 Exception_Handlers
=> Excep_Handlers
));
5118 end Build_Subprogram_Receiving_Stubs
;
5124 function Result
return Node_Id
is
5126 return Make_Identifier
(Loc
, Name_V
);
5129 ----------------------
5130 -- Stream_Parameter --
5131 ----------------------
5133 function Stream_Parameter
return Node_Id
is
5135 return Make_Identifier
(Loc
, Name_S
);
5136 end Stream_Parameter
;
5140 -------------------------------
5141 -- Get_And_Reset_RACW_Bodies --
5142 -------------------------------
5144 function Get_And_Reset_RACW_Bodies
(RACW_Type
: Entity_Id
) return List_Id
is
5145 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
5146 Stub_Elements
: Stub_Structure
:= Stubs_Table
.Get
(Desig
);
5148 Body_Decls
: List_Id
;
5149 -- Returned list of declarations
5152 if Stub_Elements
= Empty_Stub_Structure
then
5154 -- Stub elements may be missing as a consequence of a previously
5160 Body_Decls
:= Stub_Elements
.Body_Decls
;
5161 Stub_Elements
.Body_Decls
:= No_List
;
5162 Stubs_Table
.Set
(Desig
, Stub_Elements
);
5164 end Get_And_Reset_RACW_Bodies
;
5166 -----------------------
5167 -- Get_Subprogram_Id --
5168 -----------------------
5170 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
is
5171 Result
: constant String_Id
:= Get_Subprogram_Ids
(Def
).Str_Identifier
;
5173 pragma Assert
(Result
/= No_String
);
5175 end Get_Subprogram_Id
;
5177 -----------------------
5178 -- Get_Subprogram_Id --
5179 -----------------------
5181 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
is
5183 return Get_Subprogram_Ids
(Def
).Int_Identifier
;
5184 end Get_Subprogram_Id
;
5186 ------------------------
5187 -- Get_Subprogram_Ids --
5188 ------------------------
5190 function Get_Subprogram_Ids
5191 (Def
: Entity_Id
) return Subprogram_Identifiers
5194 return Subprogram_Identifier_Table
.Get
(Def
);
5195 end Get_Subprogram_Ids
;
5201 function Hash
(F
: Entity_Id
) return Hash_Index
is
5203 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
5206 function Hash
(F
: Name_Id
) return Hash_Index
is
5208 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
5211 --------------------------
5212 -- Input_With_Tag_Check --
5213 --------------------------
5215 function Input_With_Tag_Check
5217 Var_Type
: Entity_Id
;
5218 Stream
: Node_Id
) return Node_Id
5222 Make_Subprogram_Body
(Loc
,
5223 Specification
=> Make_Function_Specification
(Loc
,
5224 Defining_Unit_Name
=>
5225 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S')),
5226 Result_Definition
=> New_Occurrence_Of
(Var_Type
, Loc
)),
5227 Declarations
=> No_List
,
5228 Handled_Statement_Sequence
=>
5229 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
5230 Make_Tag_Check
(Loc
,
5231 Make_Simple_Return_Statement
(Loc
,
5232 Make_Attribute_Reference
(Loc
,
5233 Prefix
=> New_Occurrence_Of
(Var_Type
, Loc
),
5234 Attribute_Name
=> Name_Input
,
5236 New_List
(Stream
)))))));
5237 end Input_With_Tag_Check
;
5239 --------------------------------
5240 -- Is_RACW_Controlling_Formal --
5241 --------------------------------
5243 function Is_RACW_Controlling_Formal
5244 (Parameter
: Node_Id
;
5245 Stub_Type
: Entity_Id
) return Boolean
5250 -- If the kind of the parameter is E_Void, then it is not a
5251 -- controlling formal (this can happen in the context of RAS).
5253 if Ekind
(Defining_Identifier
(Parameter
)) = E_Void
then
5257 -- If the parameter is not a controlling formal, then it cannot
5258 -- be possibly a RACW_Controlling_Formal.
5260 if not Is_Controlling_Formal
(Defining_Identifier
(Parameter
)) then
5264 Typ
:= Parameter_Type
(Parameter
);
5265 return (Nkind
(Typ
) = N_Access_Definition
5266 and then Etype
(Subtype_Mark
(Typ
)) = Stub_Type
)
5267 or else Etype
(Typ
) = Stub_Type
;
5268 end Is_RACW_Controlling_Formal
;
5270 ------------------------------
5271 -- Make_Transportable_Check --
5272 ------------------------------
5274 function Make_Transportable_Check
5276 Expr
: Node_Id
) return Node_Id
is
5279 Make_Raise_Program_Error
(Loc
,
5282 Build_Get_Transportable
(Loc
,
5283 Make_Selected_Component
(Loc
,
5285 Selector_Name
=> Make_Identifier
(Loc
, Name_uTag
)))),
5286 Reason
=> PE_Non_Transportable_Actual
);
5287 end Make_Transportable_Check
;
5289 -----------------------------
5290 -- Make_Selected_Component --
5291 -----------------------------
5293 function Make_Selected_Component
5296 Selector_Name
: Name_Id
) return Node_Id
5299 return Make_Selected_Component
(Loc
,
5300 Prefix
=> New_Occurrence_Of
(Prefix
, Loc
),
5301 Selector_Name
=> Make_Identifier
(Loc
, Selector_Name
));
5302 end Make_Selected_Component
;
5304 --------------------
5305 -- Make_Tag_Check --
5306 --------------------
5308 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
is
5309 Occ
: constant Entity_Id
:=
5310 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
5313 return Make_Block_Statement
(Loc
,
5314 Handled_Statement_Sequence
=>
5315 Make_Handled_Sequence_Of_Statements
(Loc
,
5316 Statements
=> New_List
(N
),
5318 Exception_Handlers
=> New_List
(
5319 Make_Implicit_Exception_Handler
(Loc
,
5320 Choice_Parameter
=> Occ
,
5322 Exception_Choices
=>
5323 New_List
(New_Occurrence_Of
(RTE
(RE_Tag_Error
), Loc
)),
5326 New_List
(Make_Procedure_Call_Statement
(Loc
,
5328 (RTE
(RE_Raise_Program_Error_Unknown_Tag
), Loc
),
5329 New_List
(New_Occurrence_Of
(Occ
, Loc
))))))));
5332 ----------------------------
5333 -- Need_Extra_Constrained --
5334 ----------------------------
5336 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean is
5337 Etyp
: constant Entity_Id
:= Etype
(Parameter_Type
(Parameter
));
5339 return Out_Present
(Parameter
)
5340 and then Has_Discriminants
(Etyp
)
5341 and then not Is_Constrained
(Etyp
)
5342 and then not Is_Indefinite_Subtype
(Etyp
);
5343 end Need_Extra_Constrained
;
5345 ------------------------------------
5346 -- Pack_Entity_Into_Stream_Access --
5347 ------------------------------------
5349 function Pack_Entity_Into_Stream_Access
5353 Etyp
: Entity_Id
:= Empty
) return Node_Id
5358 if Present
(Etyp
) then
5361 Typ
:= Etype
(Object
);
5365 Pack_Node_Into_Stream_Access
(Loc
,
5367 Object
=> New_Occurrence_Of
(Object
, Loc
),
5369 end Pack_Entity_Into_Stream_Access
;
5371 ---------------------------
5372 -- Pack_Node_Into_Stream --
5373 ---------------------------
5375 function Pack_Node_Into_Stream
5379 Etyp
: Entity_Id
) return Node_Id
5381 Write_Attribute
: Name_Id
:= Name_Write
;
5384 if not Is_Constrained
(Etyp
) then
5385 Write_Attribute
:= Name_Output
;
5389 Make_Attribute_Reference
(Loc
,
5390 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5391 Attribute_Name
=> Write_Attribute
,
5392 Expressions
=> New_List
(
5393 Make_Attribute_Reference
(Loc
,
5394 Prefix
=> New_Occurrence_Of
(Stream
, Loc
),
5395 Attribute_Name
=> Name_Access
),
5397 end Pack_Node_Into_Stream
;
5399 ----------------------------------
5400 -- Pack_Node_Into_Stream_Access --
5401 ----------------------------------
5403 function Pack_Node_Into_Stream_Access
5407 Etyp
: Entity_Id
) return Node_Id
5409 Write_Attribute
: Name_Id
:= Name_Write
;
5412 if not Is_Constrained
(Etyp
) then
5413 Write_Attribute
:= Name_Output
;
5417 Make_Attribute_Reference
(Loc
,
5418 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5419 Attribute_Name
=> Write_Attribute
,
5420 Expressions
=> New_List
(
5423 end Pack_Node_Into_Stream_Access
;
5425 ---------------------
5426 -- PolyORB_Support --
5427 ---------------------
5429 package body PolyORB_Support
is
5431 -- Local subprograms
5433 procedure Add_RACW_Read_Attribute
5434 (RACW_Type
: Entity_Id
;
5435 Stub_Type
: Entity_Id
;
5436 Stub_Type_Access
: Entity_Id
;
5437 Body_Decls
: List_Id
);
5438 -- Add Read attribute for the RACW type. The declaration and attribute
5439 -- definition clauses are inserted right after the declaration of
5440 -- RACW_Type, while the subprogram body is appended to Body_Decls.
5442 procedure Add_RACW_Write_Attribute
5443 (RACW_Type
: Entity_Id
;
5444 Stub_Type
: Entity_Id
;
5445 Stub_Type_Access
: Entity_Id
;
5446 Body_Decls
: List_Id
);
5447 -- Same as above for the Write attribute
5449 procedure Add_RACW_From_Any
5450 (RACW_Type
: Entity_Id
;
5451 Stub_Type
: Entity_Id
;
5452 Stub_Type_Access
: Entity_Id
;
5453 Body_Decls
: List_Id
);
5454 -- Add the From_Any TSS for this RACW type
5456 procedure Add_RACW_To_Any
5457 (Designated_Type
: Entity_Id
;
5458 RACW_Type
: Entity_Id
;
5459 Stub_Type
: Entity_Id
;
5460 Stub_Type_Access
: Entity_Id
;
5461 Body_Decls
: List_Id
);
5462 -- Add the To_Any TSS for this RACW type
5464 procedure Add_RACW_TypeCode
5465 (Designated_Type
: Entity_Id
;
5466 RACW_Type
: Entity_Id
;
5467 Body_Decls
: List_Id
);
5468 -- Add the TypeCode TSS for this RACW type
5470 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
);
5471 -- Add the From_Any TSS for this RAS type
5473 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
);
5474 -- Add the To_Any TSS for this RAS type
5476 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
);
5477 -- Add the TypeCode TSS for this RAS type
5479 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
5480 -- Add a subprogram body for RAS Access TSS
5482 -------------------------------------
5483 -- Add_Obj_RPC_Receiver_Completion --
5484 -------------------------------------
5486 procedure Add_Obj_RPC_Receiver_Completion
5489 RPC_Receiver
: Entity_Id
;
5490 Stub_Elements
: Stub_Structure
)
5492 Desig
: constant Entity_Id
:=
5493 Etype
(Designated_Type
(Stub_Elements
.RACW_Type
));
5496 Make_Procedure_Call_Statement
(Loc
,
5499 RTE
(RE_Register_Obj_Receiving_Stub
), Loc
),
5501 Parameter_Associations
=> New_List
(
5505 Make_String_Literal
(Loc
,
5506 Full_Qualified_Name
(Desig
)),
5510 Make_Attribute_Reference
(Loc
,
5513 Defining_Unit_Name
(Parent
(RPC_Receiver
)), Loc
),
5519 Make_Attribute_Reference
(Loc
,
5522 Defining_Identifier
(
5523 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5526 end Add_Obj_RPC_Receiver_Completion
;
5528 -----------------------
5529 -- Add_RACW_Features --
5530 -----------------------
5532 procedure Add_RACW_Features
5533 (RACW_Type
: Entity_Id
;
5535 Stub_Type
: Entity_Id
;
5536 Stub_Type_Access
: Entity_Id
;
5537 RPC_Receiver_Decl
: Node_Id
;
5538 Body_Decls
: List_Id
)
5540 pragma Warnings
(Off
);
5541 pragma Unreferenced
(RPC_Receiver_Decl
);
5542 pragma Warnings
(On
);
5546 (RACW_Type
=> RACW_Type
,
5547 Stub_Type
=> Stub_Type
,
5548 Stub_Type_Access
=> Stub_Type_Access
,
5549 Body_Decls
=> Body_Decls
);
5552 (Designated_Type
=> Desig
,
5553 RACW_Type
=> RACW_Type
,
5554 Stub_Type
=> Stub_Type
,
5555 Stub_Type_Access
=> Stub_Type_Access
,
5556 Body_Decls
=> Body_Decls
);
5558 -- In the PolyORB case, the RACW 'Read and 'Write attributes are
5559 -- implemented in terms of the From_Any and To_Any TSSs, so these
5560 -- TSSs must be expanded before 'Read and 'Write.
5562 Add_RACW_Write_Attribute
5563 (RACW_Type
=> RACW_Type
,
5564 Stub_Type
=> Stub_Type
,
5565 Stub_Type_Access
=> Stub_Type_Access
,
5566 Body_Decls
=> Body_Decls
);
5568 Add_RACW_Read_Attribute
5569 (RACW_Type
=> RACW_Type
,
5570 Stub_Type
=> Stub_Type
,
5571 Stub_Type_Access
=> Stub_Type_Access
,
5572 Body_Decls
=> Body_Decls
);
5575 (Designated_Type
=> Desig
,
5576 RACW_Type
=> RACW_Type
,
5577 Body_Decls
=> Body_Decls
);
5578 end Add_RACW_Features
;
5580 -----------------------
5581 -- Add_RACW_From_Any --
5582 -----------------------
5584 procedure Add_RACW_From_Any
5585 (RACW_Type
: Entity_Id
;
5586 Stub_Type
: Entity_Id
;
5587 Stub_Type_Access
: Entity_Id
;
5588 Body_Decls
: List_Id
)
5590 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5591 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5593 Fnam
: constant Entity_Id
:=
5594 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F'));
5596 Func_Spec
: Node_Id
;
5597 Func_Decl
: Node_Id
;
5598 Func_Body
: Node_Id
;
5601 Statements
: List_Id
;
5602 Stub_Statements
: List_Id
;
5603 Local_Statements
: List_Id
;
5604 -- Various parts of the subprogram
5606 Any_Parameter
: constant Entity_Id
:=
5607 Make_Defining_Identifier
(Loc
, Name_A
);
5608 Reference
: constant Entity_Id
:=
5609 Make_Defining_Identifier
5610 (Loc
, New_Internal_Name
('R'));
5611 Is_Local
: constant Entity_Id
:=
5612 Make_Defining_Identifier
5613 (Loc
, New_Internal_Name
('L'));
5614 Addr
: constant Entity_Id
:=
5615 Make_Defining_Identifier
5616 (Loc
, New_Internal_Name
('A'));
5617 Local_Stub
: constant Entity_Id
:=
5618 Make_Defining_Identifier
5619 (Loc
, New_Internal_Name
('L'));
5620 Stubbed_Result
: constant Entity_Id
:=
5621 Make_Defining_Identifier
5622 (Loc
, New_Internal_Name
('S'));
5624 Stub_Condition
: Node_Id
;
5625 -- An expression that determines whether we create a stub for the
5626 -- newly-unpacked RACW. Normally we create a stub only for remote
5627 -- objects, but in the case of an RACW used to implement a RAS, we
5628 -- also create a stub for local subprograms if a pragma
5629 -- All_Calls_Remote applies.
5631 Asynchronous_Flag
: constant Entity_Id
:=
5632 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5633 -- The flag object declared in Add_RACW_Asynchronous_Flag
5637 -- Object declarations
5640 Make_Object_Declaration
(Loc
,
5641 Defining_Identifier
=>
5643 Object_Definition
=>
5644 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5646 Make_Function_Call
(Loc
,
5648 New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
5649 Parameter_Associations
=> New_List
(
5650 New_Occurrence_Of
(Any_Parameter
, Loc
)))),
5652 Make_Object_Declaration
(Loc
,
5653 Defining_Identifier
=> Local_Stub
,
5654 Aliased_Present
=> True,
5655 Object_Definition
=> New_Occurrence_Of
(Stub_Type
, Loc
)),
5657 Make_Object_Declaration
(Loc
,
5658 Defining_Identifier
=> Stubbed_Result
,
5659 Object_Definition
=>
5660 New_Occurrence_Of
(Stub_Type_Access
, Loc
),
5662 Make_Attribute_Reference
(Loc
,
5664 New_Occurrence_Of
(Local_Stub
, Loc
),
5666 Name_Unchecked_Access
)),
5668 Make_Object_Declaration
(Loc
,
5669 Defining_Identifier
=> Is_Local
,
5670 Object_Definition
=>
5671 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
5673 Make_Object_Declaration
(Loc
,
5674 Defining_Identifier
=> Addr
,
5675 Object_Definition
=>
5676 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
5678 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
5680 Set_Etype
(Stubbed_Result
, Stub_Type_Access
);
5682 -- If the ref Is_Nil, return a null pointer
5684 Statements
:= New_List
(
5685 Make_Implicit_If_Statement
(RACW_Type
,
5687 Make_Function_Call
(Loc
,
5689 New_Occurrence_Of
(RTE
(RE_Is_Nil
), Loc
),
5690 Parameter_Associations
=> New_List
(
5691 New_Occurrence_Of
(Reference
, Loc
))),
5692 Then_Statements
=> New_List
(
5693 Make_Simple_Return_Statement
(Loc
,
5695 Make_Null
(Loc
)))));
5697 Append_To
(Statements
,
5698 Make_Procedure_Call_Statement
(Loc
,
5700 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
5701 Parameter_Associations
=> New_List
(
5702 New_Occurrence_Of
(Reference
, Loc
),
5703 New_Occurrence_Of
(Is_Local
, Loc
),
5704 New_Occurrence_Of
(Addr
, Loc
))));
5706 -- If the object is located on another partition, then a stub object
5707 -- will be created with all the information needed to rebuild the
5708 -- real object at the other end. This stanza is always used in the
5709 -- case of RAS types, for which a stub is required even for local
5712 Stub_Statements
:= New_List
(
5713 Make_Assignment_Statement
(Loc
,
5714 Name
=> Make_Selected_Component
(Loc
,
5715 Prefix
=> Stubbed_Result
,
5716 Selector_Name
=> Name_Target
),
5718 Make_Function_Call
(Loc
,
5720 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
5721 Parameter_Associations
=> New_List
(
5722 New_Occurrence_Of
(Reference
, Loc
)))),
5724 Make_Procedure_Call_Statement
(Loc
,
5726 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
5727 Parameter_Associations
=> New_List
(
5728 Make_Selected_Component
(Loc
,
5729 Prefix
=> Stubbed_Result
,
5730 Selector_Name
=> Name_Target
))),
5732 Make_Assignment_Statement
(Loc
,
5733 Name
=> Make_Selected_Component
(Loc
,
5734 Prefix
=> Stubbed_Result
,
5735 Selector_Name
=> Name_Asynchronous
),
5737 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)));
5739 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5740 -- set on the stub type if, and only if, the RACW type has a pragma
5741 -- Asynchronous. This is incorrect for RACWs that implement RAS
5742 -- types, because in that case the /designated subprogram/ (not the
5743 -- type) might be asynchronous, and that causes the stub to need to
5744 -- be asynchronous too. A solution is to transport a RAS as a struct
5745 -- containing a RACW and an asynchronous flag, and to properly alter
5746 -- the Asynchronous component in the stub type in the RAS's _From_Any
5749 Append_List_To
(Stub_Statements
,
5750 Build_Get_Unique_RP_Call
(Loc
, Stubbed_Result
, Stub_Type
));
5752 -- Distinguish between the local and remote cases, and execute the
5753 -- appropriate piece of code.
5755 Stub_Condition
:= New_Occurrence_Of
(Is_Local
, Loc
);
5758 Stub_Condition
:= Make_And_Then
(Loc
,
5762 Make_Selected_Component
(Loc
,
5764 Unchecked_Convert_To
(
5765 RTE
(RE_RAS_Proxy_Type_Access
),
5766 New_Occurrence_Of
(Addr
, Loc
)),
5768 Make_Identifier
(Loc
,
5769 Name_All_Calls_Remote
)));
5772 Local_Statements
:= New_List
(
5773 Make_Simple_Return_Statement
(Loc
,
5775 Unchecked_Convert_To
(RACW_Type
,
5776 New_Occurrence_Of
(Addr
, Loc
))));
5778 Append_To
(Statements
,
5779 Make_Implicit_If_Statement
(RACW_Type
,
5782 Then_Statements
=> Local_Statements
,
5783 Else_Statements
=> Stub_Statements
));
5785 Append_To
(Statements
,
5786 Make_Simple_Return_Statement
(Loc
,
5787 Expression
=> Unchecked_Convert_To
(RACW_Type
,
5788 New_Occurrence_Of
(Stubbed_Result
, Loc
))));
5791 Make_Function_Specification
(Loc
,
5792 Defining_Unit_Name
=>
5794 Parameter_Specifications
=> New_List
(
5795 Make_Parameter_Specification
(Loc
,
5796 Defining_Identifier
=>
5799 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
5800 Result_Definition
=> New_Occurrence_Of
(RACW_Type
, Loc
));
5802 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5803 -- entity in the declaration spec, not those of the body spec.
5805 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5808 Make_Subprogram_Body
(Loc
,
5810 Copy_Specification
(Loc
, Func_Spec
),
5811 Declarations
=> Decls
,
5812 Handled_Statement_Sequence
=>
5813 Make_Handled_Sequence_Of_Statements
(Loc
,
5814 Statements
=> Statements
));
5816 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5817 Append_To
(Body_Decls
, Func_Body
);
5819 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_From_Any
);
5820 end Add_RACW_From_Any
;
5822 -----------------------------
5823 -- Add_RACW_Read_Attribute --
5824 -----------------------------
5826 procedure Add_RACW_Read_Attribute
5827 (RACW_Type
: Entity_Id
;
5828 Stub_Type
: Entity_Id
;
5829 Stub_Type_Access
: Entity_Id
;
5830 Body_Decls
: List_Id
)
5832 pragma Warnings
(Off
);
5833 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
5834 pragma Warnings
(On
);
5835 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5837 Proc_Decl
: Node_Id
;
5838 Attr_Decl
: Node_Id
;
5840 Body_Node
: Node_Id
;
5843 Statements
: List_Id
;
5844 -- Various parts of the procedure
5846 Procedure_Name
: constant Name_Id
:=
5847 New_Internal_Name
('R');
5848 Source_Ref
: constant Entity_Id
:=
5849 Make_Defining_Identifier
5850 (Loc
, New_Internal_Name
('R'));
5851 Asynchronous_Flag
: constant Entity_Id
:=
5852 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5853 pragma Assert
(Present
(Asynchronous_Flag
));
5855 function Stream_Parameter
return Node_Id
;
5856 function Result
return Node_Id
;
5857 -- Functions to create occurrences of the formal parameter names
5863 function Result
return Node_Id
is
5865 return Make_Identifier
(Loc
, Name_V
);
5868 ----------------------
5869 -- Stream_Parameter --
5870 ----------------------
5872 function Stream_Parameter
return Node_Id
is
5874 return Make_Identifier
(Loc
, Name_S
);
5875 end Stream_Parameter
;
5877 -- Start of processing for Add_RACW_Read_Attribute
5880 -- Generate object declarations
5883 Make_Object_Declaration
(Loc
,
5884 Defining_Identifier
=> Source_Ref
,
5885 Object_Definition
=>
5886 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)));
5888 Statements
:= New_List
(
5889 Make_Attribute_Reference
(Loc
,
5891 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5892 Attribute_Name
=> Name_Read
,
5893 Expressions
=> New_List
(
5895 New_Occurrence_Of
(Source_Ref
, Loc
))),
5896 Make_Assignment_Statement
(Loc
,
5900 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
5902 Make_Function_Call
(Loc
,
5904 New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
5905 Parameter_Associations
=> New_List
(
5906 New_Occurrence_Of
(Source_Ref
, Loc
))),
5909 Build_Stream_Procedure
5910 (Loc
, RACW_Type
, Body_Node
,
5911 Make_Defining_Identifier
(Loc
, Procedure_Name
),
5912 Statements
, Outp
=> True);
5913 Set_Declarations
(Body_Node
, Decls
);
5915 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
5916 Copy_Specification
(Loc
, Specification
(Body_Node
)));
5919 Make_Attribute_Definition_Clause
(Loc
,
5920 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
5924 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
5926 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
5927 Insert_After
(Proc_Decl
, Attr_Decl
);
5928 Append_To
(Body_Decls
, Body_Node
);
5929 end Add_RACW_Read_Attribute
;
5931 ---------------------
5932 -- Add_RACW_To_Any --
5933 ---------------------
5935 procedure Add_RACW_To_Any
5936 (Designated_Type
: Entity_Id
;
5937 RACW_Type
: Entity_Id
;
5938 Stub_Type
: Entity_Id
;
5939 Stub_Type_Access
: Entity_Id
;
5940 Body_Decls
: List_Id
)
5942 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5944 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5948 Stub_Elements
: constant Stub_Structure
:=
5949 Stubs_Table
.Get
(Designated_Type
);
5950 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5952 Func_Spec
: Node_Id
;
5953 Func_Decl
: Node_Id
;
5954 Func_Body
: Node_Id
;
5957 Statements
: List_Id
;
5958 Null_Statements
: List_Id
;
5959 Local_Statements
: List_Id
:= No_List
;
5960 Stub_Statements
: List_Id
;
5962 -- Various parts of the subprogram
5964 RACW_Parameter
: constant Entity_Id
5965 := Make_Defining_Identifier
(Loc
, Name_R
);
5967 Reference
: constant Entity_Id
:=
5968 Make_Defining_Identifier
5969 (Loc
, New_Internal_Name
('R'));
5970 Any
: constant Entity_Id
:=
5971 Make_Defining_Identifier
5972 (Loc
, New_Internal_Name
('A'));
5976 -- Object declarations
5979 Make_Object_Declaration
(Loc
,
5980 Defining_Identifier
=>
5982 Object_Definition
=>
5983 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
5984 Make_Object_Declaration
(Loc
,
5985 Defining_Identifier
=>
5987 Object_Definition
=>
5988 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
5990 -- If the object is null, nothing to do (Reference is already
5993 Null_Statements
:= New_List
(Make_Null_Statement
(Loc
));
5997 -- If the object is a RAS designating a local subprogram, we
5998 -- already have a target reference.
6000 Local_Statements
:= New_List
(
6001 Make_Procedure_Call_Statement
(Loc
,
6003 New_Occurrence_Of
(RTE
(RE_Set_Ref
), Loc
),
6004 Parameter_Associations
=> New_List
(
6005 New_Occurrence_Of
(Reference
, Loc
),
6006 Make_Selected_Component
(Loc
,
6008 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
6009 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
6010 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)))));
6013 -- If the object is a local RACW object, use Get_Reference now to
6014 -- obtain a reference.
6016 Local_Statements
:= New_List
(
6017 Make_Procedure_Call_Statement
(Loc
,
6019 New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
6020 Parameter_Associations
=> New_List
(
6021 Unchecked_Convert_To
(
6023 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
6024 Make_String_Literal
(Loc
,
6025 Full_Qualified_Name
(Designated_Type
)),
6026 Make_Attribute_Reference
(Loc
,
6029 Defining_Identifier
(
6030 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
6033 New_Occurrence_Of
(Reference
, Loc
))));
6036 -- If the object is located on another partition, use the target from
6039 Stub_Statements
:= New_List
(
6040 Make_Procedure_Call_Statement
(Loc
,
6042 New_Occurrence_Of
(RTE
(RE_Set_Ref
), Loc
),
6043 Parameter_Associations
=> New_List
(
6044 New_Occurrence_Of
(Reference
, Loc
),
6045 Make_Selected_Component
(Loc
,
6046 Prefix
=> Unchecked_Convert_To
(Stub_Type_Access
,
6047 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
6049 Make_Identifier
(Loc
, Name_Target
)))));
6051 -- Distinguish between the null, local and remote cases, and execute
6052 -- the appropriate piece of code.
6055 Make_Implicit_If_Statement
(RACW_Type
,
6058 Left_Opnd
=> New_Occurrence_Of
(RACW_Parameter
, Loc
),
6059 Right_Opnd
=> Make_Null
(Loc
)),
6060 Then_Statements
=> Null_Statements
,
6061 Elsif_Parts
=> New_List
(
6062 Make_Elsif_Part
(Loc
,
6066 Make_Attribute_Reference
(Loc
,
6068 New_Occurrence_Of
(RACW_Parameter
, Loc
),
6069 Attribute_Name
=> Name_Tag
),
6071 Make_Attribute_Reference
(Loc
,
6072 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
6073 Attribute_Name
=> Name_Tag
)),
6074 Then_Statements
=> Local_Statements
)),
6075 Else_Statements
=> Stub_Statements
);
6077 Statements
:= New_List
(
6079 Make_Assignment_Statement
(Loc
,
6081 New_Occurrence_Of
(Any
, Loc
),
6083 Make_Function_Call
(Loc
,
6084 Name
=> New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
6085 Parameter_Associations
=> New_List
(
6086 New_Occurrence_Of
(Reference
, Loc
)))),
6087 Make_Procedure_Call_Statement
(Loc
,
6089 New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
6090 Parameter_Associations
=> New_List
(
6091 New_Occurrence_Of
(Any
, Loc
),
6092 Make_Selected_Component
(Loc
,
6094 Defining_Identifier
(
6095 Stub_Elements
.RPC_Receiver_Decl
),
6096 Selector_Name
=> Name_Obj_TypeCode
))),
6097 Make_Simple_Return_Statement
(Loc
,
6099 New_Occurrence_Of
(Any
, Loc
)));
6101 Fnam
:= Make_Defining_Identifier
(
6102 Loc
, New_Internal_Name
('T'));
6105 Make_Function_Specification
(Loc
,
6106 Defining_Unit_Name
=>
6108 Parameter_Specifications
=> New_List
(
6109 Make_Parameter_Specification
(Loc
,
6110 Defining_Identifier
=>
6113 New_Occurrence_Of
(RACW_Type
, Loc
))),
6114 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
6116 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6117 -- entity in the declaration spec, not in the body spec.
6119 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
6122 Make_Subprogram_Body
(Loc
,
6124 Copy_Specification
(Loc
, Func_Spec
),
6125 Declarations
=> Decls
,
6126 Handled_Statement_Sequence
=>
6127 Make_Handled_Sequence_Of_Statements
(Loc
,
6128 Statements
=> Statements
));
6130 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
6131 Append_To
(Body_Decls
, Func_Body
);
6133 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_To_Any
);
6134 end Add_RACW_To_Any
;
6136 -----------------------
6137 -- Add_RACW_TypeCode --
6138 -----------------------
6140 procedure Add_RACW_TypeCode
6141 (Designated_Type
: Entity_Id
;
6142 RACW_Type
: Entity_Id
;
6143 Body_Decls
: List_Id
)
6145 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
6149 Stub_Elements
: constant Stub_Structure
:=
6150 Stubs_Table
.Get
(Designated_Type
);
6151 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
6153 Func_Spec
: Node_Id
;
6154 Func_Decl
: Node_Id
;
6155 Func_Body
: Node_Id
;
6159 Make_Defining_Identifier
(Loc
,
6160 Chars
=> New_Internal_Name
('T'));
6162 -- The spec for this subprogram has a dummy 'access RACW' argument,
6163 -- which serves only for overloading purposes.
6166 Make_Function_Specification
(Loc
,
6167 Defining_Unit_Name
=>
6169 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6171 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6172 -- entity in the declaration spec, not those of the body spec.
6174 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
6177 Make_Subprogram_Body
(Loc
,
6179 Copy_Specification
(Loc
, Func_Spec
),
6180 Declarations
=> Empty_List
,
6181 Handled_Statement_Sequence
=>
6182 Make_Handled_Sequence_Of_Statements
(Loc
,
6183 Statements
=> New_List
(
6184 Make_Simple_Return_Statement
(Loc
,
6186 Make_Selected_Component
(Loc
,
6188 Defining_Identifier
(
6189 Stub_Elements
.RPC_Receiver_Decl
),
6190 Selector_Name
=> Name_Obj_TypeCode
)))));
6192 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
6193 Append_To
(Body_Decls
, Func_Body
);
6195 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_TypeCode
);
6196 end Add_RACW_TypeCode
;
6198 ------------------------------
6199 -- Add_RACW_Write_Attribute --
6200 ------------------------------
6202 procedure Add_RACW_Write_Attribute
6203 (RACW_Type
: Entity_Id
;
6204 Stub_Type
: Entity_Id
;
6205 Stub_Type_Access
: Entity_Id
;
6206 Body_Decls
: List_Id
)
6208 pragma Warnings
(Off
);
6209 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
6210 pragma Warnings
(On
);
6212 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
6214 Body_Node
: Node_Id
;
6215 Proc_Decl
: Node_Id
;
6216 Attr_Decl
: Node_Id
;
6218 Statements
: List_Id
;
6219 Procedure_Name
: constant Name_Id
:= New_Internal_Name
('R');
6221 function Stream_Parameter
return Node_Id
;
6222 function Object
return Node_Id
;
6223 -- Functions to create occurrences of the formal parameter names
6229 function Object
return Node_Id
is
6230 Object_Ref
: constant Node_Id
:=
6231 Make_Identifier
(Loc
, Name_V
);
6234 -- Etype must be set for Build_To_Any_Call
6236 Set_Etype
(Object_Ref
, RACW_Type
);
6241 ----------------------
6242 -- Stream_Parameter --
6243 ----------------------
6245 function Stream_Parameter
return Node_Id
is
6247 return Make_Identifier
(Loc
, Name_S
);
6248 end Stream_Parameter
;
6250 -- Start of processing for Add_RACW_Write_Attribute
6253 Statements
:= New_List
(
6254 Pack_Node_Into_Stream_Access
(Loc
,
6255 Stream
=> Stream_Parameter
,
6257 Make_Function_Call
(Loc
,
6259 New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
6260 Parameter_Associations
=> New_List
(
6261 PolyORB_Support
.Helpers
.Build_To_Any_Call
6262 (Object
, Body_Decls
))),
6263 Etyp
=> RTE
(RE_Object_Ref
)));
6265 Build_Stream_Procedure
6266 (Loc
, RACW_Type
, Body_Node
,
6267 Make_Defining_Identifier
(Loc
, Procedure_Name
),
6268 Statements
, Outp
=> False);
6271 Make_Subprogram_Declaration
(Loc
,
6272 Copy_Specification
(Loc
, Specification
(Body_Node
)));
6275 Make_Attribute_Definition_Clause
(Loc
,
6276 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
6277 Chars
=> Name_Write
,
6280 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
6282 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
6283 Insert_After
(Proc_Decl
, Attr_Decl
);
6284 Append_To
(Body_Decls
, Body_Node
);
6285 end Add_RACW_Write_Attribute
;
6287 -----------------------
6288 -- Add_RAST_Features --
6289 -----------------------
6291 procedure Add_RAST_Features
6292 (Vis_Decl
: Node_Id
;
6293 RAS_Type
: Entity_Id
)
6296 Add_RAS_Access_TSS
(Vis_Decl
);
6298 Add_RAS_From_Any
(RAS_Type
);
6299 Add_RAS_TypeCode
(RAS_Type
);
6301 -- To_Any uses TypeCode, and therefore needs to be generated last
6303 Add_RAS_To_Any
(RAS_Type
);
6304 end Add_RAST_Features
;
6306 ------------------------
6307 -- Add_RAS_Access_TSS --
6308 ------------------------
6310 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
6311 Loc
: constant Source_Ptr
:= Sloc
(N
);
6313 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
6314 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
6315 -- Ras_Type is the access to subprogram type; Fat_Type is the
6316 -- corresponding record type.
6318 RACW_Type
: constant Entity_Id
:=
6319 Underlying_RACW_Type
(Ras_Type
);
6320 Desig
: constant Entity_Id
:=
6321 Etype
(Designated_Type
(RACW_Type
));
6323 Stub_Elements
: constant Stub_Structure
:=
6324 Stubs_Table
.Get
(Desig
);
6325 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
6327 Proc
: constant Entity_Id
:=
6328 Make_Defining_Identifier
(Loc
,
6329 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
6331 Proc_Spec
: Node_Id
;
6333 -- Formal parameters
6335 Package_Name
: constant Entity_Id
:=
6336 Make_Defining_Identifier
(Loc
,
6341 Subp_Id
: constant Entity_Id
:=
6342 Make_Defining_Identifier
(Loc
,
6345 -- Target subprogram
6347 Asynch_P
: constant Entity_Id
:=
6348 Make_Defining_Identifier
(Loc
,
6349 Chars
=> Name_Asynchronous
);
6350 -- Is the procedure to which the 'Access applies asynchronous?
6352 All_Calls_Remote
: constant Entity_Id
:=
6353 Make_Defining_Identifier
(Loc
,
6354 Chars
=> Name_All_Calls_Remote
);
6355 -- True if an All_Calls_Remote pragma applies to the RCI unit
6356 -- that contains the subprogram.
6358 -- Common local variables
6360 Proc_Decls
: List_Id
;
6361 Proc_Statements
: List_Id
;
6363 Subp_Ref
: constant Entity_Id
:=
6364 Make_Defining_Identifier
(Loc
, Name_R
);
6365 -- Reference that designates the target subprogram (returned
6366 -- by Get_RAS_Info).
6368 Is_Local
: constant Entity_Id
:=
6369 Make_Defining_Identifier
(Loc
, Name_L
);
6370 Local_Addr
: constant Entity_Id
:=
6371 Make_Defining_Identifier
(Loc
, Name_A
);
6372 -- For the call to Get_Local_Address
6374 -- Additional local variables for the remote case
6376 Local_Stub
: constant Entity_Id
:=
6377 Make_Defining_Identifier
(Loc
,
6378 Chars
=> New_Internal_Name
('L'));
6380 Stub_Ptr
: constant Entity_Id
:=
6381 Make_Defining_Identifier
(Loc
,
6382 Chars
=> New_Internal_Name
('S'));
6385 (Field_Name
: Name_Id
;
6386 Value
: Node_Id
) return Node_Id
;
6387 -- Construct an assignment that sets the named component in the
6395 (Field_Name
: Name_Id
;
6396 Value
: Node_Id
) return Node_Id
6400 Make_Assignment_Statement
(Loc
,
6402 Make_Selected_Component
(Loc
,
6404 Selector_Name
=> Field_Name
),
6405 Expression
=> Value
);
6408 -- Start of processing for Add_RAS_Access_TSS
6411 Proc_Decls
:= New_List
(
6413 -- Common declarations
6415 Make_Object_Declaration
(Loc
,
6416 Defining_Identifier
=> Subp_Ref
,
6417 Object_Definition
=>
6418 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
6420 Make_Object_Declaration
(Loc
,
6421 Defining_Identifier
=> Is_Local
,
6422 Object_Definition
=>
6423 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6425 Make_Object_Declaration
(Loc
,
6426 Defining_Identifier
=> Local_Addr
,
6427 Object_Definition
=>
6428 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
6430 Make_Object_Declaration
(Loc
,
6431 Defining_Identifier
=> Local_Stub
,
6432 Aliased_Present
=> True,
6433 Object_Definition
=>
6434 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
6436 Make_Object_Declaration
(Loc
,
6437 Defining_Identifier
=>
6439 Object_Definition
=>
6440 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
6442 Make_Attribute_Reference
(Loc
,
6443 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
6444 Attribute_Name
=> Name_Unchecked_Access
)));
6446 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
6447 -- Build_Get_Unique_RP_Call needs this information
6449 -- Get_RAS_Info (Pkg, Subp, R);
6450 -- Obtain a reference to the target subprogram
6452 Proc_Statements
:= New_List
(
6453 Make_Procedure_Call_Statement
(Loc
,
6455 New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
6456 Parameter_Associations
=> New_List
(
6457 New_Occurrence_Of
(Package_Name
, Loc
),
6458 New_Occurrence_Of
(Subp_Id
, Loc
),
6459 New_Occurrence_Of
(Subp_Ref
, Loc
))),
6461 -- Get_Local_Address (R, L, A);
6462 -- Determine whether the subprogram is local (L), and if so
6463 -- obtain the local address of its proxy (A).
6465 Make_Procedure_Call_Statement
(Loc
,
6467 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6468 Parameter_Associations
=> New_List
(
6469 New_Occurrence_Of
(Subp_Ref
, Loc
),
6470 New_Occurrence_Of
(Is_Local
, Loc
),
6471 New_Occurrence_Of
(Local_Addr
, Loc
))));
6473 -- Note: Here we assume that the Fat_Type is a record containing just
6474 -- an access to a proxy or stub object.
6476 Append_To
(Proc_Statements
,
6480 Make_Implicit_If_Statement
(N
,
6482 New_Occurrence_Of
(Is_Local
, Loc
),
6484 Then_Statements
=> New_List
(
6486 -- if A.Target = null then
6488 Make_Implicit_If_Statement
(N
,
6491 Make_Selected_Component
(Loc
,
6493 Unchecked_Convert_To
(
6494 RTE
(RE_RAS_Proxy_Type_Access
),
6495 New_Occurrence_Of
(Local_Addr
, Loc
)),
6497 Make_Identifier
(Loc
, Name_Target
)),
6500 Then_Statements
=> New_List
(
6502 -- A.Target := Entity_Of (Ref);
6504 Make_Assignment_Statement
(Loc
,
6506 Make_Selected_Component
(Loc
,
6508 Unchecked_Convert_To
(
6509 RTE
(RE_RAS_Proxy_Type_Access
),
6510 New_Occurrence_Of
(Local_Addr
, Loc
)),
6512 Make_Identifier
(Loc
, Name_Target
)),
6514 Make_Function_Call
(Loc
,
6516 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6517 Parameter_Associations
=> New_List
(
6518 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6520 -- Inc_Usage (A.Target);
6522 Make_Procedure_Call_Statement
(Loc
,
6524 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6525 Parameter_Associations
=> New_List
(
6526 Make_Selected_Component
(Loc
,
6528 Unchecked_Convert_To
(
6529 RTE
(RE_RAS_Proxy_Type_Access
),
6530 New_Occurrence_Of
(Local_Addr
, Loc
)),
6531 Selector_Name
=> Make_Identifier
(Loc
,
6535 -- if not All_Calls_Remote then
6536 -- return Fat_Type!(A);
6539 Make_Implicit_If_Statement
(N
,
6542 New_Occurrence_Of
(All_Calls_Remote
, Loc
)),
6544 Then_Statements
=> New_List
(
6545 Make_Simple_Return_Statement
(Loc
,
6546 Unchecked_Convert_To
(Fat_Type
,
6547 New_Occurrence_Of
(Local_Addr
, Loc
))))))));
6549 Append_List_To
(Proc_Statements
, New_List
(
6551 -- Stub.Target := Entity_Of (Ref);
6553 Set_Field
(Name_Target
,
6554 Make_Function_Call
(Loc
,
6556 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6557 Parameter_Associations
=> New_List
(
6558 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6560 -- Inc_Usage (Stub.Target);
6562 Make_Procedure_Call_Statement
(Loc
,
6564 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6565 Parameter_Associations
=> New_List
(
6566 Make_Selected_Component
(Loc
,
6568 Selector_Name
=> Name_Target
))),
6570 -- E.4.1(9) A remote call is asynchronous if it is a call to
6571 -- a procedure, or a call through a value of an access-to-procedure
6572 -- type, to which a pragma Asynchronous applies.
6574 -- Parameter Asynch_P is true when the procedure is asynchronous;
6575 -- Expression Asynch_T is true when the type is asynchronous.
6577 Set_Field
(Name_Asynchronous
,
6579 New_Occurrence_Of
(Asynch_P
, Loc
),
6580 New_Occurrence_Of
(Boolean_Literals
(
6581 Is_Asynchronous
(Ras_Type
)), Loc
)))));
6583 Append_List_To
(Proc_Statements
,
6584 Build_Get_Unique_RP_Call
(Loc
,
6585 Stub_Ptr
, Stub_Elements
.Stub_Type
));
6587 Append_To
(Proc_Statements
,
6588 Make_Simple_Return_Statement
(Loc
,
6590 Unchecked_Convert_To
(Fat_Type
,
6591 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
6594 Make_Function_Specification
(Loc
,
6595 Defining_Unit_Name
=> Proc
,
6596 Parameter_Specifications
=> New_List
(
6597 Make_Parameter_Specification
(Loc
,
6598 Defining_Identifier
=> Package_Name
,
6600 New_Occurrence_Of
(Standard_String
, Loc
)),
6602 Make_Parameter_Specification
(Loc
,
6603 Defining_Identifier
=> Subp_Id
,
6605 New_Occurrence_Of
(Standard_String
, Loc
)),
6607 Make_Parameter_Specification
(Loc
,
6608 Defining_Identifier
=> Asynch_P
,
6610 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6612 Make_Parameter_Specification
(Loc
,
6613 Defining_Identifier
=> All_Calls_Remote
,
6615 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
6617 Result_Definition
=>
6618 New_Occurrence_Of
(Fat_Type
, Loc
));
6620 -- Set the kind and return type of the function to prevent
6621 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6623 Set_Ekind
(Proc
, E_Function
);
6624 Set_Etype
(Proc
, Fat_Type
);
6627 Make_Subprogram_Body
(Loc
,
6628 Specification
=> Proc_Spec
,
6629 Declarations
=> Proc_Decls
,
6630 Handled_Statement_Sequence
=>
6631 Make_Handled_Sequence_Of_Statements
(Loc
,
6632 Statements
=> Proc_Statements
)));
6634 Set_TSS
(Fat_Type
, Proc
);
6635 end Add_RAS_Access_TSS
;
6637 ----------------------
6638 -- Add_RAS_From_Any --
6639 ----------------------
6641 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
) is
6642 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6644 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6645 Make_TSS_Name
(RAS_Type
, TSS_From_Any
));
6647 Func_Spec
: Node_Id
;
6649 Statements
: List_Id
;
6651 Any_Parameter
: constant Entity_Id
:=
6652 Make_Defining_Identifier
(Loc
, Name_A
);
6655 Statements
:= New_List
(
6656 Make_Simple_Return_Statement
(Loc
,
6658 Make_Aggregate
(Loc
,
6659 Component_Associations
=> New_List
(
6660 Make_Component_Association
(Loc
,
6661 Choices
=> New_List
(
6662 Make_Identifier
(Loc
, Name_Ras
)),
6664 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
6665 Underlying_RACW_Type
(RAS_Type
),
6666 New_Occurrence_Of
(Any_Parameter
, Loc
),
6670 Make_Function_Specification
(Loc
,
6671 Defining_Unit_Name
=>
6673 Parameter_Specifications
=> New_List
(
6674 Make_Parameter_Specification
(Loc
,
6675 Defining_Identifier
=>
6678 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
6679 Result_Definition
=> New_Occurrence_Of
(RAS_Type
, Loc
));
6682 Make_Subprogram_Body
(Loc
,
6683 Specification
=> Func_Spec
,
6684 Declarations
=> No_List
,
6685 Handled_Statement_Sequence
=>
6686 Make_Handled_Sequence_Of_Statements
(Loc
,
6687 Statements
=> Statements
)));
6688 Set_TSS
(RAS_Type
, Fnam
);
6689 end Add_RAS_From_Any
;
6691 --------------------
6692 -- Add_RAS_To_Any --
6693 --------------------
6695 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
) is
6696 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6698 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6699 Make_TSS_Name
(RAS_Type
, TSS_To_Any
));
6702 Statements
: List_Id
;
6704 Func_Spec
: Node_Id
;
6706 Any
: constant Entity_Id
:=
6707 Make_Defining_Identifier
(Loc
,
6708 Chars
=> New_Internal_Name
('A'));
6709 RAS_Parameter
: constant Entity_Id
:=
6710 Make_Defining_Identifier
(Loc
,
6711 Chars
=> New_Internal_Name
('R'));
6712 RACW_Parameter
: constant Node_Id
:=
6713 Make_Selected_Component
(Loc
,
6714 Prefix
=> RAS_Parameter
,
6715 Selector_Name
=> Name_Ras
);
6718 -- Object declarations
6720 Set_Etype
(RACW_Parameter
, Underlying_RACW_Type
(RAS_Type
));
6722 Make_Object_Declaration
(Loc
,
6723 Defining_Identifier
=>
6725 Object_Definition
=>
6726 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
6728 PolyORB_Support
.Helpers
.Build_To_Any_Call
6729 (RACW_Parameter
, No_List
)));
6731 Statements
:= New_List
(
6732 Make_Procedure_Call_Statement
(Loc
,
6734 New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
6735 Parameter_Associations
=> New_List
(
6736 New_Occurrence_Of
(Any
, Loc
),
6737 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
6739 Make_Simple_Return_Statement
(Loc
,
6741 New_Occurrence_Of
(Any
, Loc
)));
6744 Make_Function_Specification
(Loc
,
6745 Defining_Unit_Name
=>
6747 Parameter_Specifications
=> New_List
(
6748 Make_Parameter_Specification
(Loc
,
6749 Defining_Identifier
=>
6752 New_Occurrence_Of
(RAS_Type
, Loc
))),
6753 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
6756 Make_Subprogram_Body
(Loc
,
6757 Specification
=> Func_Spec
,
6758 Declarations
=> Decls
,
6759 Handled_Statement_Sequence
=>
6760 Make_Handled_Sequence_Of_Statements
(Loc
,
6761 Statements
=> Statements
)));
6762 Set_TSS
(RAS_Type
, Fnam
);
6765 ----------------------
6766 -- Add_RAS_TypeCode --
6767 ----------------------
6769 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
) is
6770 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6772 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6773 Make_TSS_Name
(RAS_Type
, TSS_TypeCode
));
6775 Func_Spec
: Node_Id
;
6777 Decls
: constant List_Id
:= New_List
;
6778 Name_String
, Repo_Id_String
: String_Id
;
6782 Make_Function_Specification
(Loc
,
6783 Defining_Unit_Name
=>
6785 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6787 PolyORB_Support
.Helpers
.Build_Name_And_Repository_Id
6788 (RAS_Type
, Name_Str
=> Name_String
, Repo_Id_Str
=> Repo_Id_String
);
6791 Make_Subprogram_Body
(Loc
,
6792 Specification
=> Func_Spec
,
6793 Declarations
=> Decls
,
6794 Handled_Statement_Sequence
=>
6795 Make_Handled_Sequence_Of_Statements
(Loc
,
6796 Statements
=> New_List
(
6797 Make_Simple_Return_Statement
(Loc
,
6799 Make_Function_Call
(Loc
,
6801 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
6802 Parameter_Associations
=> New_List
(
6803 New_Occurrence_Of
(RTE
(RE_TC_Object
), Loc
),
6804 Make_Aggregate
(Loc
,
6807 Make_Function_Call
(Loc
,
6808 Name
=> New_Occurrence_Of
(
6809 RTE
(RE_TA_String
), Loc
),
6810 Parameter_Associations
=> New_List
(
6811 Make_String_Literal
(Loc
, Name_String
))),
6812 Make_Function_Call
(Loc
,
6813 Name
=> New_Occurrence_Of
(
6814 RTE
(RE_TA_String
), Loc
),
6815 Parameter_Associations
=> New_List
(
6816 Make_String_Literal
(Loc
,
6817 Repo_Id_String
))))))))))));
6818 Set_TSS
(RAS_Type
, Fnam
);
6819 end Add_RAS_TypeCode
;
6821 -----------------------------------------
6822 -- Add_Receiving_Stubs_To_Declarations --
6823 -----------------------------------------
6825 procedure Add_Receiving_Stubs_To_Declarations
6826 (Pkg_Spec
: Node_Id
;
6830 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
6832 Pkg_RPC_Receiver
: constant Entity_Id
:=
6833 Make_Defining_Identifier
(Loc
,
6834 New_Internal_Name
('H'));
6835 Pkg_RPC_Receiver_Object
: Node_Id
;
6837 Pkg_RPC_Receiver_Body
: Node_Id
;
6838 Pkg_RPC_Receiver_Decls
: List_Id
;
6839 Pkg_RPC_Receiver_Statements
: List_Id
;
6840 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
6841 -- A Pkg_RPC_Receiver is built to decode the request
6844 -- Request object received from neutral layer
6846 Subp_Id
: Entity_Id
;
6847 -- Subprogram identifier as received from the neutral
6848 -- distribution core.
6850 Subp_Index
: Entity_Id
;
6851 -- Internal index as determined by matching either the
6852 -- method name from the request structure, or the local
6853 -- subprogram address (in case of a RAS).
6855 Is_Local
: constant Entity_Id
:=
6856 Make_Defining_Identifier
(Loc
, New_Internal_Name
('L'));
6857 Local_Address
: constant Entity_Id
:=
6858 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
6859 -- Address of a local subprogram designated by a
6860 -- reference corresponding to a RAS.
6862 Dispatch_On_Address
: constant List_Id
:= New_List
;
6863 Dispatch_On_Name
: constant List_Id
:= New_List
;
6865 Current_Declaration
: Node_Id
;
6866 Current_Stubs
: Node_Id
;
6867 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
6869 Subp_Info_Array
: constant Entity_Id
:=
6870 Make_Defining_Identifier
(Loc
,
6871 Chars
=> New_Internal_Name
('I'));
6873 Subp_Info_List
: constant List_Id
:= New_List
;
6875 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
6877 All_Calls_Remote_E
: Entity_Id
;
6879 procedure Append_Stubs_To
6880 (RPC_Receiver_Cases
: List_Id
;
6881 Declaration
: Node_Id
;
6884 Subp_Dist_Name
: Entity_Id
;
6885 Subp_Proxy_Addr
: Entity_Id
);
6886 -- Add one case to the specified RPC receiver case list associating
6887 -- Subprogram_Number with the subprogram declared by Declaration, for
6888 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6889 -- subprogram index. Subp_Dist_Name is the string used to call the
6890 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6891 -- object, used in the context of calls through remote
6892 -- access-to-subprogram types.
6894 ---------------------
6895 -- Append_Stubs_To --
6896 ---------------------
6898 procedure Append_Stubs_To
6899 (RPC_Receiver_Cases
: List_Id
;
6900 Declaration
: Node_Id
;
6903 Subp_Dist_Name
: Entity_Id
;
6904 Subp_Proxy_Addr
: Entity_Id
)
6906 Case_Stmts
: List_Id
;
6908 Case_Stmts
:= New_List
(
6909 Make_Procedure_Call_Statement
(Loc
,
6912 Defining_Entity
(Stubs
), Loc
),
6913 Parameter_Associations
=>
6914 New_List
(New_Occurrence_Of
(Request
, Loc
))));
6915 if Nkind
(Specification
(Declaration
))
6916 = N_Function_Specification
6918 Is_Asynchronous
(Defining_Entity
(Specification
(Declaration
)))
6920 Append_To
(Case_Stmts
, Make_Simple_Return_Statement
(Loc
));
6923 Append_To
(RPC_Receiver_Cases
,
6924 Make_Case_Statement_Alternative
(Loc
,
6926 New_List
(Make_Integer_Literal
(Loc
, Subp_Number
)),
6930 Append_To
(Dispatch_On_Name
,
6931 Make_Elsif_Part
(Loc
,
6933 Make_Function_Call
(Loc
,
6935 New_Occurrence_Of
(RTE
(RE_Caseless_String_Eq
), Loc
),
6936 Parameter_Associations
=> New_List
(
6937 New_Occurrence_Of
(Subp_Id
, Loc
),
6938 New_Occurrence_Of
(Subp_Dist_Name
, Loc
))),
6939 Then_Statements
=> New_List
(
6940 Make_Assignment_Statement
(Loc
,
6941 New_Occurrence_Of
(Subp_Index
, Loc
),
6942 Make_Integer_Literal
(Loc
,
6945 Append_To
(Dispatch_On_Address
,
6946 Make_Elsif_Part
(Loc
,
6950 New_Occurrence_Of
(Local_Address
, Loc
),
6952 New_Occurrence_Of
(Subp_Proxy_Addr
, Loc
)),
6953 Then_Statements
=> New_List
(
6954 Make_Assignment_Statement
(Loc
,
6955 New_Occurrence_Of
(Subp_Index
, Loc
),
6956 Make_Integer_Literal
(Loc
,
6958 end Append_Stubs_To
;
6960 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6963 -- Building receiving stubs consist in several operations:
6965 -- - a package RPC receiver must be built. This subprogram
6966 -- will get a Subprogram_Id from the incoming stream
6967 -- and will dispatch the call to the right subprogram;
6969 -- - a receiving stub for each subprogram visible in the package
6970 -- spec. This stub will read all the parameters from the stream,
6971 -- and put the result as well as the exception occurrence in the
6974 -- - a dummy package with an empty spec and a body made of an
6975 -- elaboration part, whose job is to register the receiving
6976 -- part of this RCI package on the name server. This is done
6977 -- by calling System.Partition_Interface.Register_Receiving_Stub.
6979 Build_RPC_Receiver_Body
(
6980 RPC_Receiver
=> Pkg_RPC_Receiver
,
6983 Subp_Index
=> Subp_Index
,
6984 Stmts
=> Pkg_RPC_Receiver_Statements
,
6985 Decl
=> Pkg_RPC_Receiver_Body
);
6986 Pkg_RPC_Receiver_Decls
:= Declarations
(Pkg_RPC_Receiver_Body
);
6988 -- Extract local address information from the target reference:
6989 -- if non-null, that means that this is a reference that denotes
6990 -- one particular operation, and hence that the operation name
6991 -- must not be taken into account for dispatching.
6993 Append_To
(Pkg_RPC_Receiver_Decls
,
6994 Make_Object_Declaration
(Loc
,
6995 Defining_Identifier
=>
6997 Object_Definition
=>
6998 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
6999 Append_To
(Pkg_RPC_Receiver_Decls
,
7000 Make_Object_Declaration
(Loc
,
7001 Defining_Identifier
=>
7003 Object_Definition
=>
7004 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
7005 Append_To
(Pkg_RPC_Receiver_Statements
,
7006 Make_Procedure_Call_Statement
(Loc
,
7008 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
7009 Parameter_Associations
=> New_List
(
7010 Make_Selected_Component
(Loc
,
7012 Selector_Name
=> Name_Target
),
7013 New_Occurrence_Of
(Is_Local
, Loc
),
7014 New_Occurrence_Of
(Local_Address
, Loc
))));
7016 -- For each subprogram, the receiving stub will be built and a
7017 -- case statement will be made on the Subprogram_Id to dispatch
7018 -- to the right subprogram.
7020 All_Calls_Remote_E
:= Boolean_Literals
(
7021 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
7023 Overload_Counter_Table
.Reset
;
7024 Reserve_NamingContext_Methods
;
7026 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
7027 while Present
(Current_Declaration
) loop
7028 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
7029 and then Comes_From_Source
(Current_Declaration
)
7032 Loc
: constant Source_Ptr
:=
7033 Sloc
(Current_Declaration
);
7034 -- While specifically processing Current_Declaration, use
7035 -- its Sloc as the location of all generated nodes.
7037 Subp_Def
: constant Entity_Id
:=
7039 (Specification
(Current_Declaration
));
7041 Subp_Val
: String_Id
;
7043 Subp_Dist_Name
: constant Entity_Id
:=
7044 Make_Defining_Identifier
(Loc
,
7046 Related_Id
=> Chars
(Subp_Def
),
7048 Suffix_Index
=> -1));
7050 Proxy_Object_Addr
: Entity_Id
;
7053 -- Build receiving stub
7056 Build_Subprogram_Receiving_Stubs
7057 (Vis_Decl
=> Current_Declaration
,
7059 Nkind
(Specification
(Current_Declaration
)) =
7060 N_Procedure_Specification
7061 and then Is_Asynchronous
(Subp_Def
));
7063 Append_To
(Decls
, Current_Stubs
);
7064 Analyze
(Current_Stubs
);
7068 Add_RAS_Proxy_And_Analyze
(Decls
,
7070 Current_Declaration
,
7071 All_Calls_Remote_E
=>
7073 Proxy_Object_Addr
=>
7076 -- Compute distribution identifier
7078 Assign_Subprogram_Identifier
(
7080 Current_Subprogram_Number
,
7083 pragma Assert
(Current_Subprogram_Number
=
7084 Get_Subprogram_Id
(Subp_Def
));
7087 Make_Object_Declaration
(Loc
,
7088 Defining_Identifier
=> Subp_Dist_Name
,
7089 Constant_Present
=> True,
7090 Object_Definition
=> New_Occurrence_Of
(
7091 Standard_String
, Loc
),
7093 Make_String_Literal
(Loc
, Subp_Val
)));
7094 Analyze
(Last
(Decls
));
7096 -- Add subprogram descriptor (RCI_Subp_Info) to the
7097 -- subprograms table for this receiver. The aggregate
7098 -- below must be kept consistent with the declaration
7099 -- of type RCI_Subp_Info in System.Partition_Interface.
7101 Append_To
(Subp_Info_List
,
7102 Make_Component_Association
(Loc
,
7103 Choices
=> New_List
(
7104 Make_Integer_Literal
(Loc
,
7105 Current_Subprogram_Number
)),
7107 Make_Aggregate
(Loc
,
7108 Expressions
=> New_List
(
7109 Make_Attribute_Reference
(Loc
,
7112 Subp_Dist_Name
, Loc
),
7113 Attribute_Name
=> Name_Address
),
7114 Make_Attribute_Reference
(Loc
,
7117 Subp_Dist_Name
, Loc
),
7118 Attribute_Name
=> Name_Length
),
7119 New_Occurrence_Of
(Proxy_Object_Addr
, Loc
)))));
7121 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
7122 Declaration
=> Current_Declaration
,
7123 Stubs
=> Current_Stubs
,
7124 Subp_Number
=> Current_Subprogram_Number
,
7125 Subp_Dist_Name
=> Subp_Dist_Name
,
7126 Subp_Proxy_Addr
=> Proxy_Object_Addr
);
7129 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
7132 Next
(Current_Declaration
);
7136 Make_Object_Declaration
(Loc
,
7137 Defining_Identifier
=> Subp_Info_Array
,
7138 Constant_Present
=> True,
7139 Aliased_Present
=> True,
7140 Object_Definition
=>
7141 Make_Subtype_Indication
(Loc
,
7143 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
7145 Make_Index_Or_Discriminant_Constraint
(Loc
,
7148 Low_Bound
=> Make_Integer_Literal
(Loc
,
7149 First_RCI_Subprogram_Id
),
7151 Make_Integer_Literal
(Loc
,
7152 First_RCI_Subprogram_Id
7153 + List_Length
(Subp_Info_List
) - 1)))))));
7155 if Present
(First
(Subp_Info_List
)) then
7156 Set_Expression
(Last
(Decls
),
7157 Make_Aggregate
(Loc
,
7158 Component_Associations
=> Subp_Info_List
));
7160 -- Generate the dispatch statement to determine the subprogram id
7161 -- of the called subprogram.
7163 -- We first test whether the reference that was used to make the
7164 -- call was the base RCI reference (in which case Local_Address is
7165 -- zero, and the method identifier from the request must be used
7166 -- to determine which subprogram is called) or a reference
7167 -- identifying one particular subprogram (in which case
7168 -- Local_Address is the address of that subprogram, and the
7169 -- method name from the request is ignored). The latter occurs
7170 -- for the case of a call through a remote access-to-subprogram.
7172 -- In each case, cascaded elsifs are used to determine the proper
7173 -- subprogram index. Using hash tables might be more efficient.
7175 Append_To
(Pkg_RPC_Receiver_Statements
,
7176 Make_Implicit_If_Statement
(Pkg_Spec
,
7179 Left_Opnd
=> New_Occurrence_Of
7180 (Local_Address
, Loc
),
7181 Right_Opnd
=> New_Occurrence_Of
7182 (RTE
(RE_Null_Address
), Loc
)),
7183 Then_Statements
=> New_List
(
7184 Make_Implicit_If_Statement
(Pkg_Spec
,
7186 New_Occurrence_Of
(Standard_False
, Loc
),
7187 Then_Statements
=> New_List
(
7188 Make_Null_Statement
(Loc
)),
7190 Dispatch_On_Address
)),
7192 Else_Statements
=> New_List
(
7193 Make_Implicit_If_Statement
(Pkg_Spec
,
7195 New_Occurrence_Of
(Standard_False
, Loc
),
7196 Then_Statements
=> New_List
(
7197 Make_Null_Statement
(Loc
)),
7199 Dispatch_On_Name
))));
7202 -- For a degenerate RCI with no visible subprograms,
7203 -- Subp_Info_List has zero length, and the declaration is for an
7204 -- empty array, in which case no initialization aggregate must be
7205 -- generated. We do not generate a Dispatch_Statement either.
7207 -- No initialization provided: remove CONSTANT so that the
7208 -- declaration is not an incomplete deferred constant.
7210 Set_Constant_Present
(Last
(Decls
), False);
7213 -- Analyze Subp_Info_Array declaration
7215 Analyze
(Last
(Decls
));
7217 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7218 -- rather than raising an exception since we do not want someone
7219 -- to crash a remote partition by sending invalid subprogram ids.
7220 -- This is consistent with the other parts of the case statement
7221 -- since even in presence of incorrect parameters in the stream,
7222 -- every exception will be caught and (if the subprogram is not an
7223 -- APC) put into the result stream and sent away.
7225 Append_To
(Pkg_RPC_Receiver_Cases
,
7226 Make_Case_Statement_Alternative
(Loc
,
7228 New_List
(Make_Others_Choice
(Loc
)),
7230 New_List
(Make_Null_Statement
(Loc
))));
7232 Append_To
(Pkg_RPC_Receiver_Statements
,
7233 Make_Case_Statement
(Loc
,
7235 New_Occurrence_Of
(Subp_Index
, Loc
),
7236 Alternatives
=> Pkg_RPC_Receiver_Cases
));
7238 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7241 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
7242 Analyze
(Last
(Decls
));
7244 Pkg_RPC_Receiver_Object
:=
7245 Make_Object_Declaration
(Loc
,
7246 Defining_Identifier
=>
7247 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
7248 Aliased_Present
=> True,
7249 Object_Definition
=>
7250 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7251 Append_To
(Decls
, Pkg_RPC_Receiver_Object
);
7252 Analyze
(Last
(Decls
));
7254 Get_Library_Unit_Name_String
(Pkg_Spec
);
7255 Append_To
(Register_Pkg_Actuals
,
7257 Make_String_Literal
(Loc
,
7258 Strval
=> String_From_Name_Buffer
));
7260 Append_To
(Register_Pkg_Actuals
,
7262 Make_Attribute_Reference
(Loc
,
7265 (Defining_Entity
(Pkg_Spec
), Loc
),
7269 Append_To
(Register_Pkg_Actuals
,
7271 Make_Attribute_Reference
(Loc
,
7273 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
7274 Attribute_Name
=> Name_Access
));
7276 Append_To
(Register_Pkg_Actuals
,
7278 Make_Attribute_Reference
(Loc
,
7281 Defining_Identifier
(
7282 Pkg_RPC_Receiver_Object
), Loc
),
7286 Append_To
(Register_Pkg_Actuals
,
7288 Make_Attribute_Reference
(Loc
,
7290 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
7294 Append_To
(Register_Pkg_Actuals
,
7296 Make_Attribute_Reference
(Loc
,
7298 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
7302 Append_To
(Register_Pkg_Actuals
,
7303 -- Is_All_Calls_Remote
7304 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
));
7307 Make_Procedure_Call_Statement
(Loc
,
7309 New_Occurrence_Of
(RTE
(RE_Register_Pkg_Receiving_Stub
), Loc
),
7310 Parameter_Associations
=> Register_Pkg_Actuals
));
7311 Analyze
(Last
(Stmts
));
7313 end Add_Receiving_Stubs_To_Declarations
;
7315 ---------------------------------
7316 -- Build_General_Calling_Stubs --
7317 ---------------------------------
7319 procedure Build_General_Calling_Stubs
7321 Statements
: List_Id
;
7322 Target_Object
: Node_Id
;
7323 Subprogram_Id
: Node_Id
;
7324 Asynchronous
: Node_Id
:= Empty
;
7325 Is_Known_Asynchronous
: Boolean := False;
7326 Is_Known_Non_Asynchronous
: Boolean := False;
7327 Is_Function
: Boolean;
7329 Stub_Type
: Entity_Id
:= Empty
;
7330 RACW_Type
: Entity_Id
:= Empty
;
7333 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
7335 Arguments
: Node_Id
;
7336 -- Name of the named values list used to transmit parameters
7337 -- to the remote package
7340 -- The request object constructed by these stubs
7343 -- Name of the result named value (in non-APC cases) which get the
7344 -- result of the remote subprogram.
7346 Result_TC
: Node_Id
;
7347 -- Typecode expression for the result of the request (void
7348 -- typecode for procedures).
7350 Exception_Return_Parameter
: Node_Id
;
7351 -- Name of the parameter which will hold the exception sent by the
7352 -- remote subprogram.
7354 Current_Parameter
: Node_Id
;
7355 -- Current parameter being handled
7357 Ordered_Parameters_List
: constant List_Id
:=
7358 Build_Ordered_Parameters_List
(Spec
);
7360 Asynchronous_P
: Node_Id
;
7361 -- A Boolean expression indicating whether this call is asynchronous
7363 Asynchronous_Statements
: List_Id
:= No_List
;
7364 Non_Asynchronous_Statements
: List_Id
:= No_List
;
7365 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7367 Extra_Formal_Statements
: constant List_Id
:= New_List
;
7368 -- List of statements for extra formal parameters. It will appear
7369 -- after the regular statements for writing out parameters.
7371 After_Statements
: constant List_Id
:= New_List
;
7372 -- Statements to be executed after call returns (to assign
7373 -- in out or out parameter values).
7376 -- The type of the formal parameter being processed
7378 Is_Controlling_Formal
: Boolean;
7379 Is_First_Controlling_Formal
: Boolean;
7380 First_Controlling_Formal_Seen
: Boolean := False;
7381 -- Controlling formal parameters of distributed object primitives
7382 -- require special handling, and the first such parameter needs even
7383 -- more special handling.
7386 -- ??? document general form of stub subprograms for the PolyORB case
7388 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
7391 Make_Object_Declaration
(Loc
,
7392 Defining_Identifier
=> Request
,
7393 Aliased_Present
=> False,
7394 Object_Definition
=>
7395 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
)));
7398 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
7401 Result_TC
:= PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
7402 Etype
(Result_Definition
(Spec
)), Decls
);
7404 Result_TC
:= New_Occurrence_Of
(RTE
(RE_TC_Void
), Loc
);
7408 Make_Object_Declaration
(Loc
,
7409 Defining_Identifier
=> Result
,
7410 Aliased_Present
=> False,
7411 Object_Definition
=>
7412 New_Occurrence_Of
(RTE
(RE_NamedValue
), Loc
),
7414 Make_Aggregate
(Loc
,
7415 Component_Associations
=> New_List
(
7416 Make_Component_Association
(Loc
,
7417 Choices
=> New_List
(
7418 Make_Identifier
(Loc
, Name_Name
)),
7420 New_Occurrence_Of
(RTE
(RE_Result_Name
), Loc
)),
7421 Make_Component_Association
(Loc
,
7422 Choices
=> New_List
(
7423 Make_Identifier
(Loc
, Name_Argument
)),
7425 Make_Function_Call
(Loc
,
7427 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7428 Parameter_Associations
=> New_List
(
7430 Make_Component_Association
(Loc
,
7431 Choices
=> New_List
(
7432 Make_Identifier
(Loc
, Name_Arg_Modes
)),
7434 Make_Integer_Literal
(Loc
, 0))))));
7436 if not Is_Known_Asynchronous
then
7437 Exception_Return_Parameter
:=
7438 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
7441 Make_Object_Declaration
(Loc
,
7442 Defining_Identifier
=> Exception_Return_Parameter
,
7443 Object_Definition
=>
7444 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
7447 Exception_Return_Parameter
:= Empty
;
7450 -- Initialize and fill in arguments list
7453 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
7454 Declare_Create_NVList
(Loc
, Arguments
, Decls
, Statements
);
7456 Current_Parameter
:= First
(Ordered_Parameters_List
);
7457 while Present
(Current_Parameter
) loop
7459 if Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
) then
7460 Is_Controlling_Formal
:= True;
7461 Is_First_Controlling_Formal
:=
7462 not First_Controlling_Formal_Seen
;
7463 First_Controlling_Formal_Seen
:= True;
7465 Is_Controlling_Formal
:= False;
7466 Is_First_Controlling_Formal
:= False;
7469 if Is_Controlling_Formal
then
7471 -- In the case of a controlling formal argument, we send its
7477 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7480 -- The first controlling formal parameter is treated specially: it
7481 -- is used to set the target object of the call.
7483 if not Is_First_Controlling_Formal
then
7486 Constrained
: constant Boolean :=
7487 Is_Constrained
(Etyp
)
7488 or else Is_Elementary_Type
(Etyp
);
7490 Any
: constant Entity_Id
:=
7491 Make_Defining_Identifier
(Loc
,
7492 New_Internal_Name
('A'));
7494 Actual_Parameter
: Node_Id
:=
7496 Defining_Identifier
(
7497 Current_Parameter
), Loc
);
7502 if Is_Controlling_Formal
then
7504 -- For a controlling formal parameter (other than the
7505 -- first one), use the corresponding RACW. If the
7506 -- parameter is not an anonymous access parameter, that
7507 -- involves taking its 'Unrestricted_Access.
7509 if Nkind
(Parameter_Type
(Current_Parameter
))
7510 = N_Access_Definition
7512 Actual_Parameter
:= OK_Convert_To
7513 (Etyp
, Actual_Parameter
);
7515 Actual_Parameter
:= OK_Convert_To
(Etyp
,
7516 Make_Attribute_Reference
(Loc
,
7520 Name_Unrestricted_Access
));
7525 if In_Present
(Current_Parameter
)
7526 or else not Out_Present
(Current_Parameter
)
7527 or else not Constrained
7528 or else Is_Controlling_Formal
7530 -- The parameter has an input value, is constrained at
7531 -- runtime by an input value, or is a controlling formal
7532 -- parameter (always passed as a reference) other than
7535 Expr
:= PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7536 Actual_Parameter
, Decls
);
7538 Expr
:= Make_Function_Call
(Loc
,
7540 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7541 Parameter_Associations
=> New_List
(
7542 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
7547 Make_Object_Declaration
(Loc
,
7548 Defining_Identifier
=>
7550 Aliased_Present
=> False,
7551 Object_Definition
=>
7552 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7556 Append_To
(Statements
,
7557 Add_Parameter_To_NVList
(Loc
,
7558 Parameter
=> Current_Parameter
,
7559 NVList
=> Arguments
,
7560 Constrained
=> Constrained
,
7563 if Out_Present
(Current_Parameter
)
7564 and then not Is_Controlling_Formal
7566 Append_To
(After_Statements
,
7567 Make_Assignment_Statement
(Loc
,
7570 Defining_Identifier
(Current_Parameter
), Loc
),
7572 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7573 Etype
(Parameter_Type
(Current_Parameter
)),
7574 New_Occurrence_Of
(Any
, Loc
),
7581 -- If the current parameter has a dynamic constrained status, then
7582 -- this status is transmitted as well.
7583 -- This should be done for accessibility as well ???
7585 if Nkind
(Parameter_Type
(Current_Parameter
))
7586 /= N_Access_Definition
7587 and then Need_Extra_Constrained
(Current_Parameter
)
7589 -- In this block, we do not use the extra formal that has been
7590 -- created because it does not exist at the time of expansion
7591 -- when building calling stubs for remote access to subprogram
7592 -- types. We create an extra variable of this type and push it
7593 -- in the stream after the regular parameters.
7596 Extra_Any_Parameter
: constant Entity_Id
:=
7597 Make_Defining_Identifier
7598 (Loc
, New_Internal_Name
('P'));
7600 Parameter_Exp
: constant Node_Id
:=
7601 Make_Attribute_Reference
(Loc
,
7602 Prefix
=> New_Occurrence_Of
(
7603 Defining_Identifier
(Current_Parameter
), Loc
),
7604 Attribute_Name
=> Name_Constrained
);
7606 Set_Etype
(Parameter_Exp
, Etype
(Standard_Boolean
));
7609 Make_Object_Declaration
(Loc
,
7610 Defining_Identifier
=>
7611 Extra_Any_Parameter
,
7612 Aliased_Present
=> False,
7613 Object_Definition
=>
7614 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7616 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7620 Append_To
(Extra_Formal_Statements
,
7621 Add_Parameter_To_NVList
(Loc
,
7622 Parameter
=> Extra_Any_Parameter
,
7623 NVList
=> Arguments
,
7624 Constrained
=> True,
7625 Any
=> Extra_Any_Parameter
));
7629 Next
(Current_Parameter
);
7632 -- Append the formal statements list to the statements
7634 Append_List_To
(Statements
, Extra_Formal_Statements
);
7636 Append_To
(Statements
,
7637 Make_Procedure_Call_Statement
(Loc
,
7639 New_Occurrence_Of
(RTE
(RE_Request_Create
), Loc
),
7640 Parameter_Associations
=> New_List
(
7643 New_Occurrence_Of
(Arguments
, Loc
),
7644 New_Occurrence_Of
(Result
, Loc
),
7645 New_Occurrence_Of
(RTE
(RE_Nil_Exc_List
), Loc
))));
7647 Append_To
(Parameter_Associations
(Last
(Statements
)),
7648 New_Occurrence_Of
(Request
, Loc
));
7651 not (Is_Known_Non_Asynchronous
and Is_Known_Asynchronous
));
7652 if Is_Known_Non_Asynchronous
or Is_Known_Asynchronous
then
7653 Asynchronous_P
:= New_Occurrence_Of
(
7654 Boolean_Literals
(Is_Known_Asynchronous
), Loc
);
7656 pragma Assert
(Present
(Asynchronous
));
7657 Asynchronous_P
:= New_Copy_Tree
(Asynchronous
);
7658 -- The expression node Asynchronous will be used to build an 'if'
7659 -- statement at the end of Build_General_Calling_Stubs: we need to
7660 -- make a copy here.
7663 Append_To
(Parameter_Associations
(Last
(Statements
)),
7664 Make_Indexed_Component
(Loc
,
7667 RTE
(RE_Asynchronous_P_To_Sync_Scope
), Loc
),
7668 Expressions
=> New_List
(Asynchronous_P
)));
7670 Append_To
(Statements
,
7671 Make_Procedure_Call_Statement
(Loc
,
7673 New_Occurrence_Of
(RTE
(RE_Request_Invoke
), Loc
),
7674 Parameter_Associations
=> New_List
(
7675 New_Occurrence_Of
(Request
, Loc
))));
7677 Non_Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7678 Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7680 if not Is_Known_Asynchronous
then
7682 -- Reraise an exception occurrence from the completed request.
7683 -- If the exception occurrence is empty, this is a no-op.
7685 Append_To
(Non_Asynchronous_Statements
,
7686 Make_Procedure_Call_Statement
(Loc
,
7688 New_Occurrence_Of
(RTE
(RE_Request_Raise_Occurrence
), Loc
),
7689 Parameter_Associations
=> New_List
(
7690 New_Occurrence_Of
(Request
, Loc
))));
7694 -- If this is a function call, read the value and return it
7696 Append_To
(Non_Asynchronous_Statements
,
7697 Make_Tag_Check
(Loc
,
7698 Make_Simple_Return_Statement
(Loc
,
7699 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7700 Etype
(Result_Definition
(Spec
)),
7701 Make_Selected_Component
(Loc
,
7703 Selector_Name
=> Name_Argument
),
7708 Append_List_To
(Non_Asynchronous_Statements
,
7711 if Is_Known_Asynchronous
then
7712 Append_List_To
(Statements
, Asynchronous_Statements
);
7714 elsif Is_Known_Non_Asynchronous
then
7715 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
7718 pragma Assert
(Present
(Asynchronous
));
7719 Append_To
(Statements
,
7720 Make_Implicit_If_Statement
(Nod
,
7721 Condition
=> Asynchronous
,
7722 Then_Statements
=> Asynchronous_Statements
,
7723 Else_Statements
=> Non_Asynchronous_Statements
));
7725 end Build_General_Calling_Stubs
;
7727 -----------------------
7728 -- Build_Stub_Target --
7729 -----------------------
7731 function Build_Stub_Target
7734 RCI_Locator
: Entity_Id
;
7735 Controlling_Parameter
: Entity_Id
) return RPC_Target
7737 Target_Info
: RPC_Target
(PCS_Kind
=> Name_PolyORB_DSA
);
7738 Target_Reference
: constant Entity_Id
:=
7739 Make_Defining_Identifier
(Loc
,
7740 New_Internal_Name
('T'));
7742 if Present
(Controlling_Parameter
) then
7744 Make_Object_Declaration
(Loc
,
7745 Defining_Identifier
=> Target_Reference
,
7746 Object_Definition
=>
7747 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
7749 Make_Function_Call
(Loc
,
7751 New_Occurrence_Of
(RTE
(RE_Make_Ref
), Loc
),
7752 Parameter_Associations
=> New_List
(
7753 Make_Selected_Component
(Loc
,
7754 Prefix
=> Controlling_Parameter
,
7755 Selector_Name
=> Name_Target
)))));
7756 -- Controlling_Parameter has the same components as
7757 -- System.Partition_Interface.RACW_Stub_Type.
7759 Target_Info
.Object
:= New_Occurrence_Of
(Target_Reference
, Loc
);
7762 Target_Info
.Object
:=
7763 Make_Selected_Component
(Loc
,
7765 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
7767 Make_Identifier
(Loc
, Name_Get_RCI_Package_Ref
));
7770 end Build_Stub_Target
;
7772 ---------------------
7773 -- Build_Stub_Type --
7774 ---------------------
7776 procedure Build_Stub_Type
7777 (RACW_Type
: Entity_Id
;
7778 Stub_Type
: Entity_Id
;
7779 Stub_Type_Decl
: out Node_Id
;
7780 RPC_Receiver_Decl
: out Node_Id
)
7782 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
7783 pragma Warnings
(Off
);
7784 pragma Unreferenced
(RACW_Type
);
7785 pragma Warnings
(On
);
7789 Make_Full_Type_Declaration
(Loc
,
7790 Defining_Identifier
=> Stub_Type
,
7792 Make_Record_Definition
(Loc
,
7793 Tagged_Present
=> True,
7794 Limited_Present
=> True,
7796 Make_Component_List
(Loc
,
7797 Component_Items
=> New_List
(
7799 Make_Component_Declaration
(Loc
,
7800 Defining_Identifier
=>
7801 Make_Defining_Identifier
(Loc
, Name_Target
),
7802 Component_Definition
=>
7803 Make_Component_Definition
(Loc
,
7806 Subtype_Indication
=>
7807 New_Occurrence_Of
(RTE
(RE_Entity_Ptr
), Loc
))),
7809 Make_Component_Declaration
(Loc
,
7810 Defining_Identifier
=>
7811 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
7812 Component_Definition
=>
7813 Make_Component_Definition
(Loc
,
7814 Aliased_Present
=> False,
7815 Subtype_Indication
=>
7817 Standard_Boolean
, Loc
)))))));
7819 RPC_Receiver_Decl
:=
7820 Make_Object_Declaration
(Loc
,
7821 Defining_Identifier
=> Make_Defining_Identifier
(Loc
,
7822 New_Internal_Name
('R')),
7823 Aliased_Present
=> True,
7824 Object_Definition
=>
7825 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7826 end Build_Stub_Type
;
7828 -----------------------------
7829 -- Build_RPC_Receiver_Body --
7830 -----------------------------
7832 procedure Build_RPC_Receiver_Body
7833 (RPC_Receiver
: Entity_Id
;
7834 Request
: out Entity_Id
;
7835 Subp_Id
: out Entity_Id
;
7836 Subp_Index
: out Entity_Id
;
7837 Stmts
: out List_Id
;
7840 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
7842 RPC_Receiver_Spec
: Node_Id
;
7843 RPC_Receiver_Decls
: List_Id
;
7846 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
7848 RPC_Receiver_Spec
:=
7849 Build_RPC_Receiver_Specification
(
7850 RPC_Receiver
=> RPC_Receiver
,
7851 Request_Parameter
=> Request
);
7853 Subp_Id
:= Make_Defining_Identifier
(Loc
, Name_P
);
7854 Subp_Index
:= Make_Defining_Identifier
(Loc
, Name_I
);
7856 RPC_Receiver_Decls
:= New_List
(
7857 Make_Object_Renaming_Declaration
(Loc
,
7858 Defining_Identifier
=> Subp_Id
,
7859 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
7861 Make_Explicit_Dereference
(Loc
,
7863 Make_Selected_Component
(Loc
,
7865 Selector_Name
=> Name_Operation
))),
7867 Make_Object_Declaration
(Loc
,
7868 Defining_Identifier
=> Subp_Index
,
7869 Object_Definition
=>
7870 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7872 Make_Attribute_Reference
(Loc
,
7874 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7875 Attribute_Name
=> Name_Last
)));
7880 Make_Subprogram_Body
(Loc
,
7881 Specification
=> RPC_Receiver_Spec
,
7882 Declarations
=> RPC_Receiver_Decls
,
7883 Handled_Statement_Sequence
=>
7884 Make_Handled_Sequence_Of_Statements
(Loc
,
7885 Statements
=> Stmts
));
7886 end Build_RPC_Receiver_Body
;
7888 --------------------------------------
7889 -- Build_Subprogram_Receiving_Stubs --
7890 --------------------------------------
7892 function Build_Subprogram_Receiving_Stubs
7893 (Vis_Decl
: Node_Id
;
7894 Asynchronous
: Boolean;
7895 Dynamically_Asynchronous
: Boolean := False;
7896 Stub_Type
: Entity_Id
:= Empty
;
7897 RACW_Type
: Entity_Id
:= Empty
;
7898 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
7900 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
7902 Request_Parameter
: constant Entity_Id
:=
7903 Make_Defining_Identifier
(Loc
,
7904 New_Internal_Name
('R'));
7905 -- Formal parameter for receiving stubs: a descriptor for an incoming
7908 Outer_Decls
: constant List_Id
:= New_List
;
7909 -- At the outermost level, an NVList and Any's are declared for all
7910 -- parameters. The Dynamic_Async flag also needs to be declared there
7911 -- to be visible from the exception handling code.
7913 Outer_Statements
: constant List_Id
:= New_List
;
7914 -- Statements that occur prior to the declaration of the actual
7915 -- parameter variables.
7917 Outer_Extra_Formal_Statements
: constant List_Id
:= New_List
;
7918 -- Statements concerning extra formal parameters, prior to the
7919 -- declaration of the actual parameter variables.
7921 Decls
: constant List_Id
:= New_List
;
7922 -- All the parameters will get declared before calling the real
7923 -- subprograms. Also the out parameters will be declared.
7924 -- At this level, parameters may be unconstrained.
7926 Statements
: constant List_Id
:= New_List
;
7928 After_Statements
: constant List_Id
:= New_List
;
7929 -- Statements to be executed after the subprogram call
7931 Inner_Decls
: List_Id
:= No_List
;
7932 -- In case of a function, the inner declarations are needed since
7933 -- the result may be unconstrained.
7935 Excep_Handlers
: List_Id
:= No_List
;
7937 Parameter_List
: constant List_Id
:= New_List
;
7938 -- List of parameters to be passed to the subprogram
7940 First_Controlling_Formal_Seen
: Boolean := False;
7942 Current_Parameter
: Node_Id
;
7944 Ordered_Parameters_List
: constant List_Id
:=
7945 Build_Ordered_Parameters_List
7946 (Specification
(Vis_Decl
));
7948 Arguments
: constant Entity_Id
:=
7949 Make_Defining_Identifier
(Loc
,
7950 New_Internal_Name
('A'));
7951 -- Name of the named values list used to retrieve parameters
7953 Subp_Spec
: Node_Id
;
7954 -- Subprogram specification
7956 Called_Subprogram
: Node_Id
;
7957 -- The subprogram to call
7960 if Present
(RACW_Type
) then
7961 Called_Subprogram
:=
7962 New_Occurrence_Of
(Parent_Primitive
, Loc
);
7964 Called_Subprogram
:=
7966 Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
7969 Declare_Create_NVList
(Loc
, Arguments
, Outer_Decls
, Outer_Statements
);
7971 -- Loop through every parameter and get its value from the stream. If
7972 -- the parameter is unconstrained, then the parameter is read using
7973 -- 'Input at the point of declaration.
7975 Current_Parameter
:= First
(Ordered_Parameters_List
);
7976 while Present
(Current_Parameter
) loop
7979 Constrained
: Boolean;
7980 Any
: Entity_Id
:= Empty
;
7981 Object
: constant Entity_Id
:=
7982 Make_Defining_Identifier
(Loc
,
7983 New_Internal_Name
('P'));
7984 Expr
: Node_Id
:= Empty
;
7986 Is_Controlling_Formal
: constant Boolean
7987 := Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
);
7989 Is_First_Controlling_Formal
: Boolean := False;
7991 Need_Extra_Constrained
: Boolean;
7992 -- True when an extra constrained actual is required
7995 if Is_Controlling_Formal
then
7997 -- Controlling formals in distributed object primitive
7998 -- operations are handled specially:
7999 -- - the first controlling formal is used as the
8000 -- target of the call;
8001 -- - the remaining controlling formals are transmitted
8005 Is_First_Controlling_Formal
:=
8006 not First_Controlling_Formal_Seen
;
8007 First_Controlling_Formal_Seen
:= True;
8009 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
8013 Is_Constrained
(Etyp
)
8014 or else Is_Elementary_Type
(Etyp
);
8016 if not Is_First_Controlling_Formal
then
8017 Any
:= Make_Defining_Identifier
(Loc
,
8018 New_Internal_Name
('A'));
8019 Append_To
(Outer_Decls
,
8020 Make_Object_Declaration
(Loc
,
8021 Defining_Identifier
=>
8023 Object_Definition
=>
8024 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8026 Make_Function_Call
(Loc
,
8028 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
8029 Parameter_Associations
=> New_List
(
8030 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
8031 Etyp
, Outer_Decls
)))));
8033 Append_To
(Outer_Statements
,
8034 Add_Parameter_To_NVList
(Loc
,
8035 Parameter
=> Current_Parameter
,
8036 NVList
=> Arguments
,
8037 Constrained
=> Constrained
,
8041 if Is_First_Controlling_Formal
then
8043 Addr
: constant Entity_Id
:=
8044 Make_Defining_Identifier
(Loc
,
8045 New_Internal_Name
('A'));
8046 Is_Local
: constant Entity_Id
:=
8047 Make_Defining_Identifier
(Loc
,
8048 New_Internal_Name
('L'));
8051 -- Special case: obtain the first controlling formal
8052 -- from the target of the remote call, instead of the
8055 Append_To
(Outer_Decls
,
8056 Make_Object_Declaration
(Loc
,
8057 Defining_Identifier
=>
8059 Object_Definition
=>
8060 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
8061 Append_To
(Outer_Decls
,
8062 Make_Object_Declaration
(Loc
,
8063 Defining_Identifier
=>
8065 Object_Definition
=>
8066 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
8067 Append_To
(Outer_Statements
,
8068 Make_Procedure_Call_Statement
(Loc
,
8071 RTE
(RE_Get_Local_Address
), Loc
),
8072 Parameter_Associations
=> New_List
(
8073 Make_Selected_Component
(Loc
,
8076 Request_Parameter
, Loc
),
8078 Make_Identifier
(Loc
, Name_Target
)),
8079 New_Occurrence_Of
(Is_Local
, Loc
),
8080 New_Occurrence_Of
(Addr
, Loc
))));
8082 Expr
:= Unchecked_Convert_To
(RACW_Type
,
8083 New_Occurrence_Of
(Addr
, Loc
));
8086 elsif In_Present
(Current_Parameter
)
8087 or else not Out_Present
(Current_Parameter
)
8088 or else not Constrained
8090 -- If an input parameter is constrained, then its reading is
8091 -- deferred until the beginning of the subprogram body. If
8092 -- it is unconstrained, then an expression is built for
8093 -- the object declaration and the variable is set using
8094 -- 'Input instead of 'Read.
8096 Expr
:= PolyORB_Support
.Helpers
.Build_From_Any_Call
(
8097 Etyp
, New_Occurrence_Of
(Any
, Loc
), Decls
);
8100 Append_To
(Statements
,
8101 Make_Assignment_Statement
(Loc
,
8103 New_Occurrence_Of
(Object
, Loc
),
8109 -- Expr will be used to initialize (and constrain) the
8110 -- parameter when it is declared.
8115 Need_Extra_Constrained
:=
8116 Nkind
(Parameter_Type
(Current_Parameter
)) /=
8119 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
8121 Present
(Extra_Constrained
8122 (Defining_Identifier
(Current_Parameter
)));
8124 -- We may not associate an extra constrained actual to a
8125 -- constant object, so if one is needed, declare the actual
8126 -- as a variable even if it won't be modified.
8128 Build_Actual_Object_Declaration
8131 Variable
=> Need_Extra_Constrained
8132 or else Out_Present
(Current_Parameter
),
8135 Set_Etype
(Object
, Etyp
);
8137 -- An out parameter may be written back using a 'Write
8138 -- attribute instead of a 'Output because it has been
8139 -- constrained by the parameter given to the caller. Note that
8140 -- out controlling arguments in the case of a RACW are not put
8141 -- back in the stream because the pointer on them has not
8144 if Out_Present
(Current_Parameter
)
8145 and then not Is_Controlling_Formal
8147 Append_To
(After_Statements
,
8148 Make_Procedure_Call_Statement
(Loc
,
8150 New_Occurrence_Of
(RTE
(RE_Move_Any_Value
), Loc
),
8151 Parameter_Associations
=> New_List
(
8152 New_Occurrence_Of
(Any
, Loc
),
8153 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
8154 New_Occurrence_Of
(Object
, Loc
),
8158 -- For RACW controlling formals, the Etyp of Object is always
8159 -- an RACW, even if the parameter is not of an anonymous access
8160 -- type. In such case, we need to dereference it at call time.
8162 if Is_Controlling_Formal
then
8163 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
8166 Append_To
(Parameter_List
,
8167 Make_Parameter_Association
(Loc
,
8170 Defining_Identifier
(Current_Parameter
), Loc
),
8171 Explicit_Actual_Parameter
=>
8172 Make_Explicit_Dereference
(Loc
,
8173 Unchecked_Convert_To
(RACW_Type
,
8174 OK_Convert_To
(RTE
(RE_Address
),
8175 New_Occurrence_Of
(Object
, Loc
))))));
8178 Append_To
(Parameter_List
,
8179 Make_Parameter_Association
(Loc
,
8182 Defining_Identifier
(Current_Parameter
), Loc
),
8183 Explicit_Actual_Parameter
=>
8184 Unchecked_Convert_To
(RACW_Type
,
8185 OK_Convert_To
(RTE
(RE_Address
),
8186 New_Occurrence_Of
(Object
, Loc
)))));
8190 Append_To
(Parameter_List
,
8191 Make_Parameter_Association
(Loc
,
8194 Defining_Identifier
(Current_Parameter
), Loc
),
8195 Explicit_Actual_Parameter
=>
8196 New_Occurrence_Of
(Object
, Loc
)));
8199 -- If the current parameter needs an extra formal, then read it
8200 -- from the stream and set the corresponding semantic field in
8201 -- the variable. If the kind of the parameter identifier is
8202 -- E_Void, then this is a compiler generated parameter that
8203 -- doesn't need an extra constrained status.
8205 -- The case of Extra_Accessibility should also be handled ???
8207 if Need_Extra_Constrained
then
8209 Extra_Parameter
: constant Entity_Id
:=
8211 (Defining_Identifier
8212 (Current_Parameter
));
8213 Extra_Any
: constant Entity_Id
:=
8214 Make_Defining_Identifier
8215 (Loc
, New_Internal_Name
('A'));
8217 Formal_Entity
: constant Entity_Id
:=
8218 Make_Defining_Identifier
8219 (Loc
, Chars
(Extra_Parameter
));
8221 Formal_Type
: constant Entity_Id
:=
8222 Etype
(Extra_Parameter
);
8224 Append_To
(Outer_Decls
,
8225 Make_Object_Declaration
(Loc
,
8226 Defining_Identifier
=>
8228 Object_Definition
=>
8229 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8231 Make_Function_Call
(Loc
,
8233 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
8234 Parameter_Associations
=> New_List
(
8235 PolyORB_Support
.Helpers
.Build_TypeCode_Call
8236 (Loc
, Formal_Type
, Outer_Decls
)))));
8238 Append_To
(Outer_Extra_Formal_Statements
,
8239 Add_Parameter_To_NVList
(Loc
,
8240 Parameter
=> Extra_Parameter
,
8241 NVList
=> Arguments
,
8242 Constrained
=> True,
8246 Make_Object_Declaration
(Loc
,
8247 Defining_Identifier
=> Formal_Entity
,
8248 Object_Definition
=>
8249 New_Occurrence_Of
(Formal_Type
, Loc
)));
8251 Append_To
(Statements
,
8252 Make_Assignment_Statement
(Loc
,
8254 New_Occurrence_Of
(Formal_Entity
, Loc
),
8256 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
8258 New_Occurrence_Of
(Extra_Any
, Loc
),
8260 Set_Extra_Constrained
(Object
, Formal_Entity
);
8265 Next
(Current_Parameter
);
8268 -- Extra Formals should go after all the other parameters
8270 Append_List_To
(Outer_Statements
, Outer_Extra_Formal_Statements
);
8272 Append_To
(Outer_Statements
,
8273 Make_Procedure_Call_Statement
(Loc
,
8275 New_Occurrence_Of
(RTE
(RE_Request_Arguments
), Loc
),
8276 Parameter_Associations
=> New_List
(
8277 New_Occurrence_Of
(Request_Parameter
, Loc
),
8278 New_Occurrence_Of
(Arguments
, Loc
))));
8280 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
8282 -- The remote subprogram is a function. We build an inner block to
8283 -- be able to hold a potentially unconstrained result in a
8287 Etyp
: constant Entity_Id
:=
8288 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
8289 Result
: constant Node_Id
:=
8290 Make_Defining_Identifier
(Loc
,
8291 New_Internal_Name
('R'));
8293 Inner_Decls
:= New_List
(
8294 Make_Object_Declaration
(Loc
,
8295 Defining_Identifier
=> Result
,
8296 Constant_Present
=> True,
8297 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
8299 Make_Function_Call
(Loc
,
8300 Name
=> Called_Subprogram
,
8301 Parameter_Associations
=> Parameter_List
)));
8303 if Is_Class_Wide_Type
(Etyp
) then
8305 -- For a remote call to a function with a class-wide type,
8306 -- check that the returned value satisfies the requirements
8309 Append_To
(Inner_Decls
,
8310 Make_Transportable_Check
(Loc
,
8311 New_Occurrence_Of
(Result
, Loc
)));
8315 Set_Etype
(Result
, Etyp
);
8316 Append_To
(After_Statements
,
8317 Make_Procedure_Call_Statement
(Loc
,
8319 New_Occurrence_Of
(RTE
(RE_Set_Result
), Loc
),
8320 Parameter_Associations
=> New_List
(
8321 New_Occurrence_Of
(Request_Parameter
, Loc
),
8322 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
8323 New_Occurrence_Of
(Result
, Loc
),
8325 -- A DSA function does not have out or inout arguments
8328 Append_To
(Statements
,
8329 Make_Block_Statement
(Loc
,
8330 Declarations
=> Inner_Decls
,
8331 Handled_Statement_Sequence
=>
8332 Make_Handled_Sequence_Of_Statements
(Loc
,
8333 Statements
=> After_Statements
)));
8336 -- The remote subprogram is a procedure. We do not need any inner
8337 -- block in this case. No specific processing is required here for
8338 -- the dynamically asynchronous case: the indication of whether
8339 -- call is asynchronous or not is managed by the Sync_Scope
8340 -- attibute of the request, and is handled entirely in the
8343 Append_To
(After_Statements
,
8344 Make_Procedure_Call_Statement
(Loc
,
8346 New_Occurrence_Of
(RTE
(RE_Request_Set_Out
), Loc
),
8347 Parameter_Associations
=> New_List
(
8348 New_Occurrence_Of
(Request_Parameter
, Loc
))));
8350 Append_To
(Statements
,
8351 Make_Procedure_Call_Statement
(Loc
,
8352 Name
=> Called_Subprogram
,
8353 Parameter_Associations
=> Parameter_List
));
8355 Append_List_To
(Statements
, After_Statements
);
8359 Make_Procedure_Specification
(Loc
,
8360 Defining_Unit_Name
=>
8361 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
8363 Parameter_Specifications
=> New_List
(
8364 Make_Parameter_Specification
(Loc
,
8365 Defining_Identifier
=> Request_Parameter
,
8367 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
8369 -- An exception raised during the execution of an incoming
8370 -- remote subprogram call and that needs to be sent back
8371 -- to the caller is propagated by the receiving stubs, and
8372 -- will be handled by the caller (the distribution runtime).
8374 if Asynchronous
and then not Dynamically_Asynchronous
then
8376 -- For an asynchronous procedure, add a null exception handler
8378 Excep_Handlers
:= New_List
(
8379 Make_Implicit_Exception_Handler
(Loc
,
8380 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8381 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
8385 -- In the other cases, if an exception is raised, then the
8386 -- exception occurrence is propagated.
8391 Append_To
(Outer_Statements
,
8392 Make_Block_Statement
(Loc
,
8395 Handled_Statement_Sequence
=>
8396 Make_Handled_Sequence_Of_Statements
(Loc
,
8397 Statements
=> Statements
)));
8400 Make_Subprogram_Body
(Loc
,
8401 Specification
=> Subp_Spec
,
8402 Declarations
=> Outer_Decls
,
8403 Handled_Statement_Sequence
=>
8404 Make_Handled_Sequence_Of_Statements
(Loc
,
8405 Statements
=> Outer_Statements
,
8406 Exception_Handlers
=> Excep_Handlers
));
8407 end Build_Subprogram_Receiving_Stubs
;
8413 package body Helpers
is
8415 -----------------------
8416 -- Local Subprograms --
8417 -----------------------
8419 function Find_Numeric_Representation
8420 (Typ
: Entity_Id
) return Entity_Id
;
8421 -- Given a numeric type Typ, return the smallest integer or floarting
8422 -- point type from Standard, or the smallest unsigned (modular) type
8423 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8425 function Make_Stream_Procedure_Function_Name
8428 Nam
: Name_Id
) return Entity_Id
;
8429 -- Return the name to be assigned for stream subprogram Nam of Typ.
8430 -- (copied from exp_strm.adb, should be shared???)
8432 ------------------------------------------------------------
8433 -- Common subprograms for building various tree fragments --
8434 ------------------------------------------------------------
8436 function Build_Get_Aggregate_Element
8440 Idx
: Node_Id
) return Node_Id
;
8441 -- Build a call to Get_Aggregate_Element on Any
8442 -- for typecode TC, returning the Idx'th element.
8445 Subprogram
: Entity_Id
;
8446 -- Reference location for constructed nodes
8449 -- For 'Range and Etype
8452 -- For the construction of the innermost element expression
8454 with procedure Add_Process_Element
8457 Counter
: Entity_Id
;
8460 procedure Append_Array_Traversal
8463 Counter
: Entity_Id
:= Empty
;
8465 -- Build nested loop statements that iterate over the elements of an
8466 -- array Arry. The statement(s) built by Add_Process_Element are
8467 -- executed for each element; Indices is the list of indices to be
8468 -- used in the construction of the indexed component that denotes the
8469 -- current element. Subprogram is the entity for the subprogram for
8470 -- which this iterator is generated. The generated statements are
8471 -- appended to Stmts.
8475 -- The record entity being dealt with
8477 with procedure Add_Process_Element
8479 Container
: Node_Or_Entity_Id
;
8480 Counter
: in out Int
;
8483 -- Rec is the instance of the record type, or Empty.
8484 -- Field is either the N_Defining_Identifier for a component,
8485 -- or an N_Variant_Part.
8487 procedure Append_Record_Traversal
8490 Container
: Node_Or_Entity_Id
;
8491 Counter
: in out Int
);
8492 -- Process component list Clist. Individual fields are passed
8493 -- to Field_Processing. Each variant part is also processed.
8494 -- Container is the outer Any (for From_Any/To_Any),
8495 -- the outer typecode (for TC) to which the operation applies.
8497 -----------------------------
8498 -- Append_Record_Traversal --
8499 -----------------------------
8501 procedure Append_Record_Traversal
8504 Container
: Node_Or_Entity_Id
;
8505 Counter
: in out Int
)
8509 -- Clist's Component_Items and Variant_Part
8519 CI
:= Component_Items
(Clist
);
8520 VP
:= Variant_Part
(Clist
);
8523 while Present
(Item
) loop
8524 Def
:= Defining_Identifier
(Item
);
8525 if not Is_Internal_Name
(Chars
(Def
)) then
8527 (Stmts
, Container
, Counter
, Rec
, Def
);
8532 if Present
(VP
) then
8533 Add_Process_Element
(Stmts
, Container
, Counter
, Rec
, VP
);
8535 end Append_Record_Traversal
;
8537 -------------------------
8538 -- Build_From_Any_Call --
8539 -------------------------
8541 function Build_From_Any_Call
8544 Decls
: List_Id
) return Node_Id
8546 Loc
: constant Source_Ptr
:= Sloc
(N
);
8548 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
8550 Fnam
: Entity_Id
:= Empty
;
8551 Lib_RE
: RE_Id
:= RE_Null
;
8555 -- First simple case where the From_Any function is present
8556 -- in the type's TSS.
8558 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_From_Any
);
8560 if Sloc
(U_Type
) <= Standard_Location
then
8561 U_Type
:= Base_Type
(U_Type
);
8564 -- Check first for Boolean and Character. These are enumeration
8565 -- types, but we treat them specially, since they may require
8566 -- special handling in the transfer protocol. However, this
8567 -- special handling only applies if they have standard
8568 -- representation, otherwise they are treated like any other
8569 -- enumeration type.
8571 if Present
(Fnam
) then
8574 elsif U_Type
= Standard_Boolean
then
8577 elsif U_Type
= Standard_Character
then
8580 elsif U_Type
= Standard_Wide_Character
then
8583 elsif U_Type
= Standard_Wide_Wide_Character
then
8584 Lib_RE
:= RE_FA_WWC
;
8586 -- Floating point types
8588 elsif U_Type
= Standard_Short_Float
then
8591 elsif U_Type
= Standard_Float
then
8594 elsif U_Type
= Standard_Long_Float
then
8597 elsif U_Type
= Standard_Long_Long_Float
then
8598 Lib_RE
:= RE_FA_LLF
;
8602 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
8603 Lib_RE
:= RE_FA_SSI
;
8605 elsif U_Type
= Etype
(Standard_Short_Integer
) then
8608 elsif U_Type
= Etype
(Standard_Integer
) then
8611 elsif U_Type
= Etype
(Standard_Long_Integer
) then
8614 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
8615 Lib_RE
:= RE_FA_LLI
;
8617 -- Unsigned integer types
8619 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
8620 Lib_RE
:= RE_FA_SSU
;
8622 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
8625 elsif U_Type
= RTE
(RE_Unsigned
) then
8628 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
8631 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
8632 Lib_RE
:= RE_FA_LLU
;
8634 elsif U_Type
= Standard_String
then
8635 Lib_RE
:= RE_FA_String
;
8637 -- Other (non-primitive) types
8643 Build_From_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
8644 Append_To
(Decls
, Decl
);
8648 -- Call the function
8650 if Lib_RE
/= RE_Null
then
8651 pragma Assert
(No
(Fnam
));
8652 Fnam
:= RTE
(Lib_RE
);
8656 Make_Function_Call
(Loc
,
8657 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
8658 Parameter_Associations
=> New_List
(N
));
8660 -- We must set the type of Result, so the unchecked conversion
8661 -- from the underlying type to the base type is properly done.
8663 Set_Etype
(Result
, U_Type
);
8665 return Unchecked_Convert_To
(Typ
, Result
);
8666 end Build_From_Any_Call
;
8668 -----------------------------
8669 -- Build_From_Any_Function --
8670 -----------------------------
8672 procedure Build_From_Any_Function
8676 Fnam
: out Entity_Id
)
8679 Decls
: constant List_Id
:= New_List
;
8680 Stms
: constant List_Id
:= New_List
;
8681 Any_Parameter
: constant Entity_Id
8682 := Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
8684 if Is_Itype
(Typ
) then
8685 Build_From_Any_Function
8693 Fnam
:= Make_Stream_Procedure_Function_Name
(Loc
,
8694 Typ
, Name_uFrom_Any
);
8697 Make_Function_Specification
(Loc
,
8698 Defining_Unit_Name
=> Fnam
,
8699 Parameter_Specifications
=> New_List
(
8700 Make_Parameter_Specification
(Loc
,
8701 Defining_Identifier
=>
8704 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
8705 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
8707 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8710 (not (Is_Remote_Access_To_Class_Wide_Type
(Typ
)));
8712 if Is_Derived_Type
(Typ
)
8713 and then not Is_Tagged_Type
(Typ
)
8716 Make_Simple_Return_Statement
(Loc
,
8720 Build_From_Any_Call
(
8722 New_Occurrence_Of
(Any_Parameter
, Loc
),
8725 elsif Is_Record_Type
(Typ
)
8726 and then not Is_Derived_Type
(Typ
)
8727 and then not Is_Tagged_Type
(Typ
)
8729 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
8731 Make_Simple_Return_Statement
(Loc
,
8735 Build_From_Any_Call
(
8737 New_Occurrence_Of
(Any_Parameter
, Loc
),
8741 Disc
: Entity_Id
:= Empty
;
8742 Discriminant_Associations
: List_Id
;
8743 Rdef
: constant Node_Id
:=
8744 Type_Definition
(Declaration_Node
(Typ
));
8745 Component_Counter
: Int
:= 0;
8747 -- The returned object
8749 Res
: constant Entity_Id
:=
8750 Make_Defining_Identifier
(Loc
,
8751 New_Internal_Name
('R'));
8753 Res_Definition
: Node_Id
:= New_Occurrence_Of
(Typ
, Loc
);
8755 procedure FA_Rec_Add_Process_Element
8758 Counter
: in out Int
;
8762 procedure FA_Append_Record_Traversal
is
8763 new Append_Record_Traversal
8765 Add_Process_Element
=> FA_Rec_Add_Process_Element
);
8767 --------------------------------
8768 -- FA_Rec_Add_Process_Element --
8769 --------------------------------
8771 procedure FA_Rec_Add_Process_Element
8774 Counter
: in out Int
;
8779 if Nkind
(Field
) = N_Defining_Identifier
then
8781 -- A regular component
8784 Make_Assignment_Statement
(Loc
,
8785 Name
=> Make_Selected_Component
(Loc
,
8787 New_Occurrence_Of
(Rec
, Loc
),
8789 New_Occurrence_Of
(Field
, Loc
)),
8791 Build_From_Any_Call
(Etype
(Field
),
8792 Build_Get_Aggregate_Element
(Loc
,
8794 Tc
=> Build_TypeCode_Call
(Loc
,
8795 Etype
(Field
), Decls
),
8796 Idx
=> Make_Integer_Literal
(Loc
,
8805 Struct_Counter
: Int
:= 0;
8807 Block_Decls
: constant List_Id
:= New_List
;
8808 Block_Stmts
: constant List_Id
:= New_List
;
8811 Alt_List
: constant List_Id
:= New_List
;
8812 Choice_List
: List_Id
;
8814 Struct_Any
: constant Entity_Id
:=
8815 Make_Defining_Identifier
(Loc
,
8816 New_Internal_Name
('S'));
8820 Make_Object_Declaration
(Loc
,
8821 Defining_Identifier
=>
8825 Object_Definition
=>
8826 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8828 Make_Function_Call
(Loc
,
8829 Name
=> New_Occurrence_Of
(
8830 RTE
(RE_Extract_Union_Value
), Loc
),
8831 Parameter_Associations
=> New_List
(
8832 Build_Get_Aggregate_Element
(Loc
,
8834 Tc
=> Make_Function_Call
(Loc
,
8835 Name
=> New_Occurrence_Of
(
8836 RTE
(RE_Any_Member_Type
), Loc
),
8837 Parameter_Associations
=>
8839 New_Occurrence_Of
(Any
, Loc
),
8840 Make_Integer_Literal
(Loc
,
8842 Idx
=> Make_Integer_Literal
(Loc
,
8846 Make_Block_Statement
(Loc
,
8849 Handled_Statement_Sequence
=>
8850 Make_Handled_Sequence_Of_Statements
(Loc
,
8851 Statements
=> Block_Stmts
)));
8853 Append_To
(Block_Stmts
,
8854 Make_Case_Statement
(Loc
,
8856 Make_Selected_Component
(Loc
,
8859 Chars
(Name
(Field
))),
8863 Variant
:= First_Non_Pragma
(Variants
(Field
));
8865 while Present
(Variant
) loop
8866 Choice_List
:= New_Copy_List_Tree
8867 (Discrete_Choices
(Variant
));
8869 VP_Stmts
:= New_List
;
8871 -- Struct_Counter should be reset before
8872 -- handling a variant part. Indeed only one
8873 -- of the case statement alternatives will be
8874 -- executed at run-time, so the counter must
8875 -- start at 0 for every case statement.
8877 Struct_Counter
:= 0;
8879 FA_Append_Record_Traversal
(
8881 Clist
=> Component_List
(Variant
),
8882 Container
=> Struct_Any
,
8883 Counter
=> Struct_Counter
);
8885 Append_To
(Alt_List
,
8886 Make_Case_Statement_Alternative
(Loc
,
8887 Discrete_Choices
=> Choice_List
,
8890 Next_Non_Pragma
(Variant
);
8894 Counter
:= Counter
+ 1;
8895 end FA_Rec_Add_Process_Element
;
8898 -- First all discriminants
8900 if Has_Discriminants
(Typ
) then
8901 Disc
:= First_Discriminant
(Typ
);
8902 Discriminant_Associations
:= New_List
;
8904 while Present
(Disc
) loop
8906 Disc_Var_Name
: constant Entity_Id
:=
8907 Make_Defining_Identifier
(Loc
, Chars
(Disc
));
8908 Disc_Type
: constant Entity_Id
:=
8912 Make_Object_Declaration
(Loc
,
8913 Defining_Identifier
=>
8915 Constant_Present
=> True,
8916 Object_Definition
=>
8917 New_Occurrence_Of
(Disc_Type
, Loc
),
8919 Build_From_Any_Call
(Disc_Type
,
8920 Build_Get_Aggregate_Element
(Loc
,
8921 Any
=> Any_Parameter
,
8922 Tc
=> Build_TypeCode_Call
8923 (Loc
, Disc_Type
, Decls
),
8924 Idx
=> Make_Integer_Literal
8925 (Loc
, Component_Counter
)),
8927 Component_Counter
:= Component_Counter
+ 1;
8929 Append_To
(Discriminant_Associations
,
8930 Make_Discriminant_Association
(Loc
,
8931 Selector_Names
=> New_List
(
8932 New_Occurrence_Of
(Disc
, Loc
)),
8934 New_Occurrence_Of
(Disc_Var_Name
, Loc
)));
8936 Next_Discriminant
(Disc
);
8939 Res_Definition
:= Make_Subtype_Indication
(Loc
,
8940 Subtype_Mark
=> Res_Definition
,
8942 Make_Index_Or_Discriminant_Constraint
(Loc
,
8943 Discriminant_Associations
));
8946 -- Now we have all the discriminants in variables, we can
8947 -- declared a constrained object. Note that we are not
8948 -- initializing (non-discriminant) components directly in
8949 -- the object declarations, because which fields to
8950 -- initialize depends (at run time) on the discriminant
8954 Make_Object_Declaration
(Loc
,
8955 Defining_Identifier
=>
8957 Object_Definition
=>
8960 -- ... then all components
8962 FA_Append_Record_Traversal
(Stms
,
8963 Clist
=> Component_List
(Rdef
),
8964 Container
=> Any_Parameter
,
8965 Counter
=> Component_Counter
);
8968 Make_Simple_Return_Statement
(Loc
,
8969 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
8973 elsif Is_Array_Type
(Typ
) then
8975 Constrained
: constant Boolean := Is_Constrained
(Typ
);
8977 procedure FA_Ary_Add_Process_Element
8980 Counter
: Entity_Id
;
8982 -- Assign the current element (as identified by Counter) of
8983 -- Any to the variable denoted by name Datum, and advance
8984 -- Counter by 1. If Datum is not an Any, a call to From_Any
8985 -- for its type is inserted.
8987 --------------------------------
8988 -- FA_Ary_Add_Process_Element --
8989 --------------------------------
8991 procedure FA_Ary_Add_Process_Element
8994 Counter
: Entity_Id
;
8997 Assignment
: constant Node_Id
:=
8998 Make_Assignment_Statement
(Loc
,
9000 Expression
=> Empty
);
9002 Element_Any
: Node_Id
;
9006 Element_TC
: Node_Id
;
9009 if Etype
(Datum
) = RTE
(RE_Any
) then
9011 -- When Datum is an Any the Etype field is not
9012 -- sufficient to determine the typecode of Datum
9013 -- (which can be a TC_SEQUENCE or TC_ARRAY
9014 -- depending on the value of Constrained).
9015 -- Therefore we retrieve the typecode which has
9016 -- been constructed in Append_Array_Traversal with
9017 -- a call to Get_Any_Type.
9020 Make_Function_Call
(Loc
,
9021 Name
=> New_Occurrence_Of
(
9022 RTE
(RE_Get_Any_Type
), Loc
),
9023 Parameter_Associations
=> New_List
(
9024 New_Occurrence_Of
(Entity
(Datum
), Loc
)));
9026 -- For non Any Datum we simply construct a typecode
9027 -- matching the Etype of the Datum.
9029 Element_TC
:= Build_TypeCode_Call
9030 (Loc
, Etype
(Datum
), Decls
);
9034 Build_Get_Aggregate_Element
(Loc
,
9037 Idx
=> New_Occurrence_Of
(Counter
, Loc
));
9040 -- Note: here we *prepend* statements to Stmts, so
9041 -- we must do it in reverse order.
9044 Make_Assignment_Statement
(Loc
,
9046 New_Occurrence_Of
(Counter
, Loc
),
9050 New_Occurrence_Of
(Counter
, Loc
),
9052 Make_Integer_Literal
(Loc
, 1))));
9054 if Nkind
(Datum
) /= N_Attribute_Reference
then
9056 -- We ignore the value of the length of each
9057 -- dimension, since the target array has already
9058 -- been constrained anyway.
9060 if Etype
(Datum
) /= RTE
(RE_Any
) then
9061 Set_Expression
(Assignment
,
9062 Build_From_Any_Call
(
9063 Component_Type
(Typ
),
9067 Set_Expression
(Assignment
, Element_Any
);
9069 Prepend_To
(Stmts
, Assignment
);
9071 end FA_Ary_Add_Process_Element
;
9073 Counter
: constant Entity_Id
:=
9074 Make_Defining_Identifier
(Loc
, Name_J
);
9076 Initial_Counter_Value
: Int
:= 0;
9078 Component_TC
: constant Entity_Id
:=
9079 Make_Defining_Identifier
(Loc
, Name_T
);
9081 Res
: constant Entity_Id
:=
9082 Make_Defining_Identifier
(Loc
, Name_R
);
9084 procedure Append_From_Any_Array_Iterator
is
9085 new Append_Array_Traversal
(
9088 Indices
=> New_List
,
9089 Add_Process_Element
=> FA_Ary_Add_Process_Element
);
9091 Res_Subtype_Indication
: Node_Id
:=
9092 New_Occurrence_Of
(Typ
, Loc
);
9095 if not Constrained
then
9097 Ndim
: constant Int
:= Number_Dimensions
(Typ
);
9100 Indx
: Node_Id
:= First_Index
(Typ
);
9103 Ranges
: constant List_Id
:= New_List
;
9106 for J
in 1 .. Ndim
loop
9107 Lnam
:= New_External_Name
('L', J
);
9108 Hnam
:= New_External_Name
('H', J
);
9109 Indt
:= Etype
(Indx
);
9112 Make_Object_Declaration
(Loc
,
9113 Defining_Identifier
=>
9114 Make_Defining_Identifier
(Loc
, Lnam
),
9117 Object_Definition
=>
9118 New_Occurrence_Of
(Indt
, Loc
),
9120 Build_From_Any_Call
(
9122 Build_Get_Aggregate_Element
(Loc
,
9123 Any
=> Any_Parameter
,
9124 Tc
=> Build_TypeCode_Call
(Loc
,
9126 Idx
=> Make_Integer_Literal
(Loc
, J
- 1)),
9130 Make_Object_Declaration
(Loc
,
9131 Defining_Identifier
=>
9132 Make_Defining_Identifier
(Loc
, Hnam
),
9135 Object_Definition
=>
9136 New_Occurrence_Of
(Indt
, Loc
),
9137 Expression
=> Make_Attribute_Reference
(Loc
,
9139 New_Occurrence_Of
(Indt
, Loc
),
9140 Attribute_Name
=> Name_Val
,
9141 Expressions
=> New_List
(
9142 Make_Op_Subtract
(Loc
,
9147 Standard_Long_Integer
,
9148 Make_Identifier
(Loc
, Lnam
)),
9151 Standard_Long_Integer
,
9152 Make_Function_Call
(Loc
,
9153 Name
=> New_Occurrence_Of
(RTE
(
9154 RE_Get_Nested_Sequence_Length
9156 Parameter_Associations
=>
9159 Any_Parameter
, Loc
),
9160 Make_Integer_Literal
(Loc
,
9163 Make_Integer_Literal
(Loc
, 1))))));
9167 Low_Bound
=> Make_Identifier
(Loc
, Lnam
),
9168 High_Bound
=> Make_Identifier
(Loc
, Hnam
)));
9173 -- Now we have all the necessary bound information:
9174 -- apply the set of range constraints to the
9175 -- (unconstrained) nominal subtype of Res.
9177 Initial_Counter_Value
:= Ndim
;
9178 Res_Subtype_Indication
:= Make_Subtype_Indication
(Loc
,
9180 Res_Subtype_Indication
,
9182 Make_Index_Or_Discriminant_Constraint
(Loc
,
9183 Constraints
=> Ranges
));
9188 Make_Object_Declaration
(Loc
,
9189 Defining_Identifier
=> Res
,
9190 Object_Definition
=> Res_Subtype_Indication
));
9191 Set_Etype
(Res
, Typ
);
9194 Make_Object_Declaration
(Loc
,
9195 Defining_Identifier
=> Counter
,
9196 Object_Definition
=>
9197 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
9199 Make_Integer_Literal
(Loc
, Initial_Counter_Value
)));
9202 Make_Object_Declaration
(Loc
,
9203 Defining_Identifier
=> Component_TC
,
9204 Constant_Present
=> True,
9205 Object_Definition
=>
9206 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
),
9208 Build_TypeCode_Call
(Loc
,
9209 Component_Type
(Typ
), Decls
)));
9211 Append_From_Any_Array_Iterator
(Stms
,
9212 Any_Parameter
, Counter
);
9215 Make_Simple_Return_Statement
(Loc
,
9216 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
9219 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9221 Make_Simple_Return_Statement
(Loc
,
9223 Unchecked_Convert_To
(
9225 Build_From_Any_Call
(
9226 Find_Numeric_Representation
(Typ
),
9227 New_Occurrence_Of
(Any_Parameter
, Loc
),
9231 -- Default: type is represented as an opaque sequence of bytes
9234 Strm
: constant Entity_Id
:=
9235 Make_Defining_Identifier
(Loc
,
9236 Chars
=> New_Internal_Name
('S'));
9237 Res
: constant Entity_Id
:=
9238 Make_Defining_Identifier
(Loc
,
9239 Chars
=> New_Internal_Name
('R'));
9242 -- Strm : Buffer_Stream_Type;
9245 Make_Object_Declaration
(Loc
,
9246 Defining_Identifier
=>
9250 Object_Definition
=>
9251 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
9253 -- Allocate_Buffer (Strm);
9256 Make_Procedure_Call_Statement
(Loc
,
9258 New_Occurrence_Of
(RTE
(RE_Allocate_Buffer
), Loc
),
9259 Parameter_Associations
=> New_List
(
9260 New_Occurrence_Of
(Strm
, Loc
))));
9262 -- Any_To_BS (Strm, A);
9265 Make_Procedure_Call_Statement
(Loc
,
9267 New_Occurrence_Of
(RTE
(RE_Any_To_BS
), Loc
),
9268 Parameter_Associations
=> New_List
(
9269 New_Occurrence_Of
(Any_Parameter
, Loc
),
9270 New_Occurrence_Of
(Strm
, Loc
))));
9273 -- Res : constant T := T'Input (Strm);
9275 -- Release_Buffer (Strm);
9279 Append_To
(Stms
, Make_Block_Statement
(Loc
,
9280 Declarations
=> New_List
(
9281 Make_Object_Declaration
(Loc
,
9282 Defining_Identifier
=> Res
,
9283 Constant_Present
=> True,
9284 Object_Definition
=>
9285 New_Occurrence_Of
(Typ
, Loc
),
9287 Make_Attribute_Reference
(Loc
,
9288 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
9289 Attribute_Name
=> Name_Input
,
9290 Expressions
=> New_List
(
9291 Make_Attribute_Reference
(Loc
,
9292 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
9293 Attribute_Name
=> Name_Access
))))),
9295 Handled_Statement_Sequence
=>
9296 Make_Handled_Sequence_Of_Statements
(Loc
,
9297 Statements
=> New_List
(
9298 Make_Procedure_Call_Statement
(Loc
,
9300 New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
9301 Parameter_Associations
=>
9303 New_Occurrence_Of
(Strm
, Loc
))),
9304 Make_Simple_Return_Statement
(Loc
,
9305 Expression
=> New_Occurrence_Of
(Res
, Loc
))))));
9311 Make_Subprogram_Body
(Loc
,
9312 Specification
=> Spec
,
9313 Declarations
=> Decls
,
9314 Handled_Statement_Sequence
=>
9315 Make_Handled_Sequence_Of_Statements
(Loc
,
9316 Statements
=> Stms
));
9317 end Build_From_Any_Function
;
9319 ---------------------------------
9320 -- Build_Get_Aggregate_Element --
9321 ---------------------------------
9323 function Build_Get_Aggregate_Element
9327 Idx
: Node_Id
) return Node_Id
9330 return Make_Function_Call
(Loc
,
9333 RTE
(RE_Get_Aggregate_Element
), Loc
),
9334 Parameter_Associations
=> New_List
(
9335 New_Occurrence_Of
(Any
, Loc
),
9338 end Build_Get_Aggregate_Element
;
9340 -------------------------
9341 -- Build_Reposiroty_Id --
9342 -------------------------
9344 procedure Build_Name_And_Repository_Id
9346 Name_Str
: out String_Id
;
9347 Repo_Id_Str
: out String_Id
)
9351 Store_String_Chars
("DSA:");
9352 Get_Library_Unit_Name_String
(Scope
(E
));
9353 Store_String_Chars
(
9354 Name_Buffer
(Name_Buffer
'First
9355 .. Name_Buffer
'First + Name_Len
- 1));
9356 Store_String_Char
('.');
9357 Get_Name_String
(Chars
(E
));
9358 Store_String_Chars
(
9359 Name_Buffer
(Name_Buffer
'First
9360 .. Name_Buffer
'First + Name_Len
- 1));
9361 Store_String_Chars
(":1.0");
9362 Repo_Id_Str
:= End_String
;
9363 Name_Str
:= String_From_Name_Buffer
;
9364 end Build_Name_And_Repository_Id
;
9366 -----------------------
9367 -- Build_To_Any_Call --
9368 -----------------------
9370 function Build_To_Any_Call
9372 Decls
: List_Id
) return Node_Id
9374 Loc
: constant Source_Ptr
:= Sloc
(N
);
9376 Typ
: Entity_Id
:= Etype
(N
);
9379 Fnam
: Entity_Id
:= Empty
;
9380 Lib_RE
: RE_Id
:= RE_Null
;
9383 -- If N is a selected component, then maybe its Etype has not been
9384 -- set yet: try to use the Etype of the selector_name in that
9387 if No
(Typ
) and then Nkind
(N
) = N_Selected_Component
then
9388 Typ
:= Etype
(Selector_Name
(N
));
9390 pragma Assert
(Present
(Typ
));
9392 -- The full view, if Typ is private; the completion, if Typ is
9395 U_Type
:= Underlying_Type
(Typ
);
9397 -- First simple case where the To_Any function is present in the
9400 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_To_Any
);
9402 -- Check first for Boolean and Character. These are enumeration
9403 -- types, but we treat them specially, since they may require
9404 -- special handling in the transfer protocol. However, this
9405 -- special handling only applies if they have standard
9406 -- representation, otherwise they are treated like any other
9407 -- enumeration type.
9409 if Sloc
(U_Type
) <= Standard_Location
then
9410 U_Type
:= Base_Type
(U_Type
);
9413 if Present
(Fnam
) then
9416 elsif U_Type
= Standard_Boolean
then
9419 elsif U_Type
= Standard_Character
then
9422 elsif U_Type
= Standard_Wide_Character
then
9425 elsif U_Type
= Standard_Wide_Wide_Character
then
9426 Lib_RE
:= RE_TA_WWC
;
9428 -- Floating point types
9430 elsif U_Type
= Standard_Short_Float
then
9433 elsif U_Type
= Standard_Float
then
9436 elsif U_Type
= Standard_Long_Float
then
9439 elsif U_Type
= Standard_Long_Long_Float
then
9440 Lib_RE
:= RE_TA_LLF
;
9444 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
9445 Lib_RE
:= RE_TA_SSI
;
9447 elsif U_Type
= Etype
(Standard_Short_Integer
) then
9450 elsif U_Type
= Etype
(Standard_Integer
) then
9453 elsif U_Type
= Etype
(Standard_Long_Integer
) then
9456 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
9457 Lib_RE
:= RE_TA_LLI
;
9459 -- Unsigned integer types
9461 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
9462 Lib_RE
:= RE_TA_SSU
;
9464 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
9467 elsif U_Type
= RTE
(RE_Unsigned
) then
9470 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
9473 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
9474 Lib_RE
:= RE_TA_LLU
;
9476 elsif U_Type
= Standard_String
then
9477 Lib_RE
:= RE_TA_String
;
9479 elsif U_Type
= Underlying_Type
(RTE
(RE_TypeCode
)) then
9482 -- Other (non-primitive) types
9488 Build_To_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
9489 Append_To
(Decls
, Decl
);
9493 -- Call the function
9495 if Lib_RE
/= RE_Null
then
9496 pragma Assert
(No
(Fnam
));
9497 Fnam
:= RTE
(Lib_RE
);
9501 Make_Function_Call
(Loc
,
9502 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
9503 Parameter_Associations
=>
9504 New_List
(Unchecked_Convert_To
(U_Type
, N
)));
9505 end Build_To_Any_Call
;
9507 ---------------------------
9508 -- Build_To_Any_Function --
9509 ---------------------------
9511 procedure Build_To_Any_Function
9515 Fnam
: out Entity_Id
)
9518 Decls
: constant List_Id
:= New_List
;
9519 Stms
: constant List_Id
:= New_List
;
9521 Expr_Parameter
: constant Entity_Id
:=
9522 Make_Defining_Identifier
(Loc
, Name_E
);
9524 Any
: constant Entity_Id
:=
9525 Make_Defining_Identifier
(Loc
, Name_A
);
9528 Result_TC
: Node_Id
:= Build_TypeCode_Call
(Loc
, Typ
, Decls
);
9531 if Is_Itype
(Typ
) then
9532 Build_To_Any_Function
9540 Fnam
:= Make_Stream_Procedure_Function_Name
(Loc
,
9544 Make_Function_Specification
(Loc
,
9545 Defining_Unit_Name
=> Fnam
,
9546 Parameter_Specifications
=> New_List
(
9547 Make_Parameter_Specification
(Loc
,
9548 Defining_Identifier
=>
9551 New_Occurrence_Of
(Typ
, Loc
))),
9552 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9553 Set_Etype
(Expr_Parameter
, Typ
);
9556 Make_Object_Declaration
(Loc
,
9557 Defining_Identifier
=>
9559 Object_Definition
=>
9560 New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9562 if Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9564 Rt_Type
: constant Entity_Id
9566 Expr
: constant Node_Id
9569 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9571 Set_Expression
(Any_Decl
, Build_To_Any_Call
(Expr
, Decls
));
9574 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9575 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
9577 Rt_Type
: constant Entity_Id
9579 Expr
: constant Node_Id
9582 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9585 Set_Expression
(Any_Decl
,
9586 Build_To_Any_Call
(Expr
, Decls
));
9591 Disc
: Entity_Id
:= Empty
;
9592 Rdef
: constant Node_Id
:=
9593 Type_Definition
(Declaration_Node
(Typ
));
9595 Elements
: constant List_Id
:= New_List
;
9597 procedure TA_Rec_Add_Process_Element
9599 Container
: Node_Or_Entity_Id
;
9600 Counter
: in out Int
;
9604 procedure TA_Append_Record_Traversal
is
9605 new Append_Record_Traversal
9606 (Rec
=> Expr_Parameter
,
9607 Add_Process_Element
=> TA_Rec_Add_Process_Element
);
9609 --------------------------------
9610 -- TA_Rec_Add_Process_Element --
9611 --------------------------------
9613 procedure TA_Rec_Add_Process_Element
9615 Container
: Node_Or_Entity_Id
;
9616 Counter
: in out Int
;
9620 Field_Ref
: Node_Id
;
9623 if Nkind
(Field
) = N_Defining_Identifier
then
9625 -- A regular component
9627 Field_Ref
:= Make_Selected_Component
(Loc
,
9628 Prefix
=> New_Occurrence_Of
(Rec
, Loc
),
9629 Selector_Name
=> New_Occurrence_Of
(Field
, Loc
));
9630 Set_Etype
(Field_Ref
, Etype
(Field
));
9633 Make_Procedure_Call_Statement
(Loc
,
9636 RTE
(RE_Add_Aggregate_Element
), Loc
),
9637 Parameter_Associations
=> New_List
(
9638 New_Occurrence_Of
(Container
, Loc
),
9639 Build_To_Any_Call
(Field_Ref
, Decls
))));
9646 Struct_Counter
: Int
:= 0;
9648 Block_Decls
: constant List_Id
:= New_List
;
9649 Block_Stmts
: constant List_Id
:= New_List
;
9652 Alt_List
: constant List_Id
:= New_List
;
9653 Choice_List
: List_Id
;
9655 Union_Any
: constant Entity_Id
:=
9656 Make_Defining_Identifier
(Loc
,
9657 New_Internal_Name
('V'));
9659 Struct_Any
: constant Entity_Id
:=
9660 Make_Defining_Identifier
(Loc
,
9661 New_Internal_Name
('S'));
9663 function Make_Discriminant_Reference
9665 -- Build a selected component for the
9666 -- discriminant of this variant part.
9668 ---------------------------------
9669 -- Make_Discriminant_Reference --
9670 ---------------------------------
9672 function Make_Discriminant_Reference
9675 Nod
: constant Node_Id
:=
9676 Make_Selected_Component
(Loc
,
9679 Chars
(Name
(Field
)));
9681 Set_Etype
(Nod
, Etype
(Name
(Field
)));
9683 end Make_Discriminant_Reference
;
9687 Make_Block_Statement
(Loc
,
9690 Handled_Statement_Sequence
=>
9691 Make_Handled_Sequence_Of_Statements
(Loc
,
9692 Statements
=> Block_Stmts
)));
9694 -- Declare the Variant Part aggregate
9696 -- Knowing the position of this VP in
9697 -- the variant record, we can fetch the
9698 -- VP typecode from Container.
9700 Append_To
(Block_Decls
,
9701 Make_Object_Declaration
(Loc
,
9702 Defining_Identifier
=> Union_Any
,
9703 Object_Definition
=>
9704 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9706 Make_Function_Call
(Loc
,
9707 Name
=> New_Occurrence_Of
(
9708 RTE
(RE_Create_Any
), Loc
),
9709 Parameter_Associations
=> New_List
(
9710 Make_Function_Call
(Loc
,
9713 RTE
(RE_Any_Member_Type
), Loc
),
9714 Parameter_Associations
=> New_List
(
9715 New_Occurrence_Of
(Container
, Loc
),
9716 Make_Integer_Literal
(Loc
,
9719 -- Declare the inner struct aggregate
9720 -- (that will contain the components
9723 Append_To
(Block_Decls
,
9724 Make_Object_Declaration
(Loc
,
9725 Defining_Identifier
=> Struct_Any
,
9726 Object_Definition
=>
9727 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9729 Make_Function_Call
(Loc
,
9730 Name
=> New_Occurrence_Of
(
9731 RTE
(RE_Create_Any
), Loc
),
9732 Parameter_Associations
=> New_List
(
9733 Make_Function_Call
(Loc
,
9736 RTE
(RE_Any_Member_Type
), Loc
),
9737 Parameter_Associations
=> New_List
(
9738 New_Occurrence_Of
(Union_Any
, Loc
),
9739 Make_Integer_Literal
(Loc
,
9742 -- Construct a case statement that will choose
9743 -- the appropriate code at runtime depending on
9744 -- the discriminant.
9746 Append_To
(Block_Stmts
,
9747 Make_Case_Statement
(Loc
,
9749 Make_Discriminant_Reference
,
9753 Variant
:= First_Non_Pragma
(Variants
(Field
));
9754 while Present
(Variant
) loop
9755 Choice_List
:= New_Copy_List_Tree
9756 (Discrete_Choices
(Variant
));
9758 VP_Stmts
:= New_List
;
9760 -- Append discriminant value to union
9763 Append_To
(VP_Stmts
,
9764 Make_Procedure_Call_Statement
(Loc
,
9767 RTE
(RE_Add_Aggregate_Element
), Loc
),
9768 Parameter_Associations
=> New_List
(
9769 New_Occurrence_Of
(Union_Any
, Loc
),
9771 Make_Discriminant_Reference
,
9774 -- Populate inner struct aggregate
9776 -- Struct_Counter should be reset before
9777 -- handling a variant part. Indeed only one
9778 -- of the case statement alternatives will be
9779 -- executed at run-time, so the counter must
9780 -- start at 0 for every case statement.
9782 Struct_Counter
:= 0;
9784 TA_Append_Record_Traversal
(
9786 Clist
=> Component_List
(Variant
),
9787 Container
=> Struct_Any
,
9788 Counter
=> Struct_Counter
);
9790 -- Append inner struct to union aggregate
9792 Append_To
(VP_Stmts
,
9793 Make_Procedure_Call_Statement
(Loc
,
9796 RTE
(RE_Add_Aggregate_Element
), Loc
),
9797 Parameter_Associations
=> New_List
(
9798 New_Occurrence_Of
(Union_Any
, Loc
),
9799 New_Occurrence_Of
(Struct_Any
, Loc
))));
9801 -- Append union to outer aggregate
9803 Append_To
(VP_Stmts
,
9804 Make_Procedure_Call_Statement
(Loc
,
9807 RTE
(RE_Add_Aggregate_Element
), Loc
),
9808 Parameter_Associations
=> New_List
(
9809 New_Occurrence_Of
(Container
, Loc
),
9811 (Union_Any
, Loc
))));
9813 Append_To
(Alt_List
,
9814 Make_Case_Statement_Alternative
(Loc
,
9815 Discrete_Choices
=> Choice_List
,
9816 Statements
=> VP_Stmts
));
9818 Next_Non_Pragma
(Variant
);
9822 Counter
:= Counter
+ 1;
9823 end TA_Rec_Add_Process_Element
;
9826 -- Records are encoded in a TC_STRUCT aggregate:
9827 -- -- Outer aggregate (TC_STRUCT)
9828 -- | [discriminant1]
9829 -- | [discriminant2]
9836 -- A component can be a common component or a variant
9839 -- A variant part is encoded as a TC_UNION aggregate:
9840 -- -- Variant Part Aggregate (TC_UNION)
9841 -- | [discriminant choice for this Variant Part]
9843 -- | -- Inner struct (TC_STRUCT)
9848 -- Let's start by building the outer aggregate
9849 -- First we construct an Elements array containing all
9850 -- the discriminants.
9852 if Has_Discriminants
(Typ
) then
9853 Disc
:= First_Discriminant
(Typ
);
9855 while Present
(Disc
) loop
9858 Discriminant
: constant Entity_Id
:=
9859 Make_Selected_Component
(Loc
,
9860 Prefix
=> Expr_Parameter
,
9861 Selector_Name
=> Chars
(Disc
));
9863 Set_Etype
(Discriminant
, Etype
(Disc
));
9865 Append_To
(Elements
,
9866 Make_Component_Association
(Loc
,
9867 Choices
=> New_List
(
9868 Make_Integer_Literal
(Loc
, Counter
)),
9870 Build_To_Any_Call
(Discriminant
, Decls
)));
9872 Counter
:= Counter
+ 1;
9873 Next_Discriminant
(Disc
);
9877 -- If there are no discriminants, we declare an empty
9881 Dummy_Any
: constant Entity_Id
:=
9882 Make_Defining_Identifier
(Loc
,
9883 Chars
=> New_Internal_Name
('A'));
9887 Make_Object_Declaration
(Loc
,
9888 Defining_Identifier
=> Dummy_Any
,
9889 Object_Definition
=>
9890 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
9892 Append_To
(Elements
,
9893 Make_Component_Association
(Loc
,
9894 Choices
=> New_List
(
9897 Make_Integer_Literal
(Loc
, 1),
9899 Make_Integer_Literal
(Loc
, 0))),
9901 New_Occurrence_Of
(Dummy_Any
, Loc
)));
9905 -- We build the result aggregate with discriminants
9906 -- as the first elements.
9908 Set_Expression
(Any_Decl
,
9909 Make_Function_Call
(Loc
,
9910 Name
=> New_Occurrence_Of
(
9911 RTE
(RE_Any_Aggregate_Build
), Loc
),
9912 Parameter_Associations
=> New_List
(
9914 Make_Aggregate
(Loc
,
9915 Component_Associations
=> Elements
))));
9918 -- Then we append all the components to the result
9921 TA_Append_Record_Traversal
(Stms
,
9922 Clist
=> Component_List
(Rdef
),
9924 Counter
=> Counter
);
9928 elsif Is_Array_Type
(Typ
) then
9930 Constrained
: constant Boolean := Is_Constrained
(Typ
);
9932 procedure TA_Ary_Add_Process_Element
9935 Counter
: Entity_Id
;
9938 --------------------------------
9939 -- TA_Ary_Add_Process_Element --
9940 --------------------------------
9942 procedure TA_Ary_Add_Process_Element
9945 Counter
: Entity_Id
;
9948 pragma Warnings
(Off
);
9949 pragma Unreferenced
(Counter
);
9950 pragma Warnings
(On
);
9952 Element_Any
: Node_Id
;
9955 if Etype
(Datum
) = RTE
(RE_Any
) then
9956 Element_Any
:= Datum
;
9958 Element_Any
:= Build_To_Any_Call
(Datum
, Decls
);
9962 Make_Procedure_Call_Statement
(Loc
,
9963 Name
=> New_Occurrence_Of
(
9964 RTE
(RE_Add_Aggregate_Element
), Loc
),
9965 Parameter_Associations
=> New_List
(
9966 New_Occurrence_Of
(Any
, Loc
),
9968 end TA_Ary_Add_Process_Element
;
9970 procedure Append_To_Any_Array_Iterator
is
9971 new Append_Array_Traversal
(
9973 Arry
=> Expr_Parameter
,
9974 Indices
=> New_List
,
9975 Add_Process_Element
=> TA_Ary_Add_Process_Element
);
9980 Set_Expression
(Any_Decl
,
9981 Make_Function_Call
(Loc
,
9983 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
9984 Parameter_Associations
=> New_List
(Result_TC
)));
9987 if not Constrained
then
9988 Index
:= First_Index
(Typ
);
9989 for J
in 1 .. Number_Dimensions
(Typ
) loop
9991 Make_Procedure_Call_Statement
(Loc
,
9994 RTE
(RE_Add_Aggregate_Element
), Loc
),
9995 Parameter_Associations
=> New_List
(
9996 New_Occurrence_Of
(Any
, Loc
),
9998 OK_Convert_To
(Etype
(Index
),
9999 Make_Attribute_Reference
(Loc
,
10001 New_Occurrence_Of
(Expr_Parameter
, Loc
),
10002 Attribute_Name
=> Name_First
,
10003 Expressions
=> New_List
(
10004 Make_Integer_Literal
(Loc
, J
)))),
10006 Next_Index
(Index
);
10010 Append_To_Any_Array_Iterator
(Stms
, Any
);
10013 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
10014 Set_Expression
(Any_Decl
,
10015 Build_To_Any_Call
(
10017 Find_Numeric_Representation
(Typ
),
10018 New_Occurrence_Of
(Expr_Parameter
, Loc
)),
10022 -- Default: type is represented as an opaque sequence of bytes
10025 Strm
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
10026 New_Internal_Name
('S'));
10029 -- Strm : aliased Buffer_Stream_Type;
10032 Make_Object_Declaration
(Loc
,
10033 Defining_Identifier
=>
10037 Object_Definition
=>
10038 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
10040 -- Allocate_Buffer (Strm);
10043 Make_Procedure_Call_Statement
(Loc
,
10045 New_Occurrence_Of
(RTE
(RE_Allocate_Buffer
), Loc
),
10046 Parameter_Associations
=> New_List
(
10047 New_Occurrence_Of
(Strm
, Loc
))));
10049 -- T'Output (Strm'Access, E);
10052 Make_Attribute_Reference
(Loc
,
10053 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
10054 Attribute_Name
=> Name_Output
,
10055 Expressions
=> New_List
(
10056 Make_Attribute_Reference
(Loc
,
10057 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
10058 Attribute_Name
=> Name_Access
),
10059 New_Occurrence_Of
(Expr_Parameter
, Loc
))));
10061 -- BS_To_Any (Strm, A);
10064 Make_Procedure_Call_Statement
(Loc
,
10066 New_Occurrence_Of
(RTE
(RE_BS_To_Any
), Loc
),
10067 Parameter_Associations
=> New_List
(
10068 New_Occurrence_Of
(Strm
, Loc
),
10069 New_Occurrence_Of
(Any
, Loc
))));
10071 -- Release_Buffer (Strm);
10074 Make_Procedure_Call_Statement
(Loc
,
10076 New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
10077 Parameter_Associations
=> New_List
(
10078 New_Occurrence_Of
(Strm
, Loc
))));
10082 Append_To
(Decls
, Any_Decl
);
10084 if Present
(Result_TC
) then
10086 Make_Procedure_Call_Statement
(Loc
,
10087 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
10088 Parameter_Associations
=> New_List
(
10089 New_Occurrence_Of
(Any
, Loc
),
10094 Make_Simple_Return_Statement
(Loc
,
10095 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
10098 Make_Subprogram_Body
(Loc
,
10099 Specification
=> Spec
,
10100 Declarations
=> Decls
,
10101 Handled_Statement_Sequence
=>
10102 Make_Handled_Sequence_Of_Statements
(Loc
,
10103 Statements
=> Stms
));
10104 end Build_To_Any_Function
;
10106 -------------------------
10107 -- Build_TypeCode_Call --
10108 -------------------------
10110 function Build_TypeCode_Call
10113 Decls
: List_Id
) return Node_Id
10115 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
10116 -- The full view, if Typ is private; the completion,
10117 -- if Typ is incomplete.
10119 Fnam
: Entity_Id
:= Empty
;
10120 Lib_RE
: RE_Id
:= RE_Null
;
10125 -- Special case System.PolyORB.Interface.Any: its primitives have
10126 -- not been set yet, so can't call Find_Inherited_TSS.
10128 if Typ
= RTE
(RE_Any
) then
10129 Fnam
:= RTE
(RE_TC_Any
);
10132 -- First simple case where the TypeCode is present
10133 -- in the type's TSS.
10135 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_TypeCode
);
10139 if Sloc
(U_Type
) <= Standard_Location
then
10141 -- Do not try to build alias typecodes for subtypes from
10144 U_Type
:= Base_Type
(U_Type
);
10147 if U_Type
= Standard_Boolean
then
10150 elsif U_Type
= Standard_Character
then
10153 elsif U_Type
= Standard_Wide_Character
then
10154 Lib_RE
:= RE_TC_WC
;
10156 elsif U_Type
= Standard_Wide_Wide_Character
then
10157 Lib_RE
:= RE_TC_WWC
;
10159 -- Floating point types
10161 elsif U_Type
= Standard_Short_Float
then
10162 Lib_RE
:= RE_TC_SF
;
10164 elsif U_Type
= Standard_Float
then
10167 elsif U_Type
= Standard_Long_Float
then
10168 Lib_RE
:= RE_TC_LF
;
10170 elsif U_Type
= Standard_Long_Long_Float
then
10171 Lib_RE
:= RE_TC_LLF
;
10173 -- Integer types (walk back to the base type)
10175 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
10176 Lib_RE
:= RE_TC_SSI
;
10178 elsif U_Type
= Etype
(Standard_Short_Integer
) then
10179 Lib_RE
:= RE_TC_SI
;
10181 elsif U_Type
= Etype
(Standard_Integer
) then
10184 elsif U_Type
= Etype
(Standard_Long_Integer
) then
10185 Lib_RE
:= RE_TC_LI
;
10187 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
10188 Lib_RE
:= RE_TC_LLI
;
10190 -- Unsigned integer types
10192 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
10193 Lib_RE
:= RE_TC_SSU
;
10195 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
10196 Lib_RE
:= RE_TC_SU
;
10198 elsif U_Type
= RTE
(RE_Unsigned
) then
10201 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
10202 Lib_RE
:= RE_TC_LU
;
10204 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
10205 Lib_RE
:= RE_TC_LLU
;
10207 elsif U_Type
= Standard_String
then
10208 Lib_RE
:= RE_TC_String
;
10210 -- Other (non-primitive) types
10216 Build_TypeCode_Function
(Loc
, U_Type
, Decl
, Fnam
);
10217 Append_To
(Decls
, Decl
);
10221 if Lib_RE
/= RE_Null
then
10222 Fnam
:= RTE
(Lib_RE
);
10226 -- Call the function
10229 Make_Function_Call
(Loc
, Name
=> New_Occurrence_Of
(Fnam
, Loc
));
10231 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10233 Set_Etype
(Expr
, RTE
(RE_TypeCode
));
10236 end Build_TypeCode_Call
;
10238 -----------------------------
10239 -- Build_TypeCode_Function --
10240 -----------------------------
10242 procedure Build_TypeCode_Function
10245 Decl
: out Node_Id
;
10246 Fnam
: out Entity_Id
)
10249 Decls
: constant List_Id
:= New_List
;
10250 Stms
: constant List_Id
:= New_List
;
10252 TCNam
: constant Entity_Id
:=
10253 Make_Stream_Procedure_Function_Name
(Loc
,
10254 Typ
, Name_uTypeCode
);
10256 Parameters
: List_Id
;
10258 procedure Add_String_Parameter
10260 Parameter_List
: List_Id
);
10261 -- Add a literal for S to Parameters
10263 procedure Add_TypeCode_Parameter
10264 (TC_Node
: Node_Id
;
10265 Parameter_List
: List_Id
);
10266 -- Add the typecode for Typ to Parameters
10268 procedure Add_Long_Parameter
10269 (Expr_Node
: Node_Id
;
10270 Parameter_List
: List_Id
);
10271 -- Add a signed long integer expression to Parameters
10273 procedure Initialize_Parameter_List
10274 (Name_String
: String_Id
;
10275 Repo_Id_String
: String_Id
;
10276 Parameter_List
: out List_Id
);
10277 -- Return a list that contains the first two parameters
10278 -- for a parameterized typecode: name and repository id.
10280 function Make_Constructed_TypeCode
10282 Parameters
: List_Id
) return Node_Id
;
10283 -- Call TC_Build with the given kind and parameters
10285 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
);
10286 -- Make a return statement that calls TC_Build with the given
10287 -- typecode kind, and the constructed parameters list.
10289 procedure Return_Alias_TypeCode
(Base_TypeCode
: Node_Id
);
10290 -- Return a typecode that is a TC_Alias for the given typecode
10292 --------------------------
10293 -- Add_String_Parameter --
10294 --------------------------
10296 procedure Add_String_Parameter
10298 Parameter_List
: List_Id
)
10301 Append_To
(Parameter_List
,
10302 Make_Function_Call
(Loc
,
10304 New_Occurrence_Of
(RTE
(RE_TA_String
), Loc
),
10305 Parameter_Associations
=> New_List
(
10306 Make_String_Literal
(Loc
, S
))));
10307 end Add_String_Parameter
;
10309 ----------------------------
10310 -- Add_TypeCode_Parameter --
10311 ----------------------------
10313 procedure Add_TypeCode_Parameter
10314 (TC_Node
: Node_Id
;
10315 Parameter_List
: List_Id
)
10318 Append_To
(Parameter_List
,
10319 Make_Function_Call
(Loc
,
10321 New_Occurrence_Of
(RTE
(RE_TA_TC
), Loc
),
10322 Parameter_Associations
=> New_List
(
10324 end Add_TypeCode_Parameter
;
10326 ------------------------
10327 -- Add_Long_Parameter --
10328 ------------------------
10330 procedure Add_Long_Parameter
10331 (Expr_Node
: Node_Id
;
10332 Parameter_List
: List_Id
)
10335 Append_To
(Parameter_List
,
10336 Make_Function_Call
(Loc
,
10338 New_Occurrence_Of
(RTE
(RE_TA_LI
), Loc
),
10339 Parameter_Associations
=> New_List
(Expr_Node
)));
10340 end Add_Long_Parameter
;
10342 -------------------------------
10343 -- Initialize_Parameter_List --
10344 -------------------------------
10346 procedure Initialize_Parameter_List
10347 (Name_String
: String_Id
;
10348 Repo_Id_String
: String_Id
;
10349 Parameter_List
: out List_Id
)
10352 Parameter_List
:= New_List
;
10353 Add_String_Parameter
(Name_String
, Parameter_List
);
10354 Add_String_Parameter
(Repo_Id_String
, Parameter_List
);
10355 end Initialize_Parameter_List
;
10357 ---------------------------
10358 -- Return_Alias_TypeCode --
10359 ---------------------------
10361 procedure Return_Alias_TypeCode
10362 (Base_TypeCode
: Node_Id
)
10365 Add_TypeCode_Parameter
(Base_TypeCode
, Parameters
);
10366 Return_Constructed_TypeCode
(RTE
(RE_TC_Alias
));
10367 end Return_Alias_TypeCode
;
10369 -------------------------------
10370 -- Make_Constructed_TypeCode --
10371 -------------------------------
10373 function Make_Constructed_TypeCode
10375 Parameters
: List_Id
) return Node_Id
10377 Constructed_TC
: constant Node_Id
:=
10378 Make_Function_Call
(Loc
,
10380 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
10381 Parameter_Associations
=> New_List
(
10382 New_Occurrence_Of
(Kind
, Loc
),
10383 Make_Aggregate
(Loc
,
10384 Expressions
=> Parameters
)));
10386 Set_Etype
(Constructed_TC
, RTE
(RE_TypeCode
));
10387 return Constructed_TC
;
10388 end Make_Constructed_TypeCode
;
10390 ---------------------------------
10391 -- Return_Constructed_TypeCode --
10392 ---------------------------------
10394 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
) is
10397 Make_Simple_Return_Statement
(Loc
,
10399 Make_Constructed_TypeCode
(Kind
, Parameters
)));
10400 end Return_Constructed_TypeCode
;
10406 procedure TC_Rec_Add_Process_Element
10409 Counter
: in out Int
;
10413 procedure TC_Append_Record_Traversal
is
10414 new Append_Record_Traversal
(
10416 Add_Process_Element
=> TC_Rec_Add_Process_Element
);
10418 --------------------------------
10419 -- TC_Rec_Add_Process_Element --
10420 --------------------------------
10422 procedure TC_Rec_Add_Process_Element
10425 Counter
: in out Int
;
10429 pragma Warnings
(Off
);
10430 pragma Unreferenced
(Any
, Counter
, Rec
);
10431 pragma Warnings
(On
);
10434 if Nkind
(Field
) = N_Defining_Identifier
then
10436 -- A regular component
10438 Add_TypeCode_Parameter
(
10439 Build_TypeCode_Call
(Loc
, Etype
(Field
), Decls
), Params
);
10440 Get_Name_String
(Chars
(Field
));
10441 Add_String_Parameter
(String_From_Name_Buffer
, Params
);
10448 Discriminant_Type
: constant Entity_Id
:=
10449 Etype
(Name
(Field
));
10451 Is_Enum
: constant Boolean :=
10452 Is_Enumeration_Type
(Discriminant_Type
);
10454 Union_TC_Params
: List_Id
;
10456 U_Name
: constant Name_Id
:=
10457 New_External_Name
(Chars
(Typ
), 'V', -1);
10459 Name_Str
: String_Id
;
10460 Struct_TC_Params
: List_Id
;
10464 Default
: constant Node_Id
:=
10465 Make_Integer_Literal
(Loc
, -1);
10467 Dummy_Counter
: Int
:= 0;
10469 Choice_Index
: Int
:= 0;
10471 procedure Add_Params_For_Variant_Components
;
10472 -- Add a struct TypeCode and a corresponding member name
10473 -- to the union parameter list.
10475 -- Ordering of declarations is a complete mess in this
10476 -- area, it is supposed to be types/varibles, then
10477 -- subprogram specs, then subprogram bodies ???
10479 ---------------------------------------
10480 -- Add_Params_For_Variant_Components --
10481 ---------------------------------------
10483 procedure Add_Params_For_Variant_Components
10485 S_Name
: constant Name_Id
:=
10486 New_External_Name
(U_Name
, 'S', -1);
10489 Get_Name_String
(S_Name
);
10490 Name_Str
:= String_From_Name_Buffer
;
10491 Initialize_Parameter_List
10492 (Name_Str
, Name_Str
, Struct_TC_Params
);
10494 -- Build struct parameters
10496 TC_Append_Record_Traversal
(Struct_TC_Params
,
10497 Component_List
(Variant
),
10501 Add_TypeCode_Parameter
10502 (Make_Constructed_TypeCode
10503 (RTE
(RE_TC_Struct
), Struct_TC_Params
),
10506 Add_String_Parameter
(Name_Str
, Union_TC_Params
);
10507 end Add_Params_For_Variant_Components
;
10510 Get_Name_String
(U_Name
);
10511 Name_Str
:= String_From_Name_Buffer
;
10513 Initialize_Parameter_List
10514 (Name_Str
, Name_Str
, Union_TC_Params
);
10516 -- Add union in enclosing parameter list
10518 Add_TypeCode_Parameter
10519 (Make_Constructed_TypeCode
10520 (RTE
(RE_TC_Union
), Union_TC_Params
),
10523 Add_String_Parameter
(Name_Str
, Params
);
10525 -- Build union parameters
10527 Add_TypeCode_Parameter
10528 (Build_TypeCode_Call
10529 (Loc
, Discriminant_Type
, Decls
),
10532 Add_Long_Parameter
(Default
, Union_TC_Params
);
10534 Variant
:= First_Non_Pragma
(Variants
(Field
));
10535 while Present
(Variant
) loop
10536 Choice
:= First
(Discrete_Choices
(Variant
));
10537 while Present
(Choice
) loop
10538 case Nkind
(Choice
) is
10541 L
: constant Uint
:=
10542 Expr_Value
(Low_Bound
(Choice
));
10543 H
: constant Uint
:=
10544 Expr_Value
(High_Bound
(Choice
));
10546 -- 3.8.1(8) guarantees that the bounds of
10547 -- this range are static.
10554 Expr
:= New_Occurrence_Of
(
10555 Get_Enum_Lit_From_Pos
(
10556 Discriminant_Type
, J
, Loc
), Loc
);
10559 Make_Integer_Literal
(Loc
, J
);
10561 Append_To
(Union_TC_Params
,
10562 Build_To_Any_Call
(Expr
, Decls
));
10564 Add_Params_For_Variant_Components
;
10569 when N_Others_Choice
=>
10571 -- This variant possess a default choice.
10572 -- We must therefore set the default
10573 -- parameter to the current choice index. The
10574 -- default parameter is by construction the
10575 -- fourth in the Union_TC_Params list.
10578 Default_Node
: constant Node_Id
:=
10579 Pick
(Union_TC_Params
, 4);
10581 New_Default_Node
: constant Node_Id
:=
10582 Make_Function_Call
(Loc
,
10585 (RTE
(RE_TA_LI
), Loc
),
10586 Parameter_Associations
=>
10588 Make_Integer_Literal
10589 (Loc
, Choice_Index
)));
10595 Remove
(Default_Node
);
10598 -- Add a placeholder member label
10599 -- for the default case.
10600 -- It must be of the discriminant type.
10603 Exp
: constant Node_Id
:=
10604 Make_Attribute_Reference
(Loc
,
10605 Prefix
=> New_Occurrence_Of
10606 (Discriminant_Type
, Loc
),
10607 Attribute_Name
=> Name_First
);
10609 Set_Etype
(Exp
, Discriminant_Type
);
10610 Append_To
(Union_TC_Params
,
10611 Build_To_Any_Call
(Exp
, Decls
));
10614 Add_Params_For_Variant_Components
;
10618 -- Case of an explicit choice
10621 Exp
: constant Node_Id
:=
10622 New_Copy_Tree
(Choice
);
10624 Append_To
(Union_TC_Params
,
10625 Build_To_Any_Call
(Exp
, Decls
));
10628 Add_Params_For_Variant_Components
;
10631 Choice_Index
:= Choice_Index
+ 1;
10635 Next_Non_Pragma
(Variant
);
10640 end TC_Rec_Add_Process_Element
;
10642 Type_Name_Str
: String_Id
;
10643 Type_Repo_Id_Str
: String_Id
;
10646 if Is_Itype
(Typ
) then
10647 Build_TypeCode_Function
10649 Typ
=> Etype
(Typ
),
10658 Make_Function_Specification
(Loc
,
10659 Defining_Unit_Name
=> Fnam
,
10660 Parameter_Specifications
=> Empty_List
,
10661 Result_Definition
=>
10662 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
10664 Build_Name_And_Repository_Id
(Typ
,
10665 Name_Str
=> Type_Name_Str
, Repo_Id_Str
=> Type_Repo_Id_Str
);
10666 Initialize_Parameter_List
10667 (Type_Name_Str
, Type_Repo_Id_Str
, Parameters
);
10669 if Is_Derived_Type
(Typ
)
10670 and then not Is_Tagged_Type
(Typ
)
10672 Return_Alias_TypeCode
(
10673 Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10675 elsif Is_Integer_Type
(Typ
)
10676 or else Is_Unsigned_Type
(Typ
)
10678 Return_Alias_TypeCode
(
10679 Build_TypeCode_Call
(Loc
,
10680 Find_Numeric_Representation
(Typ
), Decls
));
10682 elsif Is_Record_Type
(Typ
)
10683 and then not Is_Tagged_Type
(Typ
)
10686 -- Record typecodes are encoded as follows:
10690 -- | [Repository Id]
10692 -- Then for each discriminant:
10694 -- | [Discriminant Type Code]
10695 -- | [Discriminant Name]
10698 -- Then for each component:
10700 -- | [Component Type Code]
10701 -- | [Component Name]
10704 -- Variants components type codes are encoded as follows:
10708 -- | [Repository Id]
10709 -- | [Discriminant Type Code]
10710 -- | [Index of Default Variant Part or -1 for no default]
10712 -- Then for each Variant Part :
10717 -- | | [Variant Part Name]
10718 -- | | [Variant Part Repository Id]
10720 -- | Then for each VP component:
10721 -- | | [VP component Typecode]
10722 -- | | [VP component Name]
10728 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
10729 Return_Alias_TypeCode
(
10730 Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10733 Disc
: Entity_Id
:= Empty
;
10734 Rdef
: constant Node_Id
:=
10735 Type_Definition
(Declaration_Node
(Typ
));
10736 Dummy_Counter
: Int
:= 0;
10738 -- Construct the discriminants typecodes
10740 if Has_Discriminants
(Typ
) then
10741 Disc
:= First_Discriminant
(Typ
);
10743 while Present
(Disc
) loop
10744 Add_TypeCode_Parameter
(
10745 Build_TypeCode_Call
(Loc
, Etype
(Disc
), Decls
),
10747 Get_Name_String
(Chars
(Disc
));
10748 Add_String_Parameter
(
10749 String_From_Name_Buffer
,
10751 Next_Discriminant
(Disc
);
10754 -- then the components typecodes
10756 TC_Append_Record_Traversal
10757 (Parameters
, Component_List
(Rdef
),
10758 Empty
, Dummy_Counter
);
10759 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10763 elsif Is_Array_Type
(Typ
) then
10765 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10766 Inner_TypeCode
: Node_Id
;
10767 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10768 Indx
: Node_Id
:= First_Index
(Typ
);
10771 Inner_TypeCode
:= Build_TypeCode_Call
(Loc
,
10772 Component_Type
(Typ
),
10775 for J
in 1 .. Ndim
loop
10776 if Constrained
then
10777 Inner_TypeCode
:= Make_Constructed_TypeCode
10778 (RTE
(RE_TC_Array
), New_List
(
10779 Build_To_Any_Call
(
10780 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10781 Make_Attribute_Reference
(Loc
,
10783 New_Occurrence_Of
(Typ
, Loc
),
10786 Expressions
=> New_List
(
10787 Make_Integer_Literal
(Loc
,
10790 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10793 -- Unconstrained case: add low bound for each
10796 Add_TypeCode_Parameter
10797 (Build_TypeCode_Call
(Loc
, Etype
(Indx
), Decls
),
10799 Get_Name_String
(New_External_Name
('L', J
));
10800 Add_String_Parameter
(
10801 String_From_Name_Buffer
,
10805 Inner_TypeCode
:= Make_Constructed_TypeCode
10806 (RTE
(RE_TC_Sequence
), New_List
(
10807 Build_To_Any_Call
(
10808 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10809 Make_Integer_Literal
(Loc
, 0)),
10811 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10815 if Constrained
then
10816 Return_Alias_TypeCode
(Inner_TypeCode
);
10818 Add_TypeCode_Parameter
(Inner_TypeCode
, Parameters
);
10820 Store_String_Char
('V');
10821 Add_String_Parameter
(End_String
, Parameters
);
10822 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10827 -- Default: type is represented as an opaque sequence of bytes
10829 Return_Alias_TypeCode
10830 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10834 Make_Subprogram_Body
(Loc
,
10835 Specification
=> Spec
,
10836 Declarations
=> Decls
,
10837 Handled_Statement_Sequence
=>
10838 Make_Handled_Sequence_Of_Statements
(Loc
,
10839 Statements
=> Stms
));
10840 end Build_TypeCode_Function
;
10842 ---------------------------------
10843 -- Find_Numeric_Representation --
10844 ---------------------------------
10846 function Find_Numeric_Representation
10847 (Typ
: Entity_Id
) return Entity_Id
10849 FST
: constant Entity_Id
:= First_Subtype
(Typ
);
10850 P_Size
: constant Uint
:= Esize
(FST
);
10853 if Is_Unsigned_Type
(Typ
) then
10854 if P_Size
<= Standard_Short_Short_Integer_Size
then
10855 return RTE
(RE_Short_Short_Unsigned
);
10857 elsif P_Size
<= Standard_Short_Integer_Size
then
10858 return RTE
(RE_Short_Unsigned
);
10860 elsif P_Size
<= Standard_Integer_Size
then
10861 return RTE
(RE_Unsigned
);
10863 elsif P_Size
<= Standard_Long_Integer_Size
then
10864 return RTE
(RE_Long_Unsigned
);
10867 return RTE
(RE_Long_Long_Unsigned
);
10870 elsif Is_Integer_Type
(Typ
) then
10871 if P_Size
<= Standard_Short_Short_Integer_Size
then
10872 return Standard_Short_Short_Integer
;
10874 elsif P_Size
<= Standard_Short_Integer_Size
then
10875 return Standard_Short_Integer
;
10877 elsif P_Size
<= Standard_Integer_Size
then
10878 return Standard_Integer
;
10880 elsif P_Size
<= Standard_Long_Integer_Size
then
10881 return Standard_Long_Integer
;
10884 return Standard_Long_Long_Integer
;
10887 elsif Is_Floating_Point_Type
(Typ
) then
10888 if P_Size
<= Standard_Short_Float_Size
then
10889 return Standard_Short_Float
;
10891 elsif P_Size
<= Standard_Float_Size
then
10892 return Standard_Float
;
10894 elsif P_Size
<= Standard_Long_Float_Size
then
10895 return Standard_Long_Float
;
10898 return Standard_Long_Long_Float
;
10902 raise Program_Error
;
10905 -- TBD: fixed point types???
10906 -- TBverified numeric types with a biased representation???
10908 end Find_Numeric_Representation
;
10910 ---------------------------
10911 -- Append_Array_Traversal --
10912 ---------------------------
10914 procedure Append_Array_Traversal
10917 Counter
: Entity_Id
:= Empty
;
10920 Loc
: constant Source_Ptr
:= Sloc
(Subprogram
);
10921 Typ
: constant Entity_Id
:= Etype
(Arry
);
10922 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10923 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10925 Inner_Any
, Inner_Counter
: Entity_Id
;
10927 Loop_Stm
: Node_Id
;
10928 Inner_Stmts
: constant List_Id
:= New_List
;
10931 if Depth
> Ndim
then
10933 -- Processing for one element of an array
10936 Element_Expr
: constant Node_Id
:=
10937 Make_Indexed_Component
(Loc
,
10938 New_Occurrence_Of
(Arry
, Loc
),
10942 Set_Etype
(Element_Expr
, Component_Type
(Typ
));
10943 Add_Process_Element
(Stmts
,
10945 Counter
=> Counter
,
10946 Datum
=> Element_Expr
);
10952 Append_To
(Indices
,
10953 Make_Identifier
(Loc
, New_External_Name
('L', Depth
)));
10955 if not Constrained
or else Depth
> 1 then
10956 Inner_Any
:= Make_Defining_Identifier
(Loc
,
10957 New_External_Name
('A', Depth
));
10958 Set_Etype
(Inner_Any
, RTE
(RE_Any
));
10960 Inner_Any
:= Empty
;
10963 if Present
(Counter
) then
10964 Inner_Counter
:= Make_Defining_Identifier
(Loc
,
10965 New_External_Name
('J', Depth
));
10967 Inner_Counter
:= Empty
;
10971 Loop_Any
: Node_Id
:= Inner_Any
;
10974 -- For the first dimension of a constrained array, we add
10975 -- elements directly in the corresponding Any; there is no
10976 -- intervening inner Any.
10978 if No
(Loop_Any
) then
10982 Append_Array_Traversal
(Inner_Stmts
,
10984 Counter
=> Inner_Counter
,
10985 Depth
=> Depth
+ 1);
10989 Make_Implicit_Loop_Statement
(Subprogram
,
10990 Iteration_Scheme
=>
10991 Make_Iteration_Scheme
(Loc
,
10992 Loop_Parameter_Specification
=>
10993 Make_Loop_Parameter_Specification
(Loc
,
10994 Defining_Identifier
=>
10995 Make_Defining_Identifier
(Loc
,
10996 Chars
=> New_External_Name
('L', Depth
)),
10998 Discrete_Subtype_Definition
=>
10999 Make_Attribute_Reference
(Loc
,
11000 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
11001 Attribute_Name
=> Name_Range
,
11003 Expressions
=> New_List
(
11004 Make_Integer_Literal
(Loc
, Depth
))))),
11005 Statements
=> Inner_Stmts
);
11008 Decls
: constant List_Id
:= New_List
;
11009 Dimen_Stmts
: constant List_Id
:= New_List
;
11010 Length_Node
: Node_Id
;
11012 Inner_Any_TypeCode
: constant Entity_Id
:=
11013 Make_Defining_Identifier
(Loc
,
11014 New_External_Name
('T', Depth
));
11016 Inner_Any_TypeCode_Expr
: Node_Id
;
11020 if Constrained
then
11021 Inner_Any_TypeCode_Expr
:=
11022 Make_Function_Call
(Loc
,
11024 New_Occurrence_Of
(RTE
(RE_Get_TC
), Loc
),
11025 Parameter_Associations
=> New_List
(
11026 New_Occurrence_Of
(Any
, Loc
)));
11028 Inner_Any_TypeCode_Expr
:=
11029 Make_Function_Call
(Loc
,
11031 New_Occurrence_Of
(RTE
(RE_Any_Member_Type
), Loc
),
11032 Parameter_Associations
=> New_List
(
11033 New_Occurrence_Of
(Any
, Loc
),
11034 Make_Integer_Literal
(Loc
, Ndim
)));
11037 Inner_Any_TypeCode_Expr
:=
11038 Make_Function_Call
(Loc
,
11040 New_Occurrence_Of
(RTE
(RE_Content_Type
), Loc
),
11041 Parameter_Associations
=> New_List
(
11042 Make_Identifier
(Loc
,
11043 New_External_Name
('T', Depth
- 1))));
11047 Make_Object_Declaration
(Loc
,
11048 Defining_Identifier
=> Inner_Any_TypeCode
,
11049 Constant_Present
=> True,
11050 Object_Definition
=> New_Occurrence_Of
(
11051 RTE
(RE_TypeCode
), Loc
),
11052 Expression
=> Inner_Any_TypeCode_Expr
));
11054 if Present
(Inner_Any
) then
11056 Make_Object_Declaration
(Loc
,
11057 Defining_Identifier
=> Inner_Any
,
11058 Object_Definition
=>
11059 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
11061 Make_Function_Call
(Loc
,
11063 New_Occurrence_Of
(
11064 RTE
(RE_Create_Any
), Loc
),
11065 Parameter_Associations
=> New_List
(
11066 New_Occurrence_Of
(Inner_Any_TypeCode
, Loc
)))));
11069 if Present
(Inner_Counter
) then
11071 Make_Object_Declaration
(Loc
,
11072 Defining_Identifier
=> Inner_Counter
,
11073 Object_Definition
=>
11074 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
11076 Make_Integer_Literal
(Loc
, 0)));
11079 if not Constrained
then
11080 Length_Node
:= Make_Attribute_Reference
(Loc
,
11081 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
11082 Attribute_Name
=> Name_Length
,
11084 New_List
(Make_Integer_Literal
(Loc
, Depth
)));
11085 Set_Etype
(Length_Node
, RTE
(RE_Long_Unsigned
));
11087 Add_Process_Element
(Dimen_Stmts
,
11088 Datum
=> Length_Node
,
11090 Counter
=> Inner_Counter
);
11093 -- Loop_Stm does appropriate processing for each element
11096 Append_To
(Dimen_Stmts
, Loop_Stm
);
11098 -- Link outer and inner any
11100 if Present
(Inner_Any
) then
11101 Add_Process_Element
(Dimen_Stmts
,
11103 Counter
=> Counter
,
11104 Datum
=> New_Occurrence_Of
(Inner_Any
, Loc
));
11108 Make_Block_Statement
(Loc
,
11111 Handled_Statement_Sequence
=>
11112 Make_Handled_Sequence_Of_Statements
(Loc
,
11113 Statements
=> Dimen_Stmts
)));
11115 end Append_Array_Traversal
;
11117 -----------------------------------------
11118 -- Make_Stream_Procedure_Function_Name --
11119 -----------------------------------------
11121 function Make_Stream_Procedure_Function_Name
11124 Nam
: Name_Id
) return Entity_Id
11127 -- For tagged types, we use a canonical name so that it matches
11128 -- the primitive spec. For all other cases, we use a serialized
11129 -- name so that multiple generations of the same procedure do not
11132 if Is_Tagged_Type
(Typ
) then
11133 return Make_Defining_Identifier
(Loc
, Nam
);
11135 return Make_Defining_Identifier
(Loc
,
11137 New_External_Name
(Nam
, ' ', Increment_Serial_Number
));
11139 end Make_Stream_Procedure_Function_Name
;
11142 -----------------------------------
11143 -- Reserve_NamingContext_Methods --
11144 -----------------------------------
11146 procedure Reserve_NamingContext_Methods
is
11147 Str_Resolve
: constant String := "resolve";
11149 Name_Buffer
(1 .. Str_Resolve
'Length) := Str_Resolve
;
11150 Name_Len
:= Str_Resolve
'Length;
11151 Overload_Counter_Table
.Set
(Name_Find
, 1);
11152 end Reserve_NamingContext_Methods
;
11154 end PolyORB_Support
;
11156 -------------------------------
11157 -- RACW_Type_Is_Asynchronous --
11158 -------------------------------
11160 procedure RACW_Type_Is_Asynchronous
(RACW_Type
: Entity_Id
) is
11161 Asynchronous_Flag
: constant Entity_Id
:=
11162 Asynchronous_Flags_Table
.Get
(RACW_Type
);
11164 Replace
(Expression
(Parent
(Asynchronous_Flag
)),
11165 New_Occurrence_Of
(Standard_True
, Sloc
(Asynchronous_Flag
)));
11166 end RACW_Type_Is_Asynchronous
;
11168 -------------------------
11169 -- RCI_Package_Locator --
11170 -------------------------
11172 function RCI_Package_Locator
11174 Package_Spec
: Node_Id
) return Node_Id
11177 Pkg_Name
: String_Id
;
11180 Get_Library_Unit_Name_String
(Package_Spec
);
11181 Pkg_Name
:= String_From_Name_Buffer
;
11183 Make_Package_Instantiation
(Loc
,
11184 Defining_Unit_Name
=>
11185 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
11187 New_Occurrence_Of
(RTE
(RE_RCI_Locator
), Loc
),
11188 Generic_Associations
=> New_List
(
11189 Make_Generic_Association
(Loc
,
11191 Make_Identifier
(Loc
, Name_RCI_Name
),
11192 Explicit_Generic_Actual_Parameter
=>
11193 Make_String_Literal
(Loc
,
11194 Strval
=> Pkg_Name
)),
11195 Make_Generic_Association
(Loc
,
11197 Make_Identifier
(Loc
, Name_Version
),
11198 Explicit_Generic_Actual_Parameter
=>
11199 Make_Attribute_Reference
(Loc
,
11201 New_Occurrence_Of
(Defining_Entity
(Package_Spec
), Loc
),
11205 RCI_Locator_Table
.Set
(Defining_Unit_Name
(Package_Spec
),
11206 Defining_Unit_Name
(Inst
));
11208 end RCI_Package_Locator
;
11210 -----------------------------------------------
11211 -- Remote_Types_Tagged_Full_View_Encountered --
11212 -----------------------------------------------
11214 procedure Remote_Types_Tagged_Full_View_Encountered
11215 (Full_View
: Entity_Id
)
11217 Stub_Elements
: constant Stub_Structure
:=
11218 Stubs_Table
.Get
(Full_View
);
11220 if Stub_Elements
/= Empty_Stub_Structure
then
11221 Add_RACW_Primitive_Declarations_And_Bodies
11223 Stub_Elements
.RPC_Receiver_Decl
,
11224 Stub_Elements
.Body_Decls
);
11226 end Remote_Types_Tagged_Full_View_Encountered
;
11228 -------------------
11229 -- Scope_Of_Spec --
11230 -------------------
11232 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
is
11233 Unit_Name
: Node_Id
;
11236 Unit_Name
:= Defining_Unit_Name
(Spec
);
11237 while Nkind
(Unit_Name
) /= N_Defining_Identifier
loop
11238 Unit_Name
:= Defining_Identifier
(Unit_Name
);
11244 ----------------------
11245 -- Set_Renaming_TSS --
11246 ----------------------
11248 procedure Set_Renaming_TSS
11251 TSS_Nam
: TSS_Name_Type
)
11253 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
11254 Spec
: constant Node_Id
:= Parent
(Nam
);
11256 TSS_Node
: constant Node_Id
:=
11257 Make_Subprogram_Renaming_Declaration
(Loc
,
11259 Copy_Specification
(Loc
,
11261 New_Name
=> Make_TSS_Name
(Typ
, TSS_Nam
)),
11262 Name
=> New_Occurrence_Of
(Nam
, Loc
));
11264 Snam
: constant Entity_Id
:=
11265 Defining_Unit_Name
(Specification
(TSS_Node
));
11268 if Nkind
(Spec
) = N_Function_Specification
then
11269 Set_Ekind
(Snam
, E_Function
);
11270 Set_Etype
(Snam
, Entity
(Result_Definition
(Spec
)));
11272 Set_Ekind
(Snam
, E_Procedure
);
11273 Set_Etype
(Snam
, Standard_Void_Type
);
11276 Set_TSS
(Typ
, Snam
);
11277 end Set_Renaming_TSS
;
11279 ----------------------------------------------
11280 -- Specific_Add_Obj_RPC_Receiver_Completion --
11281 ----------------------------------------------
11283 procedure Specific_Add_Obj_RPC_Receiver_Completion
11286 RPC_Receiver
: Entity_Id
;
11287 Stub_Elements
: Stub_Structure
) is
11289 case Get_PCS_Name
is
11290 when Name_PolyORB_DSA
=>
11291 PolyORB_Support
.Add_Obj_RPC_Receiver_Completion
(Loc
,
11292 Decls
, RPC_Receiver
, Stub_Elements
);
11294 GARLIC_Support
.Add_Obj_RPC_Receiver_Completion
(Loc
,
11295 Decls
, RPC_Receiver
, Stub_Elements
);
11297 end Specific_Add_Obj_RPC_Receiver_Completion
;
11299 --------------------------------
11300 -- Specific_Add_RACW_Features --
11301 --------------------------------
11303 procedure Specific_Add_RACW_Features
11304 (RACW_Type
: Entity_Id
;
11306 Stub_Type
: Entity_Id
;
11307 Stub_Type_Access
: Entity_Id
;
11308 RPC_Receiver_Decl
: Node_Id
;
11309 Body_Decls
: List_Id
) is
11311 case Get_PCS_Name
is
11312 when Name_PolyORB_DSA
=>
11313 PolyORB_Support
.Add_RACW_Features
(
11322 GARLIC_Support
.Add_RACW_Features
(
11329 end Specific_Add_RACW_Features
;
11331 --------------------------------
11332 -- Specific_Add_RAST_Features --
11333 --------------------------------
11335 procedure Specific_Add_RAST_Features
11336 (Vis_Decl
: Node_Id
;
11337 RAS_Type
: Entity_Id
) is
11339 case Get_PCS_Name
is
11340 when Name_PolyORB_DSA
=>
11341 PolyORB_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
11343 GARLIC_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
11345 end Specific_Add_RAST_Features
;
11347 --------------------------------------------------
11348 -- Specific_Add_Receiving_Stubs_To_Declarations --
11349 --------------------------------------------------
11351 procedure Specific_Add_Receiving_Stubs_To_Declarations
11352 (Pkg_Spec
: Node_Id
;
11357 case Get_PCS_Name
is
11358 when Name_PolyORB_DSA
=>
11359 PolyORB_Support
.Add_Receiving_Stubs_To_Declarations
(
11360 Pkg_Spec
, Decls
, Stmts
);
11362 GARLIC_Support
.Add_Receiving_Stubs_To_Declarations
(
11363 Pkg_Spec
, Decls
, Stmts
);
11365 end Specific_Add_Receiving_Stubs_To_Declarations
;
11367 ------------------------------------------
11368 -- Specific_Build_General_Calling_Stubs --
11369 ------------------------------------------
11371 procedure Specific_Build_General_Calling_Stubs
11373 Statements
: List_Id
;
11374 Target
: RPC_Target
;
11375 Subprogram_Id
: Node_Id
;
11376 Asynchronous
: Node_Id
:= Empty
;
11377 Is_Known_Asynchronous
: Boolean := False;
11378 Is_Known_Non_Asynchronous
: Boolean := False;
11379 Is_Function
: Boolean;
11381 Stub_Type
: Entity_Id
:= Empty
;
11382 RACW_Type
: Entity_Id
:= Empty
;
11386 case Get_PCS_Name
is
11387 when Name_PolyORB_DSA
=>
11388 PolyORB_Support
.Build_General_Calling_Stubs
(
11394 Is_Known_Asynchronous
,
11395 Is_Known_Non_Asynchronous
,
11402 GARLIC_Support
.Build_General_Calling_Stubs
(
11406 Target
.RPC_Receiver
,
11409 Is_Known_Asynchronous
,
11410 Is_Known_Non_Asynchronous
,
11417 end Specific_Build_General_Calling_Stubs
;
11419 --------------------------------------
11420 -- Specific_Build_RPC_Receiver_Body --
11421 --------------------------------------
11423 procedure Specific_Build_RPC_Receiver_Body
11424 (RPC_Receiver
: Entity_Id
;
11425 Request
: out Entity_Id
;
11426 Subp_Id
: out Entity_Id
;
11427 Subp_Index
: out Entity_Id
;
11428 Stmts
: out List_Id
;
11429 Decl
: out Node_Id
)
11432 case Get_PCS_Name
is
11433 when Name_PolyORB_DSA
=>
11434 PolyORB_Support
.Build_RPC_Receiver_Body
11442 GARLIC_Support
.Build_RPC_Receiver_Body
11450 end Specific_Build_RPC_Receiver_Body
;
11452 --------------------------------
11453 -- Specific_Build_Stub_Target --
11454 --------------------------------
11456 function Specific_Build_Stub_Target
11459 RCI_Locator
: Entity_Id
;
11460 Controlling_Parameter
: Entity_Id
) return RPC_Target
11463 case Get_PCS_Name
is
11464 when Name_PolyORB_DSA
=>
11465 return PolyORB_Support
.Build_Stub_Target
(Loc
,
11466 Decls
, RCI_Locator
, Controlling_Parameter
);
11468 return GARLIC_Support
.Build_Stub_Target
(Loc
,
11469 Decls
, RCI_Locator
, Controlling_Parameter
);
11471 end Specific_Build_Stub_Target
;
11473 ------------------------------
11474 -- Specific_Build_Stub_Type --
11475 ------------------------------
11477 procedure Specific_Build_Stub_Type
11478 (RACW_Type
: Entity_Id
;
11479 Stub_Type
: Entity_Id
;
11480 Stub_Type_Decl
: out Node_Id
;
11481 RPC_Receiver_Decl
: out Node_Id
)
11484 case Get_PCS_Name
is
11485 when Name_PolyORB_DSA
=>
11486 PolyORB_Support
.Build_Stub_Type
(
11487 RACW_Type
, Stub_Type
,
11488 Stub_Type_Decl
, RPC_Receiver_Decl
);
11490 GARLIC_Support
.Build_Stub_Type
(
11491 RACW_Type
, Stub_Type
,
11492 Stub_Type_Decl
, RPC_Receiver_Decl
);
11494 end Specific_Build_Stub_Type
;
11496 function Specific_Build_Subprogram_Receiving_Stubs
11497 (Vis_Decl
: Node_Id
;
11498 Asynchronous
: Boolean;
11499 Dynamically_Asynchronous
: Boolean := False;
11500 Stub_Type
: Entity_Id
:= Empty
;
11501 RACW_Type
: Entity_Id
:= Empty
;
11502 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
11505 case Get_PCS_Name
is
11506 when Name_PolyORB_DSA
=>
11507 return PolyORB_Support
.Build_Subprogram_Receiving_Stubs
(
11510 Dynamically_Asynchronous
,
11515 return GARLIC_Support
.Build_Subprogram_Receiving_Stubs
(
11518 Dynamically_Asynchronous
,
11523 end Specific_Build_Subprogram_Receiving_Stubs
;
11525 --------------------------
11526 -- Underlying_RACW_Type --
11527 --------------------------
11529 function Underlying_RACW_Type
(RAS_Typ
: Entity_Id
) return Entity_Id
is
11530 Record_Type
: Entity_Id
;
11533 if Ekind
(RAS_Typ
) = E_Record_Type
then
11534 Record_Type
:= RAS_Typ
;
11536 pragma Assert
(Present
(Equivalent_Type
(RAS_Typ
)));
11537 Record_Type
:= Equivalent_Type
(RAS_Typ
);
11541 Etype
(Subtype_Indication
(
11542 Component_Definition
(
11543 First
(Component_Items
(Component_List
(
11544 Type_Definition
(Declaration_Node
(Record_Type
))))))));
11545 end Underlying_RACW_Type
;