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
;
880 pragma Warnings
(Off
, Subp_Str
);
883 -- The first thing added is an instantiation of the generic package
884 -- System.Partition_Interface.RCI_Locator with the name of this remote
885 -- package. This will act as an interface with the name server to
886 -- determine the Partition_ID and the RPC_Receiver for the receiver
889 RCI_Instantiation
:= RCI_Package_Locator
(Loc
, Pkg_Spec
);
890 RCI_Cache
:= Defining_Unit_Name
(RCI_Instantiation
);
892 Append_To
(Decls
, RCI_Instantiation
);
893 Analyze
(RCI_Instantiation
);
895 -- For each subprogram declaration visible in the spec, we do build a
896 -- body. We also increment a counter to assign a different Subprogram_Id
897 -- to each subprograms. The receiving stubs processing do use the same
898 -- mechanism and will thus assign the same Id and do the correct
901 Overload_Counter_Table
.Reset
;
902 PolyORB_Support
.Reserve_NamingContext_Methods
;
904 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
905 while Present
(Current_Declaration
) loop
906 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
907 and then Comes_From_Source
(Current_Declaration
)
909 Assign_Subprogram_Identifier
910 (Defining_Unit_Name
(Specification
(Current_Declaration
)),
911 Current_Subprogram_Number
,
915 Build_Subprogram_Calling_Stubs
(
916 Vis_Decl
=> Current_Declaration
,
918 Build_Subprogram_Id
(Loc
,
919 Defining_Unit_Name
(Specification
(Current_Declaration
))),
921 Nkind
(Specification
(Current_Declaration
)) =
922 N_Procedure_Specification
924 Is_Asynchronous
(Defining_Unit_Name
(Specification
925 (Current_Declaration
))));
927 Append_To
(Decls
, Subp_Stubs
);
928 Analyze
(Subp_Stubs
);
930 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
933 Next
(Current_Declaration
);
935 end Add_Calling_Stubs_To_Declarations
;
937 -----------------------------
938 -- Add_Parameter_To_NVList --
939 -----------------------------
941 function Add_Parameter_To_NVList
944 Parameter
: Entity_Id
;
945 Constrained
: Boolean;
946 RACW_Ctrl
: Boolean := False;
947 Any
: Entity_Id
) return Node_Id
949 Parameter_Name_String
: String_Id
;
950 Parameter_Mode
: Node_Id
;
952 function Parameter_Passing_Mode
954 Parameter
: Entity_Id
;
955 Constrained
: Boolean) return Node_Id
;
956 -- Return an expression that denotes the parameter passing mode to be
957 -- used for Parameter in distribution stubs, where Constrained is
958 -- Parameter's constrained status.
960 ----------------------------
961 -- Parameter_Passing_Mode --
962 ----------------------------
964 function Parameter_Passing_Mode
966 Parameter
: Entity_Id
;
967 Constrained
: Boolean) return Node_Id
972 if Out_Present
(Parameter
) then
973 if In_Present
(Parameter
)
974 or else not Constrained
976 -- Unconstrained formals must be translated
977 -- to 'in' or 'inout', not 'out', because
978 -- they need to be constrained by the actual.
980 Lib_RE
:= RE_Mode_Inout
;
982 Lib_RE
:= RE_Mode_Out
;
986 Lib_RE
:= RE_Mode_In
;
989 return New_Occurrence_Of
(RTE
(Lib_RE
), Loc
);
990 end Parameter_Passing_Mode
;
992 -- Start of processing for Add_Parameter_To_NVList
995 if Nkind
(Parameter
) = N_Defining_Identifier
then
996 Get_Name_String
(Chars
(Parameter
));
998 Get_Name_String
(Chars
(Defining_Identifier
(Parameter
)));
1001 Parameter_Name_String
:= String_From_Name_Buffer
;
1003 if RACW_Ctrl
or else Nkind
(Parameter
) = N_Defining_Identifier
then
1005 -- When the parameter passed to Add_Parameter_To_NVList is an
1006 -- Extra_Constrained parameter, Parameter is an N_Defining_
1007 -- Identifier, instead of a complete N_Parameter_Specification.
1008 -- Thus, we explicitly set 'in' mode in this case.
1010 Parameter_Mode
:= New_Occurrence_Of
(RTE
(RE_Mode_In
), Loc
);
1014 Parameter_Passing_Mode
(Loc
, Parameter
, Constrained
);
1018 Make_Procedure_Call_Statement
(Loc
,
1021 (RTE
(RE_NVList_Add_Item
), Loc
),
1022 Parameter_Associations
=> New_List
(
1023 New_Occurrence_Of
(NVList
, Loc
),
1024 Make_Function_Call
(Loc
,
1027 (RTE
(RE_To_PolyORB_String
), Loc
),
1028 Parameter_Associations
=> New_List
(
1029 Make_String_Literal
(Loc
,
1030 Strval
=> Parameter_Name_String
))),
1031 New_Occurrence_Of
(Any
, Loc
),
1033 end Add_Parameter_To_NVList
;
1035 --------------------------------
1036 -- Add_RACW_Asynchronous_Flag --
1037 --------------------------------
1039 procedure Add_RACW_Asynchronous_Flag
1040 (Declarations
: List_Id
;
1041 RACW_Type
: Entity_Id
)
1043 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1045 Asynchronous_Flag
: constant Entity_Id
:=
1046 Make_Defining_Identifier
(Loc
,
1047 New_External_Name
(Chars
(RACW_Type
), 'A'));
1050 -- Declare the asynchronous flag. This flag will be changed to True
1051 -- whenever it is known that the RACW type is asynchronous.
1053 Append_To
(Declarations
,
1054 Make_Object_Declaration
(Loc
,
1055 Defining_Identifier
=> Asynchronous_Flag
,
1056 Constant_Present
=> True,
1057 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
1058 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
1060 Asynchronous_Flags_Table
.Set
(RACW_Type
, Asynchronous_Flag
);
1061 end Add_RACW_Asynchronous_Flag
;
1063 -----------------------
1064 -- Add_RACW_Features --
1065 -----------------------
1067 procedure Add_RACW_Features
(RACW_Type
: Entity_Id
) is
1068 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
1069 Same_Scope
: constant Boolean := Scope
(Desig
) = Scope
(RACW_Type
);
1073 Body_Decls
: List_Id
;
1075 Stub_Type
: Entity_Id
;
1076 Stub_Type_Access
: Entity_Id
;
1077 RPC_Receiver_Decl
: Node_Id
;
1080 -- True when appropriate stubs have already been generated (this is the
1081 -- case when another RACW with the same designated type has already been
1082 -- encountered, in which case we reuse the previous stubs rather than
1083 -- generating new ones).
1086 if not Expander_Active
then
1090 -- Mark the current package declaration as containing an RACW, so that
1091 -- the bodies for the calling stubs and the RACW stream subprograms
1092 -- are attached to the tree when the corresponding body is encountered.
1094 Set_Has_RACW
(Current_Scope
);
1096 -- Look for place to declare the RACW stub type and RACW operations
1102 -- Case of declaring the RACW in the same package as its designated
1103 -- type: we know that the designated type is a private type, so we
1104 -- use the private declarations list.
1106 Pkg_Spec
:= Package_Specification_Of_Scope
(Current_Scope
);
1108 if Present
(Private_Declarations
(Pkg_Spec
)) then
1109 Decls
:= Private_Declarations
(Pkg_Spec
);
1111 Decls
:= Visible_Declarations
(Pkg_Spec
);
1116 -- Case of declaring the RACW in another package than its designated
1117 -- type: use the private declarations list if present; otherwise
1118 -- use the visible declarations.
1120 Decls
:= List_Containing
(Declaration_Node
(RACW_Type
));
1124 -- If we were unable to find the declarations, that means that the
1125 -- completion of the type was missing. We can safely return and let the
1126 -- error be caught by the semantic analysis.
1133 (Designated_Type
=> Desig
,
1134 RACW_Type
=> RACW_Type
,
1136 Stub_Type
=> Stub_Type
,
1137 Stub_Type_Access
=> Stub_Type_Access
,
1138 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1139 Body_Decls
=> Body_Decls
,
1140 Existing
=> Existing
);
1142 Add_RACW_Asynchronous_Flag
1143 (Declarations
=> Decls
,
1144 RACW_Type
=> RACW_Type
);
1146 Specific_Add_RACW_Features
1147 (RACW_Type
=> RACW_Type
,
1149 Stub_Type
=> Stub_Type
,
1150 Stub_Type_Access
=> Stub_Type_Access
,
1151 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1152 Body_Decls
=> Body_Decls
);
1154 if not Same_Scope
and then not Existing
then
1156 -- The RACW has been declared in another scope than the designated
1157 -- type and has not been handled by another RACW in the same package
1158 -- as the first one, so add primitives for the stub type here.
1160 Validate_RACW_Primitives
(RACW_Type
);
1161 Add_RACW_Primitive_Declarations_And_Bodies
1162 (Designated_Type
=> Desig
,
1163 Insertion_Node
=> RPC_Receiver_Decl
,
1164 Body_Decls
=> Body_Decls
);
1167 -- Validate_RACW_Primitives will be called when the designated type
1168 -- is frozen, see Exp_Ch3.Freeze_Type.
1170 -- ??? Shouldn't we have a pragma Assert (not Is_Frozen (Desig))?
1172 Add_Access_Type_To_Process
(E
=> Desig
, A
=> RACW_Type
);
1174 end Add_RACW_Features
;
1176 ------------------------------------------------
1177 -- Add_RACW_Primitive_Declarations_And_Bodies --
1178 ------------------------------------------------
1180 procedure Add_RACW_Primitive_Declarations_And_Bodies
1181 (Designated_Type
: Entity_Id
;
1182 Insertion_Node
: Node_Id
;
1183 Body_Decls
: List_Id
)
1185 Loc
: constant Source_Ptr
:= Sloc
(Insertion_Node
);
1186 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1187 -- the declarations are recognized as belonging to the current package.
1189 Stub_Elements
: constant Stub_Structure
:=
1190 Stubs_Table
.Get
(Designated_Type
);
1192 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
1194 Is_RAS
: constant Boolean :=
1195 not Comes_From_Source
(Stub_Elements
.RACW_Type
);
1196 -- Case of the RACW generated to implement a remote access-to-
1199 Build_Bodies
: constant Boolean :=
1200 In_Extended_Main_Code_Unit
(Stub_Elements
.Stub_Type
);
1201 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1202 -- only when the main unit is the unit that contains the stub type.
1204 Current_Insertion_Node
: Node_Id
:= Insertion_Node
;
1206 RPC_Receiver
: Entity_Id
;
1207 RPC_Receiver_Statements
: List_Id
;
1208 RPC_Receiver_Case_Alternatives
: constant List_Id
:= New_List
;
1209 RPC_Receiver_Elsif_Parts
: List_Id
;
1210 RPC_Receiver_Request
: Entity_Id
;
1211 RPC_Receiver_Subp_Id
: Entity_Id
;
1212 RPC_Receiver_Subp_Index
: Entity_Id
;
1214 Subp_Str
: String_Id
;
1216 Current_Primitive_Elmt
: Elmt_Id
;
1217 Current_Primitive
: Entity_Id
;
1218 Current_Primitive_Body
: Node_Id
;
1219 Current_Primitive_Spec
: Node_Id
;
1220 Current_Primitive_Decl
: Node_Id
;
1221 Current_Primitive_Number
: Int
:= 0;
1222 Current_Primitive_Alias
: Node_Id
;
1223 Current_Receiver
: Entity_Id
;
1224 Current_Receiver_Body
: Node_Id
;
1225 RPC_Receiver_Decl
: Node_Id
;
1226 Possibly_Asynchronous
: Boolean;
1229 if not Expander_Active
then
1235 Make_Defining_Identifier
(Loc
,
1236 Chars
=> New_Internal_Name
('P'));
1237 Specific_Build_RPC_Receiver_Body
1238 (RPC_Receiver
=> RPC_Receiver
,
1239 Request
=> RPC_Receiver_Request
,
1240 Subp_Id
=> RPC_Receiver_Subp_Id
,
1241 Subp_Index
=> RPC_Receiver_Subp_Index
,
1242 Stmts
=> RPC_Receiver_Statements
,
1243 Decl
=> RPC_Receiver_Decl
);
1245 if Get_PCS_Name
= Name_PolyORB_DSA
then
1247 -- For the case of PolyORB, we need to map a textual operation
1248 -- name into a primitive index. Currently we do so using a simple
1249 -- sequence of string comparisons.
1251 RPC_Receiver_Elsif_Parts
:= New_List
;
1255 -- Build callers, receivers for every primitive operations and a RPC
1256 -- receiver for this type.
1258 if Present
(Primitive_Operations
(Designated_Type
)) then
1259 Overload_Counter_Table
.Reset
;
1261 Current_Primitive_Elmt
:=
1262 First_Elmt
(Primitive_Operations
(Designated_Type
));
1263 while Current_Primitive_Elmt
/= No_Elmt
loop
1264 Current_Primitive
:= Node
(Current_Primitive_Elmt
);
1266 -- Copy the primitive of all the parents, except predefined ones
1267 -- that are not remotely dispatching. Also omit hidden primitives
1268 -- (occurs in the case of primitives of interface progenitors
1269 -- other than immediate ancestors of the Designated_Type).
1271 if Chars
(Current_Primitive
) /= Name_uSize
1272 and then Chars
(Current_Primitive
) /= Name_uAlignment
1274 (Is_TSS
(Current_Primitive
, TSS_Deep_Finalize
) or else
1275 Is_TSS
(Current_Primitive
, TSS_Stream_Input
) or else
1276 Is_TSS
(Current_Primitive
, TSS_Stream_Output
) or else
1277 Is_TSS
(Current_Primitive
, TSS_Stream_Read
) or else
1278 Is_TSS
(Current_Primitive
, TSS_Stream_Write
))
1279 and then not Is_Hidden
(Current_Primitive
)
1281 -- The first thing to do is build an up-to-date copy of the
1282 -- spec with all the formals referencing Designated_Type
1283 -- transformed into formals referencing Stub_Type. Since this
1284 -- primitive may have been inherited, go back the alias chain
1285 -- until the real primitive has been found.
1287 Current_Primitive_Alias
:= Current_Primitive
;
1288 while Present
(Alias
(Current_Primitive_Alias
)) loop
1290 (Current_Primitive_Alias
1291 /= Alias
(Current_Primitive_Alias
));
1292 Current_Primitive_Alias
:= Alias
(Current_Primitive_Alias
);
1295 -- Copy the spec from the original declaration for the purpose
1296 -- of declaring an overriding subprogram: we need to replace
1297 -- the type of each controlling formal with Stub_Type. The
1298 -- primitive may have been declared for Designated_Type or
1299 -- inherited from some ancestor type for which we do not have
1300 -- an easily determined Entity_Id. We have no systematic way
1301 -- of knowing which type to substitute Stub_Type for. Instead,
1302 -- Copy_Specification relies on the flag Is_Controlling_Formal
1303 -- to determine which formals to change.
1305 Current_Primitive_Spec
:=
1306 Copy_Specification
(Loc
,
1307 Spec
=> Parent
(Current_Primitive_Alias
),
1308 Ctrl_Type
=> Stub_Elements
.Stub_Type
);
1310 Current_Primitive_Decl
:=
1311 Make_Subprogram_Declaration
(Loc
,
1312 Specification
=> Current_Primitive_Spec
);
1314 Insert_After_And_Analyze
(Current_Insertion_Node
,
1315 Current_Primitive_Decl
);
1316 Current_Insertion_Node
:= Current_Primitive_Decl
;
1318 Possibly_Asynchronous
:=
1319 Nkind
(Current_Primitive_Spec
) = N_Procedure_Specification
1320 and then Could_Be_Asynchronous
(Current_Primitive_Spec
);
1322 Assign_Subprogram_Identifier
(
1323 Defining_Unit_Name
(Current_Primitive_Spec
),
1324 Current_Primitive_Number
,
1327 if Build_Bodies
then
1328 Current_Primitive_Body
:=
1329 Build_Subprogram_Calling_Stubs
1330 (Vis_Decl
=> Current_Primitive_Decl
,
1332 Build_Subprogram_Id
(Loc
,
1333 Defining_Unit_Name
(Current_Primitive_Spec
)),
1334 Asynchronous
=> Possibly_Asynchronous
,
1335 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1336 Stub_Type
=> Stub_Elements
.Stub_Type
,
1337 RACW_Type
=> Stub_Elements
.RACW_Type
);
1338 Append_To
(Body_Decls
, Current_Primitive_Body
);
1340 -- Analyzing the body here would cause the Stub type to
1341 -- be frozen, thus preventing subsequent primitive
1342 -- declarations. For this reason, it will be analyzed
1343 -- later in the regular flow (and in the context of the
1344 -- appropriate unit body, see Append_RACW_Bodies).
1348 -- Build the receiver stubs
1350 if Build_Bodies
and then not Is_RAS
then
1351 Current_Receiver_Body
:=
1352 Specific_Build_Subprogram_Receiving_Stubs
1353 (Vis_Decl
=> Current_Primitive_Decl
,
1354 Asynchronous
=> Possibly_Asynchronous
,
1355 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1356 Stub_Type
=> Stub_Elements
.Stub_Type
,
1357 RACW_Type
=> Stub_Elements
.RACW_Type
,
1358 Parent_Primitive
=> Current_Primitive
);
1360 Current_Receiver
:= Defining_Unit_Name
(
1361 Specification
(Current_Receiver_Body
));
1363 Append_To
(Body_Decls
, Current_Receiver_Body
);
1365 -- Add a case alternative to the receiver
1367 if Get_PCS_Name
= Name_PolyORB_DSA
then
1368 Append_To
(RPC_Receiver_Elsif_Parts
,
1369 Make_Elsif_Part
(Loc
,
1371 Make_Function_Call
(Loc
,
1374 RTE
(RE_Caseless_String_Eq
), Loc
),
1375 Parameter_Associations
=> New_List
(
1376 New_Occurrence_Of
(RPC_Receiver_Subp_Id
, Loc
),
1377 Make_String_Literal
(Loc
, Subp_Str
))),
1378 Then_Statements
=> New_List
(
1379 Make_Assignment_Statement
(Loc
,
1380 Name
=> New_Occurrence_Of
(
1381 RPC_Receiver_Subp_Index
, Loc
),
1383 Make_Integer_Literal
(Loc
,
1384 Current_Primitive_Number
)))));
1387 Append_To
(RPC_Receiver_Case_Alternatives
,
1388 Make_Case_Statement_Alternative
(Loc
,
1389 Discrete_Choices
=> New_List
(
1390 Make_Integer_Literal
(Loc
, Current_Primitive_Number
)),
1392 Statements
=> New_List
(
1393 Make_Procedure_Call_Statement
(Loc
,
1395 New_Occurrence_Of
(Current_Receiver
, Loc
),
1396 Parameter_Associations
=> New_List
(
1397 New_Occurrence_Of
(RPC_Receiver_Request
, Loc
))))));
1400 -- Increment the index of current primitive
1402 Current_Primitive_Number
:= Current_Primitive_Number
+ 1;
1405 Next_Elmt
(Current_Primitive_Elmt
);
1409 -- Build the case statement and the heart of the subprogram
1411 if Build_Bodies
and then not Is_RAS
then
1412 if Get_PCS_Name
= Name_PolyORB_DSA
1413 and then Present
(First
(RPC_Receiver_Elsif_Parts
))
1415 Append_To
(RPC_Receiver_Statements
,
1416 Make_Implicit_If_Statement
(Designated_Type
,
1417 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
1418 Then_Statements
=> New_List
,
1419 Elsif_Parts
=> RPC_Receiver_Elsif_Parts
));
1422 Append_To
(RPC_Receiver_Case_Alternatives
,
1423 Make_Case_Statement_Alternative
(Loc
,
1424 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1425 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
1427 Append_To
(RPC_Receiver_Statements
,
1428 Make_Case_Statement
(Loc
,
1430 New_Occurrence_Of
(RPC_Receiver_Subp_Index
, Loc
),
1431 Alternatives
=> RPC_Receiver_Case_Alternatives
));
1433 Append_To
(Body_Decls
, RPC_Receiver_Decl
);
1434 Specific_Add_Obj_RPC_Receiver_Completion
(Loc
,
1435 Body_Decls
, RPC_Receiver
, Stub_Elements
);
1437 -- Do not analyze RPC receiver body at this stage since it references
1438 -- subprograms that have not been analyzed yet. It will be analyzed in
1439 -- the regular flow (see Append_RACW_Bodies).
1442 end Add_RACW_Primitive_Declarations_And_Bodies
;
1444 -----------------------------
1445 -- Add_RAS_Dereference_TSS --
1446 -----------------------------
1448 procedure Add_RAS_Dereference_TSS
(N
: Node_Id
) is
1449 Loc
: constant Source_Ptr
:= Sloc
(N
);
1451 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
1452 RAS_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
1453 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(RAS_Type
);
1454 RACW_Type
: constant Entity_Id
:= Underlying_RACW_Type
(RAS_Type
);
1455 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
1457 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
1458 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
1460 RACW_Primitive_Name
: Node_Id
;
1462 Proc
: constant Entity_Id
:=
1463 Make_Defining_Identifier
(Loc
,
1464 Chars
=> Make_TSS_Name
(RAS_Type
, TSS_RAS_Dereference
));
1466 Proc_Spec
: Node_Id
;
1467 Param_Specs
: List_Id
;
1468 Param_Assoc
: constant List_Id
:= New_List
;
1469 Stmts
: constant List_Id
:= New_List
;
1471 RAS_Parameter
: constant Entity_Id
:=
1472 Make_Defining_Identifier
(Loc
,
1473 Chars
=> New_Internal_Name
('P'));
1475 Is_Function
: constant Boolean :=
1476 Nkind
(Type_Def
) = N_Access_Function_Definition
;
1478 Is_Degenerate
: Boolean;
1479 -- Set to True if the subprogram_specification for this RAS has an
1480 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1482 Spec
: constant Node_Id
:= Type_Def
;
1484 Current_Parameter
: Node_Id
;
1486 -- Start of processing for Add_RAS_Dereference_TSS
1489 -- The Dereference TSS for a remote access-to-subprogram type has the
1492 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1495 -- This is called whenever a value of a RAS type is dereferenced
1497 -- First construct a list of parameter specifications:
1499 -- The first formal is the RAS values
1501 Param_Specs
:= New_List
(
1502 Make_Parameter_Specification
(Loc
,
1503 Defining_Identifier
=> RAS_Parameter
,
1506 New_Occurrence_Of
(Fat_Type
, Loc
)));
1508 -- The following formals are copied from the type declaration
1510 Is_Degenerate
:= False;
1511 Current_Parameter
:= First
(Parameter_Specifications
(Type_Def
));
1512 Parameters
: while Present
(Current_Parameter
) loop
1513 if Nkind
(Parameter_Type
(Current_Parameter
)) =
1516 Is_Degenerate
:= True;
1519 Append_To
(Param_Specs
,
1520 Make_Parameter_Specification
(Loc
,
1521 Defining_Identifier
=>
1522 Make_Defining_Identifier
(Loc
,
1523 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))),
1524 In_Present
=> In_Present
(Current_Parameter
),
1525 Out_Present
=> Out_Present
(Current_Parameter
),
1527 New_Copy_Tree
(Parameter_Type
(Current_Parameter
)),
1529 New_Copy_Tree
(Expression
(Current_Parameter
))));
1531 Append_To
(Param_Assoc
,
1532 Make_Identifier
(Loc
,
1533 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))));
1535 Next
(Current_Parameter
);
1536 end loop Parameters
;
1538 if Is_Degenerate
then
1539 Prepend_To
(Param_Assoc
, New_Occurrence_Of
(RAS_Parameter
, Loc
));
1541 -- Generate a dummy body. This code will never actually be executed,
1542 -- because null is the only legal value for a degenerate RAS type.
1543 -- For legality's sake (in order to avoid generating a function that
1544 -- does not contain a return statement), we include a dummy recursive
1545 -- call on the TSS itself.
1548 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Explicit_Raise
));
1549 RACW_Primitive_Name
:= New_Occurrence_Of
(Proc
, Loc
);
1552 -- For a normal RAS type, we cast the RAS formal to the corresponding
1553 -- tagged type, and perform a dispatching call to its Call primitive
1556 Prepend_To
(Param_Assoc
,
1557 Unchecked_Convert_To
(RACW_Type
,
1558 New_Occurrence_Of
(RAS_Parameter
, Loc
)));
1560 RACW_Primitive_Name
:=
1561 Make_Selected_Component
(Loc
,
1562 Prefix
=> Scope
(RACW_Type
),
1563 Selector_Name
=> Name_uCall
);
1568 Make_Simple_Return_Statement
(Loc
,
1570 Make_Function_Call
(Loc
,
1571 Name
=> RACW_Primitive_Name
,
1572 Parameter_Associations
=> Param_Assoc
)));
1576 Make_Procedure_Call_Statement
(Loc
,
1577 Name
=> RACW_Primitive_Name
,
1578 Parameter_Associations
=> Param_Assoc
));
1581 -- Build the complete subprogram
1585 Make_Function_Specification
(Loc
,
1586 Defining_Unit_Name
=> Proc
,
1587 Parameter_Specifications
=> Param_Specs
,
1588 Result_Definition
=>
1590 Entity
(Result_Definition
(Spec
)), Loc
));
1592 Set_Ekind
(Proc
, E_Function
);
1594 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
1598 Make_Procedure_Specification
(Loc
,
1599 Defining_Unit_Name
=> Proc
,
1600 Parameter_Specifications
=> Param_Specs
);
1602 Set_Ekind
(Proc
, E_Procedure
);
1603 Set_Etype
(Proc
, Standard_Void_Type
);
1607 Make_Subprogram_Body
(Loc
,
1608 Specification
=> Proc_Spec
,
1609 Declarations
=> New_List
,
1610 Handled_Statement_Sequence
=>
1611 Make_Handled_Sequence_Of_Statements
(Loc
,
1612 Statements
=> Stmts
)));
1614 Set_TSS
(Fat_Type
, Proc
);
1615 end Add_RAS_Dereference_TSS
;
1617 -------------------------------
1618 -- Add_RAS_Proxy_And_Analyze --
1619 -------------------------------
1621 procedure Add_RAS_Proxy_And_Analyze
1624 All_Calls_Remote_E
: Entity_Id
;
1625 Proxy_Object_Addr
: out Entity_Id
)
1627 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
1629 Subp_Name
: constant Entity_Id
:=
1630 Defining_Unit_Name
(Specification
(Vis_Decl
));
1632 Pkg_Name
: constant Entity_Id
:=
1633 Make_Defining_Identifier
(Loc
,
1635 New_External_Name
(Chars
(Subp_Name
), 'P', -1));
1637 Proxy_Type
: constant Entity_Id
:=
1638 Make_Defining_Identifier
(Loc
,
1641 Related_Id
=> Chars
(Subp_Name
),
1644 Proxy_Type_Full_View
: constant Entity_Id
:=
1645 Make_Defining_Identifier
(Loc
,
1646 Chars
(Proxy_Type
));
1648 Subp_Decl_Spec
: constant Node_Id
:=
1649 Build_RAS_Primitive_Specification
1650 (Subp_Spec
=> Specification
(Vis_Decl
),
1651 Remote_Object_Type
=> Proxy_Type
);
1653 Subp_Body_Spec
: constant Node_Id
:=
1654 Build_RAS_Primitive_Specification
1655 (Subp_Spec
=> Specification
(Vis_Decl
),
1656 Remote_Object_Type
=> Proxy_Type
);
1658 Vis_Decls
: constant List_Id
:= New_List
;
1659 Pvt_Decls
: constant List_Id
:= New_List
;
1660 Actuals
: constant List_Id
:= New_List
;
1662 Perform_Call
: Node_Id
;
1665 -- type subpP is tagged limited private;
1667 Append_To
(Vis_Decls
,
1668 Make_Private_Type_Declaration
(Loc
,
1669 Defining_Identifier
=> Proxy_Type
,
1670 Tagged_Present
=> True,
1671 Limited_Present
=> True));
1673 -- [subprogram] Call
1674 -- (Self : access subpP;
1675 -- ...other-formals...)
1678 Append_To
(Vis_Decls
,
1679 Make_Subprogram_Declaration
(Loc
,
1680 Specification
=> Subp_Decl_Spec
));
1682 -- A : constant System.Address;
1684 Proxy_Object_Addr
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1686 Append_To
(Vis_Decls
,
1687 Make_Object_Declaration
(Loc
,
1688 Defining_Identifier
=>
1692 Object_Definition
=>
1693 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
1697 -- type subpP is tagged limited record
1698 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1702 Append_To
(Pvt_Decls
,
1703 Make_Full_Type_Declaration
(Loc
,
1704 Defining_Identifier
=>
1705 Proxy_Type_Full_View
,
1707 Build_Remote_Subprogram_Proxy_Type
(Loc
,
1708 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
))));
1710 -- Trick semantic analysis into swapping the public and full view when
1711 -- freezing the public view.
1713 Set_Comes_From_Source
(Proxy_Type_Full_View
, True);
1716 -- (Self : access O;
1717 -- ...other-formals...) is
1719 -- P (...other-formals...);
1723 -- (Self : access O;
1724 -- ...other-formals...)
1727 -- return F (...other-formals...);
1730 if Nkind
(Subp_Decl_Spec
) = N_Procedure_Specification
then
1732 Make_Procedure_Call_Statement
(Loc
,
1734 New_Occurrence_Of
(Subp_Name
, Loc
),
1735 Parameter_Associations
=>
1739 Make_Simple_Return_Statement
(Loc
,
1741 Make_Function_Call
(Loc
,
1743 New_Occurrence_Of
(Subp_Name
, Loc
),
1744 Parameter_Associations
=>
1748 Formal
:= First
(Parameter_Specifications
(Subp_Decl_Spec
));
1749 pragma Assert
(Present
(Formal
));
1752 exit when No
(Formal
);
1754 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1757 -- O : aliased subpP;
1759 Append_To
(Pvt_Decls
,
1760 Make_Object_Declaration
(Loc
,
1761 Defining_Identifier
=>
1762 Make_Defining_Identifier
(Loc
,
1766 Object_Definition
=>
1767 New_Occurrence_Of
(Proxy_Type
, Loc
)));
1769 -- A : constant System.Address := O'Address;
1771 Append_To
(Pvt_Decls
,
1772 Make_Object_Declaration
(Loc
,
1773 Defining_Identifier
=>
1774 Make_Defining_Identifier
(Loc
,
1775 Chars
(Proxy_Object_Addr
)),
1778 Object_Definition
=>
1779 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
1781 Make_Attribute_Reference
(Loc
,
1782 Prefix
=> New_Occurrence_Of
(
1783 Defining_Identifier
(Last
(Pvt_Decls
)), Loc
),
1788 Make_Package_Declaration
(Loc
,
1789 Specification
=> Make_Package_Specification
(Loc
,
1790 Defining_Unit_Name
=> Pkg_Name
,
1791 Visible_Declarations
=> Vis_Decls
,
1792 Private_Declarations
=> Pvt_Decls
,
1793 End_Label
=> Empty
)));
1794 Analyze
(Last
(Decls
));
1797 Make_Package_Body
(Loc
,
1798 Defining_Unit_Name
=>
1799 Make_Defining_Identifier
(Loc
,
1801 Declarations
=> New_List
(
1802 Make_Subprogram_Body
(Loc
,
1805 Declarations
=> New_List
,
1806 Handled_Statement_Sequence
=>
1807 Make_Handled_Sequence_Of_Statements
(Loc
,
1808 Statements
=> New_List
(Perform_Call
))))));
1809 Analyze
(Last
(Decls
));
1810 end Add_RAS_Proxy_And_Analyze
;
1812 -----------------------
1813 -- Add_RAST_Features --
1814 -----------------------
1816 procedure Add_RAST_Features
(Vis_Decl
: Node_Id
) is
1817 RAS_Type
: constant Entity_Id
:=
1818 Equivalent_Type
(Defining_Identifier
(Vis_Decl
));
1820 pragma Assert
(No
(TSS
(RAS_Type
, TSS_RAS_Access
)));
1821 Add_RAS_Dereference_TSS
(Vis_Decl
);
1822 Specific_Add_RAST_Features
(Vis_Decl
, RAS_Type
);
1823 end Add_RAST_Features
;
1829 procedure Add_Stub_Type
1830 (Designated_Type
: Entity_Id
;
1831 RACW_Type
: Entity_Id
;
1833 Stub_Type
: out Entity_Id
;
1834 Stub_Type_Access
: out Entity_Id
;
1835 RPC_Receiver_Decl
: out Node_Id
;
1836 Body_Decls
: out List_Id
;
1837 Existing
: out Boolean)
1839 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1841 Stub_Elements
: constant Stub_Structure
:=
1842 Stubs_Table
.Get
(Designated_Type
);
1843 Stub_Type_Decl
: Node_Id
;
1844 Stub_Type_Access_Decl
: Node_Id
;
1847 if Stub_Elements
/= Empty_Stub_Structure
then
1848 Stub_Type
:= Stub_Elements
.Stub_Type
;
1849 Stub_Type_Access
:= Stub_Elements
.Stub_Type_Access
;
1850 RPC_Receiver_Decl
:= Stub_Elements
.RPC_Receiver_Decl
;
1851 Body_Decls
:= Stub_Elements
.Body_Decls
;
1858 Make_Defining_Identifier
(Loc
,
1859 Chars
=> New_Internal_Name
('S'));
1861 Make_Defining_Identifier
(Loc
,
1862 Chars
=> New_External_Name
1863 (Related_Id
=> Chars
(Stub_Type
), Suffix
=> 'A'));
1865 Specific_Build_Stub_Type
1866 (RACW_Type
, Stub_Type
,
1867 Stub_Type_Decl
, RPC_Receiver_Decl
);
1869 Stub_Type_Access_Decl
:=
1870 Make_Full_Type_Declaration
(Loc
,
1871 Defining_Identifier
=> Stub_Type_Access
,
1873 Make_Access_To_Object_Definition
(Loc
,
1874 All_Present
=> True,
1875 Subtype_Indication
=> New_Occurrence_Of
(Stub_Type
, Loc
)));
1877 Append_To
(Decls
, Stub_Type_Decl
);
1878 Analyze
(Last
(Decls
));
1879 Append_To
(Decls
, Stub_Type_Access_Decl
);
1880 Analyze
(Last
(Decls
));
1882 -- This is in no way a type derivation, but we fake it to make sure that
1883 -- the dispatching table gets built with the corresponding primitive
1884 -- operations at the right place.
1886 Derive_Subprograms
(Parent_Type
=> Designated_Type
,
1887 Derived_Type
=> Stub_Type
);
1889 if Present
(RPC_Receiver_Decl
) then
1890 Append_To
(Decls
, RPC_Receiver_Decl
);
1892 RPC_Receiver_Decl
:= Last
(Decls
);
1895 Body_Decls
:= New_List
;
1897 Stubs_Table
.Set
(Designated_Type
,
1898 (Stub_Type
=> Stub_Type
,
1899 Stub_Type_Access
=> Stub_Type_Access
,
1900 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1901 Body_Decls
=> Body_Decls
,
1902 RACW_Type
=> RACW_Type
));
1905 ------------------------
1906 -- Append_RACW_Bodies --
1907 ------------------------
1909 procedure Append_RACW_Bodies
(Decls
: List_Id
; Spec_Id
: Entity_Id
) is
1912 E
:= First_Entity
(Spec_Id
);
1913 while Present
(E
) loop
1914 if Is_Remote_Access_To_Class_Wide_Type
(E
) then
1915 Append_List_To
(Decls
, Get_And_Reset_RACW_Bodies
(E
));
1920 end Append_RACW_Bodies
;
1922 ----------------------------------
1923 -- Assign_Subprogram_Identifier --
1924 ----------------------------------
1926 procedure Assign_Subprogram_Identifier
1931 N
: constant Name_Id
:= Chars
(Def
);
1933 Overload_Order
: constant Int
:=
1934 Overload_Counter_Table
.Get
(N
) + 1;
1937 Overload_Counter_Table
.Set
(N
, Overload_Order
);
1939 Get_Name_String
(N
);
1941 -- Homonym handling: as in Exp_Dbug, but much simpler,
1942 -- because the only entities for which we have to generate
1943 -- names here need only to be disambiguated within their
1946 if Overload_Order
> 1 then
1947 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 2) := "__";
1948 Name_Len
:= Name_Len
+ 2;
1949 Add_Nat_To_Name_Buffer
(Overload_Order
);
1952 Id
:= String_From_Name_Buffer
;
1953 Subprogram_Identifier_Table
.Set
(Def
,
1954 Subprogram_Identifiers
'(Str_Identifier => Id, Int_Identifier => Spn));
1955 end Assign_Subprogram_Identifier;
1957 -------------------------------------
1958 -- Build_Actual_Object_Declaration --
1959 -------------------------------------
1961 procedure Build_Actual_Object_Declaration
1962 (Object : Entity_Id;
1968 Loc : constant Source_Ptr := Sloc (Object);
1970 -- Declare a temporary object for the actual, possibly initialized with
1971 -- a 'Input
/From_Any call
.
1973 -- Complication arises in the case of limited types, for which such a
1974 -- declaration is illegal in Ada 95. In that case, we first generate a
1975 -- renaming declaration of the 'Input call, and then if needed we
1976 -- generate an overlaid non-constant view.
1978 if Ada_Version
<= Ada_95
1979 and then Is_Limited_Type
(Etyp
)
1980 and then Present
(Expr
)
1983 -- Object : Etyp renames <func-call>
1986 Make_Object_Renaming_Declaration
(Loc
,
1987 Defining_Identifier
=> Object
,
1988 Subtype_Mark
=> New_Occurrence_Of
(Etyp
, Loc
),
1993 -- The name defined by the renaming declaration denotes a
1994 -- constant view; create a non-constant object at the same address
1995 -- to be used as the actual.
1998 Constant_Object
: constant Entity_Id
:=
1999 Make_Defining_Identifier
(Loc
,
2000 New_Internal_Name
('P'));
2002 Set_Defining_Identifier
2003 (Last
(Decls
), Constant_Object
);
2005 -- We have an unconstrained Etyp: build the actual constrained
2006 -- subtype for the value we just read from the stream.
2008 -- suubtype S is <actual subtype of Constant_Object>;
2011 Build_Actual_Subtype
(Etyp
,
2012 New_Occurrence_Of
(Constant_Object
, Loc
)));
2017 Make_Object_Declaration
(Loc
,
2018 Defining_Identifier
=> Object
,
2019 Object_Definition
=>
2021 (Defining_Identifier
(Last
(Decls
)), Loc
)));
2022 Set_Ekind
(Object
, E_Variable
);
2024 -- Suppress default initialization:
2025 -- pragma Import (Ada, Object);
2029 Chars
=> Name_Import
,
2030 Pragma_Argument_Associations
=> New_List
(
2031 Make_Pragma_Argument_Association
(Loc
,
2032 Chars
=> Name_Convention
,
2033 Expression
=> Make_Identifier
(Loc
, Name_Ada
)),
2034 Make_Pragma_Argument_Association
(Loc
,
2035 Chars
=> Name_Entity
,
2036 Expression
=> New_Occurrence_Of
(Object
, Loc
)))));
2038 -- for Object'Address use Constant_Object'Address;
2041 Make_Attribute_Definition_Clause
(Loc
,
2042 Name
=> New_Occurrence_Of
(Object
, Loc
),
2043 Chars
=> Name_Address
,
2045 Make_Attribute_Reference
(Loc
,
2047 New_Occurrence_Of
(Constant_Object
, Loc
),
2055 -- General case of a regular object declaration. Object is flagged
2056 -- constant unless it has mode out or in out, to allow the backend
2057 -- to optimize where possible.
2059 -- Object : [constant] Etyp [:= <expr>];
2062 Make_Object_Declaration
(Loc
,
2063 Defining_Identifier
=> Object
,
2064 Constant_Present
=> Present
(Expr
) and then not Variable
,
2065 Object_Definition
=>
2066 New_Occurrence_Of
(Etyp
, Loc
),
2067 Expression
=> Expr
));
2069 if Constant_Present
(Last
(Decls
)) then
2070 Set_Ekind
(Object
, E_Constant
);
2072 Set_Ekind
(Object
, E_Variable
);
2075 end Build_Actual_Object_Declaration
;
2077 ------------------------------
2078 -- Build_Get_Unique_RP_Call --
2079 ------------------------------
2081 function Build_Get_Unique_RP_Call
2083 Pointer
: Entity_Id
;
2084 Stub_Type
: Entity_Id
) return List_Id
2088 Make_Procedure_Call_Statement
(Loc
,
2090 New_Occurrence_Of
(RTE
(RE_Get_Unique_Remote_Pointer
), Loc
),
2091 Parameter_Associations
=> New_List
(
2092 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2093 New_Occurrence_Of
(Pointer
, Loc
)))),
2095 Make_Assignment_Statement
(Loc
,
2097 Make_Selected_Component
(Loc
,
2099 New_Occurrence_Of
(Pointer
, Loc
),
2101 New_Occurrence_Of
(First_Tag_Component
2102 (Designated_Type
(Etype
(Pointer
))), Loc
)),
2104 Make_Attribute_Reference
(Loc
,
2106 New_Occurrence_Of
(Stub_Type
, Loc
),
2110 -- Note: The assignment to Pointer._Tag is safe here because
2111 -- we carefully ensured that Stub_Type has exactly the same layout
2112 -- as System.Partition_Interface.RACW_Stub_Type.
2114 end Build_Get_Unique_RP_Call
;
2116 -----------------------------------
2117 -- Build_Ordered_Parameters_List --
2118 -----------------------------------
2120 function Build_Ordered_Parameters_List
(Spec
: Node_Id
) return List_Id
is
2121 Constrained_List
: List_Id
;
2122 Unconstrained_List
: List_Id
;
2123 Current_Parameter
: Node_Id
;
2125 First_Parameter
: Node_Id
;
2126 For_RAS
: Boolean := False;
2129 if No
(Parameter_Specifications
(Spec
)) then
2133 Constrained_List
:= New_List
;
2134 Unconstrained_List
:= New_List
;
2135 First_Parameter
:= First
(Parameter_Specifications
(Spec
));
2137 if Nkind
(Parameter_Type
(First_Parameter
)) = N_Access_Definition
2138 and then Chars
(Defining_Identifier
(First_Parameter
)) = Name_uS
2143 -- Loop through the parameters and add them to the right list
2145 Current_Parameter
:= First_Parameter
;
2146 while Present
(Current_Parameter
) loop
2147 if (Nkind
(Parameter_Type
(Current_Parameter
)) = N_Access_Definition
2149 Is_Constrained
(Etype
(Parameter_Type
(Current_Parameter
)))
2151 Is_Elementary_Type
(Etype
(Parameter_Type
(Current_Parameter
))))
2152 and then not (For_RAS
and then Current_Parameter
= First_Parameter
)
2154 Append_To
(Constrained_List
, New_Copy
(Current_Parameter
));
2156 Append_To
(Unconstrained_List
, New_Copy
(Current_Parameter
));
2159 Next
(Current_Parameter
);
2162 -- Unconstrained parameters are returned first
2164 Append_List_To
(Unconstrained_List
, Constrained_List
);
2166 return Unconstrained_List
;
2167 end Build_Ordered_Parameters_List
;
2169 ----------------------------------
2170 -- Build_Passive_Partition_Stub --
2171 ----------------------------------
2173 procedure Build_Passive_Partition_Stub
(U
: Node_Id
) is
2175 Pkg_Name
: String_Id
;
2178 Loc
: constant Source_Ptr
:= Sloc
(U
);
2181 -- Verify that the implementation supports distribution, by accessing
2182 -- a type defined in the proper version of system.rpc
2185 Dist_OK
: Entity_Id
;
2186 pragma Warnings
(Off
, Dist_OK
);
2188 Dist_OK
:= RTE
(RE_Params_Stream_Type
);
2191 -- Use body if present, spec otherwise
2193 if Nkind
(U
) = N_Package_Declaration
then
2194 Pkg_Spec
:= Specification
(U
);
2195 L
:= Visible_Declarations
(Pkg_Spec
);
2197 Pkg_Spec
:= Parent
(Corresponding_Spec
(U
));
2198 L
:= Declarations
(U
);
2201 Get_Library_Unit_Name_String
(Pkg_Spec
);
2202 Pkg_Name
:= String_From_Name_Buffer
;
2204 Make_Procedure_Call_Statement
(Loc
,
2206 New_Occurrence_Of
(RTE
(RE_Register_Passive_Package
), Loc
),
2207 Parameter_Associations
=> New_List
(
2208 Make_String_Literal
(Loc
, Pkg_Name
),
2209 Make_Attribute_Reference
(Loc
,
2211 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
2216 end Build_Passive_Partition_Stub
;
2218 --------------------------------------
2219 -- Build_RPC_Receiver_Specification --
2220 --------------------------------------
2222 function Build_RPC_Receiver_Specification
2223 (RPC_Receiver
: Entity_Id
;
2224 Request_Parameter
: Entity_Id
) return Node_Id
2226 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
2229 Make_Procedure_Specification
(Loc
,
2230 Defining_Unit_Name
=> RPC_Receiver
,
2231 Parameter_Specifications
=> New_List
(
2232 Make_Parameter_Specification
(Loc
,
2233 Defining_Identifier
=> Request_Parameter
,
2235 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
2236 end Build_RPC_Receiver_Specification
;
2238 ----------------------------------------
2239 -- Build_Remote_Subprogram_Proxy_Type --
2240 ----------------------------------------
2242 function Build_Remote_Subprogram_Proxy_Type
2244 ACR_Expression
: Node_Id
) return Node_Id
2248 Make_Record_Definition
(Loc
,
2249 Tagged_Present
=> True,
2250 Limited_Present
=> True,
2252 Make_Component_List
(Loc
,
2254 Component_Items
=> New_List
(
2255 Make_Component_Declaration
(Loc
,
2256 Defining_Identifier
=>
2257 Make_Defining_Identifier
(Loc
,
2258 Name_All_Calls_Remote
),
2259 Component_Definition
=>
2260 Make_Component_Definition
(Loc
,
2261 Subtype_Indication
=>
2262 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
2266 Make_Component_Declaration
(Loc
,
2267 Defining_Identifier
=>
2268 Make_Defining_Identifier
(Loc
,
2270 Component_Definition
=>
2271 Make_Component_Definition
(Loc
,
2272 Subtype_Indication
=>
2273 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2275 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)),
2277 Make_Component_Declaration
(Loc
,
2278 Defining_Identifier
=>
2279 Make_Defining_Identifier
(Loc
,
2281 Component_Definition
=>
2282 Make_Component_Definition
(Loc
,
2283 Subtype_Indication
=>
2284 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))))));
2285 end Build_Remote_Subprogram_Proxy_Type
;
2287 ------------------------------------
2288 -- Build_Subprogram_Calling_Stubs --
2289 ------------------------------------
2291 function Build_Subprogram_Calling_Stubs
2292 (Vis_Decl
: Node_Id
;
2294 Asynchronous
: Boolean;
2295 Dynamically_Asynchronous
: Boolean := False;
2296 Stub_Type
: Entity_Id
:= Empty
;
2297 RACW_Type
: Entity_Id
:= Empty
;
2298 Locator
: Entity_Id
:= Empty
;
2299 New_Name
: Name_Id
:= No_Name
) return Node_Id
2301 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
2303 Decls
: constant List_Id
:= New_List
;
2304 Statements
: constant List_Id
:= New_List
;
2306 Subp_Spec
: Node_Id
;
2307 -- The specification of the body
2309 Controlling_Parameter
: Entity_Id
:= Empty
;
2311 Asynchronous_Expr
: Node_Id
:= Empty
;
2313 RCI_Locator
: Entity_Id
;
2315 Spec_To_Use
: Node_Id
;
2317 procedure Insert_Partition_Check
(Parameter
: Node_Id
);
2318 -- Check that the parameter has been elaborated on the same partition
2319 -- than the controlling parameter (E.4(19)).
2321 ----------------------------
2322 -- Insert_Partition_Check --
2323 ----------------------------
2325 procedure Insert_Partition_Check
(Parameter
: Node_Id
) is
2326 Parameter_Entity
: constant Entity_Id
:=
2327 Defining_Identifier
(Parameter
);
2329 -- The expression that will be built is of the form:
2331 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2332 -- raise Constraint_Error;
2335 -- We do not check that Parameter is in Stub_Type since such a check
2336 -- has been inserted at the point of call already (a tag check since
2337 -- we have multiple controlling operands).
2340 Make_Raise_Constraint_Error
(Loc
,
2344 Make_Function_Call
(Loc
,
2346 New_Occurrence_Of
(RTE
(RE_Same_Partition
), Loc
),
2347 Parameter_Associations
=>
2349 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2350 New_Occurrence_Of
(Parameter_Entity
, Loc
)),
2351 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2352 New_Occurrence_Of
(Controlling_Parameter
, Loc
))))),
2353 Reason
=> CE_Partition_Check_Failed
));
2354 end Insert_Partition_Check
;
2356 -- Start of processing for Build_Subprogram_Calling_Stubs
2359 Subp_Spec
:= Copy_Specification
(Loc
,
2360 Spec
=> Specification
(Vis_Decl
),
2361 New_Name
=> New_Name
);
2363 if Locator
= Empty
then
2364 RCI_Locator
:= RCI_Cache
;
2365 Spec_To_Use
:= Specification
(Vis_Decl
);
2367 RCI_Locator
:= Locator
;
2368 Spec_To_Use
:= Subp_Spec
;
2371 -- Find a controlling argument if we have a stub type. Also check
2372 -- if this subprogram can be made asynchronous.
2374 if Present
(Stub_Type
)
2375 and then Present
(Parameter_Specifications
(Spec_To_Use
))
2378 Current_Parameter
: Node_Id
:=
2379 First
(Parameter_Specifications
2382 while Present
(Current_Parameter
) loop
2384 Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
)
2386 if Controlling_Parameter
= Empty
then
2387 Controlling_Parameter
:=
2388 Defining_Identifier
(Current_Parameter
);
2390 Insert_Partition_Check
(Current_Parameter
);
2394 Next
(Current_Parameter
);
2399 pragma Assert
(No
(Stub_Type
) or else Present
(Controlling_Parameter
));
2401 if Dynamically_Asynchronous
then
2402 Asynchronous_Expr
:= Make_Selected_Component
(Loc
,
2403 Prefix
=> Controlling_Parameter
,
2404 Selector_Name
=> Name_Asynchronous
);
2407 Specific_Build_General_Calling_Stubs
2409 Statements
=> Statements
,
2410 Target
=> Specific_Build_Stub_Target
(Loc
,
2411 Decls
, RCI_Locator
, Controlling_Parameter
),
2412 Subprogram_Id
=> Subp_Id
,
2413 Asynchronous
=> Asynchronous_Expr
,
2414 Is_Known_Asynchronous
=> Asynchronous
2415 and then not Dynamically_Asynchronous
,
2416 Is_Known_Non_Asynchronous
2418 and then not Dynamically_Asynchronous
,
2419 Is_Function
=> Nkind
(Spec_To_Use
) =
2420 N_Function_Specification
,
2421 Spec
=> Spec_To_Use
,
2422 Stub_Type
=> Stub_Type
,
2423 RACW_Type
=> RACW_Type
,
2426 RCI_Calling_Stubs_Table
.Set
2427 (Defining_Unit_Name
(Specification
(Vis_Decl
)),
2428 Defining_Unit_Name
(Spec_To_Use
));
2431 Make_Subprogram_Body
(Loc
,
2432 Specification
=> Subp_Spec
,
2433 Declarations
=> Decls
,
2434 Handled_Statement_Sequence
=>
2435 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
));
2436 end Build_Subprogram_Calling_Stubs
;
2438 -------------------------
2439 -- Build_Subprogram_Id --
2440 -------------------------
2442 function Build_Subprogram_Id
2444 E
: Entity_Id
) return Node_Id
2447 if Get_Subprogram_Ids
(E
).Str_Identifier
= No_String
then
2449 Current_Declaration
: Node_Id
;
2450 Current_Subp
: Entity_Id
;
2451 Current_Subp_Str
: String_Id
;
2452 Current_Subp_Number
: Int
:= First_RCI_Subprogram_Id
;
2454 pragma Warnings
(Off
, Current_Subp_Str
);
2457 -- Build_Subprogram_Id is called outside of the context of
2458 -- generating calling or receiving stubs. Hence we are processing
2459 -- an 'Access attribute_reference for an RCI subprogram, for the
2460 -- purpose of obtaining a RAS value.
2463 (Is_Remote_Call_Interface
(Scope
(E
))
2465 (Nkind
(Parent
(E
)) = N_Procedure_Specification
2467 Nkind
(Parent
(E
)) = N_Function_Specification
));
2469 Current_Declaration
:=
2470 First
(Visible_Declarations
2471 (Package_Specification_Of_Scope
(Scope
(E
))));
2472 while Present
(Current_Declaration
) loop
2473 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
2474 and then Comes_From_Source
(Current_Declaration
)
2476 Current_Subp
:= Defining_Unit_Name
(Specification
(
2477 Current_Declaration
));
2479 Assign_Subprogram_Identifier
2480 (Current_Subp
, Current_Subp_Number
, Current_Subp_Str
);
2482 Current_Subp_Number
:= Current_Subp_Number
+ 1;
2485 Next
(Current_Declaration
);
2490 case Get_PCS_Name
is
2491 when Name_PolyORB_DSA
=>
2492 return Make_String_Literal
(Loc
, Get_Subprogram_Id
(E
));
2494 return Make_Integer_Literal
(Loc
, Get_Subprogram_Id
(E
));
2496 end Build_Subprogram_Id
;
2498 ------------------------
2499 -- Copy_Specification --
2500 ------------------------
2502 function Copy_Specification
2505 Ctrl_Type
: Entity_Id
:= Empty
;
2506 New_Name
: Name_Id
:= No_Name
) return Node_Id
2508 Parameters
: List_Id
:= No_List
;
2510 Current_Parameter
: Node_Id
;
2511 Current_Identifier
: Entity_Id
;
2512 Current_Type
: Node_Id
;
2514 Name_For_New_Spec
: Name_Id
;
2516 New_Identifier
: Entity_Id
;
2518 -- Comments needed in body below ???
2521 if New_Name
= No_Name
then
2522 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
2523 or else Nkind
(Spec
) = N_Procedure_Specification
);
2525 Name_For_New_Spec
:= Chars
(Defining_Unit_Name
(Spec
));
2527 Name_For_New_Spec
:= New_Name
;
2530 if Present
(Parameter_Specifications
(Spec
)) then
2531 Parameters
:= New_List
;
2532 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2533 while Present
(Current_Parameter
) loop
2534 Current_Identifier
:= Defining_Identifier
(Current_Parameter
);
2535 Current_Type
:= Parameter_Type
(Current_Parameter
);
2537 if Nkind
(Current_Type
) = N_Access_Definition
then
2538 if Present
(Ctrl_Type
) then
2539 pragma Assert
(Is_Controlling_Formal
(Current_Identifier
));
2541 Make_Access_Definition
(Loc
,
2542 Subtype_Mark
=> New_Occurrence_Of
(Ctrl_Type
, Loc
),
2543 Null_Exclusion_Present
=>
2544 Null_Exclusion_Present
(Current_Type
));
2548 Make_Access_Definition
(Loc
,
2550 New_Copy_Tree
(Subtype_Mark
(Current_Type
)),
2551 Null_Exclusion_Present
=>
2552 Null_Exclusion_Present
(Current_Type
));
2556 if Present
(Ctrl_Type
)
2557 and then Is_Controlling_Formal
(Current_Identifier
)
2559 Current_Type
:= New_Occurrence_Of
(Ctrl_Type
, Loc
);
2561 Current_Type
:= New_Copy_Tree
(Current_Type
);
2565 New_Identifier
:= Make_Defining_Identifier
(Loc
,
2566 Chars
(Current_Identifier
));
2568 Append_To
(Parameters
,
2569 Make_Parameter_Specification
(Loc
,
2570 Defining_Identifier
=> New_Identifier
,
2571 Parameter_Type
=> Current_Type
,
2572 In_Present
=> In_Present
(Current_Parameter
),
2573 Out_Present
=> Out_Present
(Current_Parameter
),
2575 New_Copy_Tree
(Expression
(Current_Parameter
))));
2577 -- For a regular formal parameter (that needs to be marshalled
2578 -- in the context of remote calls), set the Etype now, because
2579 -- marshalling processing might need it.
2581 if Is_Entity_Name
(Current_Type
) then
2582 Set_Etype
(New_Identifier
, Entity
(Current_Type
));
2584 -- Current_Type is an access definition, special processing
2585 -- (not requiring etype) will occur for marshalling.
2591 Next
(Current_Parameter
);
2595 case Nkind
(Spec
) is
2597 when N_Function_Specification | N_Access_Function_Definition
=>
2599 Make_Function_Specification
(Loc
,
2600 Defining_Unit_Name
=>
2601 Make_Defining_Identifier
(Loc
,
2602 Chars
=> Name_For_New_Spec
),
2603 Parameter_Specifications
=> Parameters
,
2604 Result_Definition
=>
2605 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
2607 when N_Procedure_Specification | N_Access_Procedure_Definition
=>
2609 Make_Procedure_Specification
(Loc
,
2610 Defining_Unit_Name
=>
2611 Make_Defining_Identifier
(Loc
,
2612 Chars
=> Name_For_New_Spec
),
2613 Parameter_Specifications
=> Parameters
);
2616 raise Program_Error
;
2618 end Copy_Specification
;
2620 -----------------------------
2621 -- Corresponding_Stub_Type --
2622 -----------------------------
2624 function Corresponding_Stub_Type
(RACW_Type
: Entity_Id
) return Entity_Id
is
2625 Desig
: constant Entity_Id
:=
2626 Etype
(Designated_Type
(RACW_Type
));
2627 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
2629 return Stub_Elements
.Stub_Type
;
2630 end Corresponding_Stub_Type
;
2632 ---------------------------
2633 -- Could_Be_Asynchronous --
2634 ---------------------------
2636 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean is
2637 Current_Parameter
: Node_Id
;
2640 if Present
(Parameter_Specifications
(Spec
)) then
2641 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2642 while Present
(Current_Parameter
) loop
2643 if Out_Present
(Current_Parameter
) then
2647 Next
(Current_Parameter
);
2652 end Could_Be_Asynchronous
;
2654 ---------------------------
2655 -- Declare_Create_NVList --
2656 ---------------------------
2658 procedure Declare_Create_NVList
2666 Make_Object_Declaration
(Loc
,
2667 Defining_Identifier
=> NVList
,
2668 Aliased_Present
=> False,
2669 Object_Definition
=>
2670 New_Occurrence_Of
(RTE
(RE_NVList_Ref
), Loc
)));
2673 Make_Procedure_Call_Statement
(Loc
,
2675 New_Occurrence_Of
(RTE
(RE_NVList_Create
), Loc
),
2676 Parameter_Associations
=> New_List
(
2677 New_Occurrence_Of
(NVList
, Loc
))));
2678 end Declare_Create_NVList
;
2680 ---------------------------------------------
2681 -- Expand_All_Calls_Remote_Subprogram_Call --
2682 ---------------------------------------------
2684 procedure Expand_All_Calls_Remote_Subprogram_Call
(N
: Node_Id
) is
2685 Called_Subprogram
: constant Entity_Id
:= Entity
(Name
(N
));
2686 RCI_Package
: constant Entity_Id
:= Scope
(Called_Subprogram
);
2687 Loc
: constant Source_Ptr
:= Sloc
(N
);
2688 RCI_Locator
: Node_Id
;
2689 RCI_Cache
: Entity_Id
;
2690 Calling_Stubs
: Node_Id
;
2691 E_Calling_Stubs
: Entity_Id
;
2694 E_Calling_Stubs
:= RCI_Calling_Stubs_Table
.Get
(Called_Subprogram
);
2696 if E_Calling_Stubs
= Empty
then
2697 RCI_Cache
:= RCI_Locator_Table
.Get
(RCI_Package
);
2699 if RCI_Cache
= Empty
then
2702 (Loc
, Specification
(Unit_Declaration_Node
(RCI_Package
)));
2703 Prepend_To
(Current_Sem_Unit_Declarations
, RCI_Locator
);
2705 -- The RCI_Locator package is inserted at the top level in the
2706 -- current unit, and must appear in the proper scope, so that it
2707 -- is not prematurely removed by the GCC back-end.
2710 Scop
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
2713 if Ekind
(Scop
) = E_Package_Body
then
2714 Push_Scope
(Spec_Entity
(Scop
));
2716 elsif Ekind
(Scop
) = E_Subprogram_Body
then
2718 (Corresponding_Spec
(Unit_Declaration_Node
(Scop
)));
2724 Analyze
(RCI_Locator
);
2728 RCI_Cache
:= Defining_Unit_Name
(RCI_Locator
);
2731 RCI_Locator
:= Parent
(RCI_Cache
);
2734 Calling_Stubs
:= Build_Subprogram_Calling_Stubs
2735 (Vis_Decl
=> Parent
(Parent
(Called_Subprogram
)),
2737 Build_Subprogram_Id
(Loc
, Called_Subprogram
),
2738 Asynchronous
=> Nkind
(N
) = N_Procedure_Call_Statement
2740 Is_Asynchronous
(Called_Subprogram
),
2741 Locator
=> RCI_Cache
,
2742 New_Name
=> New_Internal_Name
('S'));
2743 Insert_After
(RCI_Locator
, Calling_Stubs
);
2744 Analyze
(Calling_Stubs
);
2745 E_Calling_Stubs
:= Defining_Unit_Name
(Specification
(Calling_Stubs
));
2748 Rewrite
(Name
(N
), New_Occurrence_Of
(E_Calling_Stubs
, Loc
));
2749 end Expand_All_Calls_Remote_Subprogram_Call
;
2751 ---------------------------------
2752 -- Expand_Calling_Stubs_Bodies --
2753 ---------------------------------
2755 procedure Expand_Calling_Stubs_Bodies
(Unit_Node
: Node_Id
) is
2756 Spec
: constant Node_Id
:= Specification
(Unit_Node
);
2757 Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
2759 Push_Scope
(Scope_Of_Spec
(Spec
));
2760 Add_Calling_Stubs_To_Declarations
2761 (Specification
(Unit_Node
), Decls
);
2763 end Expand_Calling_Stubs_Bodies
;
2765 -----------------------------------
2766 -- Expand_Receiving_Stubs_Bodies --
2767 -----------------------------------
2769 procedure Expand_Receiving_Stubs_Bodies
(Unit_Node
: Node_Id
) is
2772 Stubs_Decls
: List_Id
;
2773 Stubs_Stmts
: List_Id
;
2776 if Nkind
(Unit_Node
) = N_Package_Declaration
then
2777 Spec
:= Specification
(Unit_Node
);
2778 Decls
:= Private_Declarations
(Spec
);
2781 Decls
:= Visible_Declarations
(Spec
);
2784 Push_Scope
(Scope_Of_Spec
(Spec
));
2785 Specific_Add_Receiving_Stubs_To_Declarations
(Spec
, Decls
, Decls
);
2789 Package_Specification_Of_Scope
(Corresponding_Spec
(Unit_Node
));
2790 Decls
:= Declarations
(Unit_Node
);
2792 Push_Scope
(Scope_Of_Spec
(Unit_Node
));
2793 Stubs_Decls
:= New_List
;
2794 Stubs_Stmts
:= New_List
;
2795 Specific_Add_Receiving_Stubs_To_Declarations
2796 (Spec
, Stubs_Decls
, Stubs_Stmts
);
2798 Insert_List_Before
(First
(Decls
), Stubs_Decls
);
2801 HSS_Stmts
: constant List_Id
:=
2802 Statements
(Handled_Statement_Sequence
(Unit_Node
));
2803 First_HSS_Stmt
: constant Node_Id
:= First
(HSS_Stmts
);
2805 if No
(First_HSS_Stmt
) then
2806 Append_List_To
(HSS_Stmts
, Stubs_Stmts
);
2808 Insert_List_Before
(First_HSS_Stmt
, Stubs_Stmts
);
2814 end Expand_Receiving_Stubs_Bodies
;
2816 --------------------
2817 -- GARLIC_Support --
2818 --------------------
2820 package body GARLIC_Support
is
2822 -- Local subprograms
2824 procedure Add_RACW_Read_Attribute
2825 (RACW_Type
: Entity_Id
;
2826 Stub_Type
: Entity_Id
;
2827 Stub_Type_Access
: Entity_Id
;
2828 Body_Decls
: List_Id
);
2829 -- Add Read attribute for the RACW type. The declaration and attribute
2830 -- definition clauses are inserted right after the declaration of
2831 -- RACW_Type, while the subprogram body is appended to Body_Decls.
2833 procedure Add_RACW_Write_Attribute
2834 (RACW_Type
: Entity_Id
;
2835 Stub_Type
: Entity_Id
;
2836 Stub_Type_Access
: Entity_Id
;
2837 RPC_Receiver
: Node_Id
;
2838 Body_Decls
: List_Id
);
2839 -- Same as above for the Write attribute
2841 function Stream_Parameter
return Node_Id
;
2842 function Result
return Node_Id
;
2843 function Object
return Node_Id
renames Result
;
2844 -- Functions to create occurrences of the formal parameter names of the
2845 -- 'Read and 'Write attributes.
2848 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2849 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2851 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
2852 -- Add a subprogram body for RAS Access TSS
2854 -------------------------------------
2855 -- Add_Obj_RPC_Receiver_Completion --
2856 -------------------------------------
2858 procedure Add_Obj_RPC_Receiver_Completion
2861 RPC_Receiver
: Entity_Id
;
2862 Stub_Elements
: Stub_Structure
) is
2864 -- The RPC receiver body should not be the completion of the
2865 -- declaration recorded in the stub structure, because then the
2866 -- occurrences of the formal parameters within the body should refer
2867 -- to the entities from the declaration, not from the completion, to
2868 -- which we do not have easy access. Instead, the RPC receiver body
2869 -- acts as its own declaration, and the RPC receiver declaration is
2870 -- completed by a renaming-as-body.
2873 Make_Subprogram_Renaming_Declaration
(Loc
,
2875 Copy_Specification
(Loc
,
2876 Specification
(Stub_Elements
.RPC_Receiver_Decl
)),
2877 Name
=> New_Occurrence_Of
(RPC_Receiver
, Loc
)));
2878 end Add_Obj_RPC_Receiver_Completion
;
2880 -----------------------
2881 -- Add_RACW_Features --
2882 -----------------------
2884 procedure Add_RACW_Features
2885 (RACW_Type
: Entity_Id
;
2886 Stub_Type
: Entity_Id
;
2887 Stub_Type_Access
: Entity_Id
;
2888 RPC_Receiver_Decl
: Node_Id
;
2889 Body_Decls
: List_Id
)
2891 RPC_Receiver
: Node_Id
;
2892 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
2895 Loc
:= Sloc
(RACW_Type
);
2899 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2900 -- of the corresponding distributed object type. We retrieve its
2901 -- address from the local proxy object.
2903 RPC_Receiver
:= Make_Selected_Component
(Loc
,
2905 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
), Object
),
2906 Selector_Name
=> Make_Identifier
(Loc
, Name_Receiver
));
2909 RPC_Receiver
:= Make_Attribute_Reference
(Loc
,
2910 Prefix
=> New_Occurrence_Of
(
2911 Defining_Unit_Name
(Specification
(RPC_Receiver_Decl
)), Loc
),
2912 Attribute_Name
=> Name_Address
);
2915 Add_RACW_Write_Attribute
(
2922 Add_RACW_Read_Attribute
(
2927 end Add_RACW_Features
;
2929 -----------------------------
2930 -- Add_RACW_Read_Attribute --
2931 -----------------------------
2933 procedure Add_RACW_Read_Attribute
2934 (RACW_Type
: Entity_Id
;
2935 Stub_Type
: Entity_Id
;
2936 Stub_Type_Access
: Entity_Id
;
2937 Body_Decls
: List_Id
)
2939 Proc_Decl
: Node_Id
;
2940 Attr_Decl
: Node_Id
;
2942 Body_Node
: Node_Id
;
2945 Statements
: List_Id
;
2946 Local_Statements
: List_Id
;
2947 Remote_Statements
: List_Id
;
2948 -- Various parts of the procedure
2950 Procedure_Name
: constant Name_Id
:=
2951 New_Internal_Name
('R');
2952 Source_Partition
: constant Entity_Id
:=
2953 Make_Defining_Identifier
2954 (Loc
, New_Internal_Name
('P'));
2955 Source_Receiver
: constant Entity_Id
:=
2956 Make_Defining_Identifier
2957 (Loc
, New_Internal_Name
('S'));
2958 Source_Address
: constant Entity_Id
:=
2959 Make_Defining_Identifier
2960 (Loc
, New_Internal_Name
('P'));
2961 Local_Stub
: constant Entity_Id
:=
2962 Make_Defining_Identifier
2963 (Loc
, New_Internal_Name
('L'));
2964 Stubbed_Result
: constant Entity_Id
:=
2965 Make_Defining_Identifier
2966 (Loc
, New_Internal_Name
('S'));
2967 Asynchronous_Flag
: constant Entity_Id
:=
2968 Asynchronous_Flags_Table
.Get
(RACW_Type
);
2969 pragma Assert
(Present
(Asynchronous_Flag
));
2971 -- Start of processing for Add_RACW_Read_Attribute
2974 -- Generate object declarations
2977 Make_Object_Declaration
(Loc
,
2978 Defining_Identifier
=> Source_Partition
,
2979 Object_Definition
=>
2980 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
)),
2982 Make_Object_Declaration
(Loc
,
2983 Defining_Identifier
=> Source_Receiver
,
2984 Object_Definition
=>
2985 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
2987 Make_Object_Declaration
(Loc
,
2988 Defining_Identifier
=> Source_Address
,
2989 Object_Definition
=>
2990 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
2992 Make_Object_Declaration
(Loc
,
2993 Defining_Identifier
=> Local_Stub
,
2994 Aliased_Present
=> True,
2995 Object_Definition
=> New_Occurrence_Of
(Stub_Type
, Loc
)),
2997 Make_Object_Declaration
(Loc
,
2998 Defining_Identifier
=> Stubbed_Result
,
2999 Object_Definition
=>
3000 New_Occurrence_Of
(Stub_Type_Access
, Loc
),
3002 Make_Attribute_Reference
(Loc
,
3004 New_Occurrence_Of
(Local_Stub
, Loc
),
3006 Name_Unchecked_Access
)));
3008 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3010 Statements
:= New_List
(
3011 Make_Attribute_Reference
(Loc
,
3013 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3014 Attribute_Name
=> Name_Read
,
3015 Expressions
=> New_List
(
3017 New_Occurrence_Of
(Source_Partition
, Loc
))),
3019 Make_Attribute_Reference
(Loc
,
3021 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3024 Expressions
=> New_List
(
3026 New_Occurrence_Of
(Source_Receiver
, Loc
))),
3028 Make_Attribute_Reference
(Loc
,
3030 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3033 Expressions
=> New_List
(
3035 New_Occurrence_Of
(Source_Address
, Loc
))));
3037 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3039 Set_Etype
(Stubbed_Result
, Stub_Type_Access
);
3041 -- If the Address is Null_Address, then return a null object
3043 Append_To
(Statements
,
3044 Make_Implicit_If_Statement
(RACW_Type
,
3047 Left_Opnd
=> New_Occurrence_Of
(Source_Address
, Loc
),
3048 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
3049 Then_Statements
=> New_List
(
3050 Make_Assignment_Statement
(Loc
,
3052 Expression
=> Make_Null
(Loc
)),
3053 Make_Simple_Return_Statement
(Loc
))));
3055 -- If the RACW denotes an object created on the current partition,
3056 -- Local_Statements will be executed. The real object will be used.
3058 Local_Statements
:= New_List
(
3059 Make_Assignment_Statement
(Loc
,
3062 Unchecked_Convert_To
(RACW_Type
,
3063 OK_Convert_To
(RTE
(RE_Address
),
3064 New_Occurrence_Of
(Source_Address
, Loc
)))));
3066 -- If the object is located on another partition, then a stub object
3067 -- will be created with all the information needed to rebuild the
3068 -- real object at the other end.
3070 Remote_Statements
:= New_List
(
3072 Make_Assignment_Statement
(Loc
,
3073 Name
=> Make_Selected_Component
(Loc
,
3074 Prefix
=> Stubbed_Result
,
3075 Selector_Name
=> Name_Origin
),
3077 New_Occurrence_Of
(Source_Partition
, Loc
)),
3079 Make_Assignment_Statement
(Loc
,
3080 Name
=> Make_Selected_Component
(Loc
,
3081 Prefix
=> Stubbed_Result
,
3082 Selector_Name
=> Name_Receiver
),
3084 New_Occurrence_Of
(Source_Receiver
, Loc
)),
3086 Make_Assignment_Statement
(Loc
,
3087 Name
=> Make_Selected_Component
(Loc
,
3088 Prefix
=> Stubbed_Result
,
3089 Selector_Name
=> Name_Addr
),
3091 New_Occurrence_Of
(Source_Address
, Loc
)));
3093 Append_To
(Remote_Statements
,
3094 Make_Assignment_Statement
(Loc
,
3095 Name
=> Make_Selected_Component
(Loc
,
3096 Prefix
=> Stubbed_Result
,
3097 Selector_Name
=> Name_Asynchronous
),
3099 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)));
3101 Append_List_To
(Remote_Statements
,
3102 Build_Get_Unique_RP_Call
(Loc
, Stubbed_Result
, Stub_Type
));
3103 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3104 -- set on the stub type if, and only if, the RACW type has a pragma
3105 -- Asynchronous. This is incorrect for RACWs that implement RAS
3106 -- types, because in that case the /designated subprogram/ (not the
3107 -- type) might be asynchronous, and that causes the stub to need to
3108 -- be asynchronous too. A solution is to transport a RAS as a struct
3109 -- containing a RACW and an asynchronous flag, and to properly alter
3110 -- the Asynchronous component in the stub type in the RAS's Input
3113 Append_To
(Remote_Statements
,
3114 Make_Assignment_Statement
(Loc
,
3116 Expression
=> Unchecked_Convert_To
(RACW_Type
,
3117 New_Occurrence_Of
(Stubbed_Result
, Loc
))));
3119 -- Distinguish between the local and remote cases, and execute the
3120 -- appropriate piece of code.
3122 Append_To
(Statements
,
3123 Make_Implicit_If_Statement
(RACW_Type
,
3127 Make_Function_Call
(Loc
,
3128 Name
=> New_Occurrence_Of
(
3129 RTE
(RE_Get_Local_Partition_Id
), Loc
)),
3130 Right_Opnd
=> New_Occurrence_Of
(Source_Partition
, Loc
)),
3131 Then_Statements
=> Local_Statements
,
3132 Else_Statements
=> Remote_Statements
));
3134 Build_Stream_Procedure
3135 (Loc
, RACW_Type
, Body_Node
,
3136 Make_Defining_Identifier
(Loc
, Procedure_Name
),
3137 Statements
, Outp
=> True);
3138 Set_Declarations
(Body_Node
, Decls
);
3140 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
3141 Copy_Specification
(Loc
, Specification
(Body_Node
)));
3144 Make_Attribute_Definition_Clause
(Loc
,
3145 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
3149 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
3151 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
3152 Insert_After
(Proc_Decl
, Attr_Decl
);
3153 Append_To
(Body_Decls
, Body_Node
);
3154 end Add_RACW_Read_Attribute
;
3156 ------------------------------
3157 -- Add_RACW_Write_Attribute --
3158 ------------------------------
3160 procedure Add_RACW_Write_Attribute
3161 (RACW_Type
: Entity_Id
;
3162 Stub_Type
: Entity_Id
;
3163 Stub_Type_Access
: Entity_Id
;
3164 RPC_Receiver
: Node_Id
;
3165 Body_Decls
: List_Id
)
3167 Body_Node
: Node_Id
;
3168 Proc_Decl
: Node_Id
;
3169 Attr_Decl
: Node_Id
;
3171 Statements
: List_Id
;
3172 Local_Statements
: List_Id
;
3173 Remote_Statements
: List_Id
;
3174 Null_Statements
: List_Id
;
3176 Procedure_Name
: constant Name_Id
:= New_Internal_Name
('R');
3179 -- Build the code fragment corresponding to the marshalling of a
3182 Local_Statements
:= New_List
(
3184 Pack_Entity_Into_Stream_Access
(Loc
,
3185 Stream
=> Stream_Parameter
,
3186 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
3188 Pack_Node_Into_Stream_Access
(Loc
,
3189 Stream
=> Stream_Parameter
,
3190 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
), RPC_Receiver
),
3191 Etyp
=> RTE
(RE_Unsigned_64
)),
3193 Pack_Node_Into_Stream_Access
(Loc
,
3194 Stream
=> Stream_Parameter
,
3195 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
),
3196 Make_Attribute_Reference
(Loc
,
3198 Make_Explicit_Dereference
(Loc
,
3200 Attribute_Name
=> Name_Address
)),
3201 Etyp
=> RTE
(RE_Unsigned_64
)));
3203 -- Build the code fragment corresponding to the marshalling of
3206 Remote_Statements
:= New_List
(
3208 Pack_Node_Into_Stream_Access
(Loc
,
3209 Stream
=> Stream_Parameter
,
3211 Make_Selected_Component
(Loc
,
3212 Prefix
=> Unchecked_Convert_To
(Stub_Type_Access
,
3215 Make_Identifier
(Loc
, Name_Origin
)),
3216 Etyp
=> RTE
(RE_Partition_ID
)),
3218 Pack_Node_Into_Stream_Access
(Loc
,
3219 Stream
=> Stream_Parameter
,
3221 Make_Selected_Component
(Loc
,
3222 Prefix
=> Unchecked_Convert_To
(Stub_Type_Access
,
3225 Make_Identifier
(Loc
, Name_Receiver
)),
3226 Etyp
=> RTE
(RE_Unsigned_64
)),
3228 Pack_Node_Into_Stream_Access
(Loc
,
3229 Stream
=> Stream_Parameter
,
3231 Make_Selected_Component
(Loc
,
3232 Prefix
=> Unchecked_Convert_To
(Stub_Type_Access
,
3235 Make_Identifier
(Loc
, Name_Addr
)),
3236 Etyp
=> RTE
(RE_Unsigned_64
)));
3238 -- Build code fragment corresponding to marshalling of a null object
3240 Null_Statements
:= New_List
(
3242 Pack_Entity_Into_Stream_Access
(Loc
,
3243 Stream
=> Stream_Parameter
,
3244 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
3246 Pack_Node_Into_Stream_Access
(Loc
,
3247 Stream
=> Stream_Parameter
,
3248 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
), RPC_Receiver
),
3249 Etyp
=> RTE
(RE_Unsigned_64
)),
3251 Pack_Node_Into_Stream_Access
(Loc
,
3252 Stream
=> Stream_Parameter
,
3253 Object
=> Make_Integer_Literal
(Loc
, Uint_0
),
3254 Etyp
=> RTE
(RE_Unsigned_64
)));
3256 Statements
:= New_List
(
3257 Make_Implicit_If_Statement
(RACW_Type
,
3260 Left_Opnd
=> Object
,
3261 Right_Opnd
=> Make_Null
(Loc
)),
3262 Then_Statements
=> Null_Statements
,
3263 Elsif_Parts
=> New_List
(
3264 Make_Elsif_Part
(Loc
,
3268 Make_Attribute_Reference
(Loc
,
3270 Attribute_Name
=> Name_Tag
),
3272 Make_Attribute_Reference
(Loc
,
3273 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
3274 Attribute_Name
=> Name_Tag
)),
3275 Then_Statements
=> Remote_Statements
)),
3276 Else_Statements
=> Local_Statements
));
3278 Build_Stream_Procedure
3279 (Loc
, RACW_Type
, Body_Node
,
3280 Make_Defining_Identifier
(Loc
, Procedure_Name
),
3281 Statements
, Outp
=> False);
3283 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
3284 Copy_Specification
(Loc
, Specification
(Body_Node
)));
3287 Make_Attribute_Definition_Clause
(Loc
,
3288 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
3289 Chars
=> Name_Write
,
3292 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
3294 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
3295 Insert_After
(Proc_Decl
, Attr_Decl
);
3296 Append_To
(Body_Decls
, Body_Node
);
3297 end Add_RACW_Write_Attribute
;
3299 ------------------------
3300 -- Add_RAS_Access_TSS --
3301 ------------------------
3303 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
3304 Loc
: constant Source_Ptr
:= Sloc
(N
);
3306 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
3307 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
3308 -- Ras_Type is the access to subprogram type while Fat_Type is the
3309 -- corresponding record type.
3311 RACW_Type
: constant Entity_Id
:=
3312 Underlying_RACW_Type
(Ras_Type
);
3313 Desig
: constant Entity_Id
:=
3314 Etype
(Designated_Type
(RACW_Type
));
3316 Stub_Elements
: constant Stub_Structure
:=
3317 Stubs_Table
.Get
(Desig
);
3318 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
3320 Proc
: constant Entity_Id
:=
3321 Make_Defining_Identifier
(Loc
,
3322 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
3324 Proc_Spec
: Node_Id
;
3326 -- Formal parameters
3328 Package_Name
: constant Entity_Id
:=
3329 Make_Defining_Identifier
(Loc
,
3333 Subp_Id
: constant Entity_Id
:=
3334 Make_Defining_Identifier
(Loc
,
3336 -- Target subprogram
3338 Asynch_P
: constant Entity_Id
:=
3339 Make_Defining_Identifier
(Loc
,
3340 Chars
=> Name_Asynchronous
);
3341 -- Is the procedure to which the 'Access applies asynchronous?
3343 All_Calls_Remote
: constant Entity_Id
:=
3344 Make_Defining_Identifier
(Loc
,
3345 Chars
=> Name_All_Calls_Remote
);
3346 -- True if an All_Calls_Remote pragma applies to the RCI unit
3347 -- that contains the subprogram.
3349 -- Common local variables
3351 Proc_Decls
: List_Id
;
3352 Proc_Statements
: List_Id
;
3354 Origin
: constant Entity_Id
:=
3355 Make_Defining_Identifier
(Loc
,
3356 Chars
=> New_Internal_Name
('P'));
3358 -- Additional local variables for the local case
3360 Proxy_Addr
: constant Entity_Id
:=
3361 Make_Defining_Identifier
(Loc
,
3362 Chars
=> New_Internal_Name
('P'));
3364 -- Additional local variables for the remote case
3366 Local_Stub
: constant Entity_Id
:=
3367 Make_Defining_Identifier
(Loc
,
3368 Chars
=> New_Internal_Name
('L'));
3370 Stub_Ptr
: constant Entity_Id
:=
3371 Make_Defining_Identifier
(Loc
,
3372 Chars
=> New_Internal_Name
('S'));
3375 (Field_Name
: Name_Id
;
3376 Value
: Node_Id
) return Node_Id
;
3377 -- Construct an assignment that sets the named component in the
3385 (Field_Name
: Name_Id
;
3386 Value
: Node_Id
) return Node_Id
3390 Make_Assignment_Statement
(Loc
,
3392 Make_Selected_Component
(Loc
,
3394 Selector_Name
=> Field_Name
),
3395 Expression
=> Value
);
3398 -- Start of processing for Add_RAS_Access_TSS
3401 Proc_Decls
:= New_List
(
3403 -- Common declarations
3405 Make_Object_Declaration
(Loc
,
3406 Defining_Identifier
=> Origin
,
3407 Constant_Present
=> True,
3408 Object_Definition
=>
3409 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3411 Make_Function_Call
(Loc
,
3413 New_Occurrence_Of
(RTE
(RE_Get_Active_Partition_Id
), Loc
),
3414 Parameter_Associations
=> New_List
(
3415 New_Occurrence_Of
(Package_Name
, Loc
)))),
3417 -- Declaration use only in the local case: proxy address
3419 Make_Object_Declaration
(Loc
,
3420 Defining_Identifier
=> Proxy_Addr
,
3421 Object_Definition
=>
3422 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3424 -- Declarations used only in the remote case: stub object and
3427 Make_Object_Declaration
(Loc
,
3428 Defining_Identifier
=> Local_Stub
,
3429 Aliased_Present
=> True,
3430 Object_Definition
=>
3431 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
3433 Make_Object_Declaration
(Loc
,
3434 Defining_Identifier
=>
3436 Object_Definition
=>
3437 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
3439 Make_Attribute_Reference
(Loc
,
3440 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
3441 Attribute_Name
=> Name_Unchecked_Access
)));
3443 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
3444 -- Build_Get_Unique_RP_Call needs this information
3446 -- Note: Here we assume that the Fat_Type is a record
3447 -- containing just a pointer to a proxy or stub object.
3449 Proc_Statements
:= New_List
(
3453 -- Get_RAS_Info (Pkg, Subp, PA);
3454 -- if Origin = Local_Partition_Id
3455 -- and then not All_Calls_Remote
3457 -- return Fat_Type!(PA);
3460 Make_Procedure_Call_Statement
(Loc
,
3462 New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
3463 Parameter_Associations
=> New_List
(
3464 New_Occurrence_Of
(Package_Name
, Loc
),
3465 New_Occurrence_Of
(Subp_Id
, Loc
),
3466 New_Occurrence_Of
(Proxy_Addr
, Loc
))),
3468 Make_Implicit_If_Statement
(N
,
3474 New_Occurrence_Of
(Origin
, Loc
),
3476 Make_Function_Call
(Loc
,
3478 RTE
(RE_Get_Local_Partition_Id
), Loc
))),
3481 New_Occurrence_Of
(All_Calls_Remote
, Loc
))),
3482 Then_Statements
=> New_List
(
3483 Make_Simple_Return_Statement
(Loc
,
3484 Unchecked_Convert_To
(Fat_Type
,
3485 OK_Convert_To
(RTE
(RE_Address
),
3486 New_Occurrence_Of
(Proxy_Addr
, Loc
)))))),
3488 Set_Field
(Name_Origin
,
3489 New_Occurrence_Of
(Origin
, Loc
)),
3491 Set_Field
(Name_Receiver
,
3492 Make_Function_Call
(Loc
,
3494 New_Occurrence_Of
(RTE
(RE_Get_RCI_Package_Receiver
), Loc
),
3495 Parameter_Associations
=> New_List
(
3496 New_Occurrence_Of
(Package_Name
, Loc
)))),
3498 Set_Field
(Name_Addr
, New_Occurrence_Of
(Proxy_Addr
, Loc
)),
3500 -- E.4.1(9) A remote call is asynchronous if it is a call to
3501 -- a procedure, or a call through a value of an access-to-procedure
3502 -- type, to which a pragma Asynchronous applies.
3504 -- Parameter Asynch_P is true when the procedure is asynchronous;
3505 -- Expression Asynch_T is true when the type is asynchronous.
3507 Set_Field
(Name_Asynchronous
,
3509 New_Occurrence_Of
(Asynch_P
, Loc
),
3510 New_Occurrence_Of
(Boolean_Literals
(
3511 Is_Asynchronous
(Ras_Type
)), Loc
))));
3513 Append_List_To
(Proc_Statements
,
3514 Build_Get_Unique_RP_Call
3515 (Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
3517 -- Return the newly created value
3519 Append_To
(Proc_Statements
,
3520 Make_Simple_Return_Statement
(Loc
,
3522 Unchecked_Convert_To
(Fat_Type
,
3523 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
3526 Make_Function_Specification
(Loc
,
3527 Defining_Unit_Name
=> Proc
,
3528 Parameter_Specifications
=> New_List
(
3529 Make_Parameter_Specification
(Loc
,
3530 Defining_Identifier
=> Package_Name
,
3532 New_Occurrence_Of
(Standard_String
, Loc
)),
3534 Make_Parameter_Specification
(Loc
,
3535 Defining_Identifier
=> Subp_Id
,
3537 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
)),
3539 Make_Parameter_Specification
(Loc
,
3540 Defining_Identifier
=> Asynch_P
,
3542 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3544 Make_Parameter_Specification
(Loc
,
3545 Defining_Identifier
=> All_Calls_Remote
,
3547 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
3549 Result_Definition
=>
3550 New_Occurrence_Of
(Fat_Type
, Loc
));
3552 -- Set the kind and return type of the function to prevent
3553 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3555 Set_Ekind
(Proc
, E_Function
);
3556 Set_Etype
(Proc
, Fat_Type
);
3559 Make_Subprogram_Body
(Loc
,
3560 Specification
=> Proc_Spec
,
3561 Declarations
=> Proc_Decls
,
3562 Handled_Statement_Sequence
=>
3563 Make_Handled_Sequence_Of_Statements
(Loc
,
3564 Statements
=> Proc_Statements
)));
3566 Set_TSS
(Fat_Type
, Proc
);
3567 end Add_RAS_Access_TSS
;
3569 -----------------------
3570 -- Add_RAST_Features --
3571 -----------------------
3573 procedure Add_RAST_Features
3574 (Vis_Decl
: Node_Id
;
3575 RAS_Type
: Entity_Id
)
3577 pragma Warnings
(Off
);
3578 pragma Unreferenced
(RAS_Type
);
3579 pragma Warnings
(On
);
3581 Add_RAS_Access_TSS
(Vis_Decl
);
3582 end Add_RAST_Features
;
3584 -----------------------------------------
3585 -- Add_Receiving_Stubs_To_Declarations --
3586 -----------------------------------------
3588 procedure Add_Receiving_Stubs_To_Declarations
3589 (Pkg_Spec
: Node_Id
;
3593 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
3595 Request_Parameter
: Node_Id
;
3597 Pkg_RPC_Receiver
: constant Entity_Id
:=
3598 Make_Defining_Identifier
(Loc
,
3599 New_Internal_Name
('H'));
3600 Pkg_RPC_Receiver_Statements
: List_Id
;
3601 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
3602 Pkg_RPC_Receiver_Body
: Node_Id
;
3603 -- A Pkg_RPC_Receiver is built to decode the request
3605 Lookup_RAS_Info
: constant Entity_Id
:=
3606 Make_Defining_Identifier
(Loc
,
3607 Chars
=> New_Internal_Name
('R'));
3608 -- A remote subprogram is created to allow peers to look up
3609 -- RAS information using subprogram ids.
3611 Subp_Id
: Entity_Id
;
3612 Subp_Index
: Entity_Id
;
3613 -- Subprogram_Id as read from the incoming stream
3615 Current_Declaration
: Node_Id
;
3616 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
3617 Current_Stubs
: Node_Id
;
3619 Subp_Info_Array
: constant Entity_Id
:=
3620 Make_Defining_Identifier
(Loc
,
3621 Chars
=> New_Internal_Name
('I'));
3623 Subp_Info_List
: constant List_Id
:= New_List
;
3625 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
3627 All_Calls_Remote_E
: Entity_Id
;
3628 Proxy_Object_Addr
: Entity_Id
;
3630 procedure Append_Stubs_To
3631 (RPC_Receiver_Cases
: List_Id
;
3633 Subprogram_Number
: Int
);
3634 -- Add one case to the specified RPC receiver case list
3635 -- associating Subprogram_Number with the subprogram declared
3636 -- by Declaration, for which we have receiving stubs in Stubs.
3638 ---------------------
3639 -- Append_Stubs_To --
3640 ---------------------
3642 procedure Append_Stubs_To
3643 (RPC_Receiver_Cases
: List_Id
;
3645 Subprogram_Number
: Int
)
3648 Append_To
(RPC_Receiver_Cases
,
3649 Make_Case_Statement_Alternative
(Loc
,
3651 New_List
(Make_Integer_Literal
(Loc
, Subprogram_Number
)),
3654 Make_Procedure_Call_Statement
(Loc
,
3657 Defining_Entity
(Stubs
), Loc
),
3658 Parameter_Associations
=> New_List
(
3659 New_Occurrence_Of
(Request_Parameter
, Loc
))))));
3660 end Append_Stubs_To
;
3662 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3665 -- Building receiving stubs consist in several operations:
3667 -- - a package RPC receiver must be built. This subprogram
3668 -- will get a Subprogram_Id from the incoming stream
3669 -- and will dispatch the call to the right subprogram;
3671 -- - a receiving stub for each subprogram visible in the package
3672 -- spec. This stub will read all the parameters from the stream,
3673 -- and put the result as well as the exception occurrence in the
3676 -- - a dummy package with an empty spec and a body made of an
3677 -- elaboration part, whose job is to register the receiving
3678 -- part of this RCI package on the name server. This is done
3679 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3681 Build_RPC_Receiver_Body
(
3682 RPC_Receiver
=> Pkg_RPC_Receiver
,
3683 Request
=> Request_Parameter
,
3685 Subp_Index
=> Subp_Index
,
3686 Stmts
=> Pkg_RPC_Receiver_Statements
,
3687 Decl
=> Pkg_RPC_Receiver_Body
);
3688 pragma Assert
(Subp_Id
= Subp_Index
);
3690 -- A null subp_id denotes a call through a RAS, in which case the
3691 -- next Uint_64 element in the stream is the address of the local
3692 -- proxy object, from which we can retrieve the actual subprogram id.
3694 Append_To
(Pkg_RPC_Receiver_Statements
,
3695 Make_Implicit_If_Statement
(Pkg_Spec
,
3698 New_Occurrence_Of
(Subp_Id
, Loc
),
3699 Make_Integer_Literal
(Loc
, 0)),
3700 Then_Statements
=> New_List
(
3701 Make_Assignment_Statement
(Loc
,
3703 New_Occurrence_Of
(Subp_Id
, Loc
),
3705 Make_Selected_Component
(Loc
,
3707 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
3708 OK_Convert_To
(RTE
(RE_Address
),
3709 Make_Attribute_Reference
(Loc
,
3711 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3714 Expressions
=> New_List
(
3715 Make_Selected_Component
(Loc
,
3716 Prefix
=> Request_Parameter
,
3717 Selector_Name
=> Name_Params
))))),
3719 Make_Identifier
(Loc
, Name_Subp_Id
))))));
3721 -- Build a subprogram for RAS information lookups
3723 Current_Declaration
:=
3724 Make_Subprogram_Declaration
(Loc
,
3726 Make_Function_Specification
(Loc
,
3727 Defining_Unit_Name
=>
3729 Parameter_Specifications
=> New_List
(
3730 Make_Parameter_Specification
(Loc
,
3731 Defining_Identifier
=>
3732 Make_Defining_Identifier
(Loc
, Name_Subp_Id
),
3736 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))),
3737 Result_Definition
=>
3738 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)));
3739 Append_To
(Decls
, Current_Declaration
);
3740 Analyze
(Current_Declaration
);
3742 Current_Stubs
:= Build_Subprogram_Receiving_Stubs
3743 (Vis_Decl
=> Current_Declaration
,
3744 Asynchronous
=> False);
3745 Append_To
(Decls
, Current_Stubs
);
3746 Analyze
(Current_Stubs
);
3748 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3751 Subprogram_Number
=> 1);
3753 -- For each subprogram, the receiving stub will be built and a
3754 -- case statement will be made on the Subprogram_Id to dispatch
3755 -- to the right subprogram.
3757 All_Calls_Remote_E
:=
3759 (Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
3761 Overload_Counter_Table
.Reset
;
3763 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
3764 while Present
(Current_Declaration
) loop
3765 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
3766 and then Comes_From_Source
(Current_Declaration
)
3769 Loc
: constant Source_Ptr
:= Sloc
(Current_Declaration
);
3770 -- While specifically processing Current_Declaration, use
3771 -- its Sloc as the location of all generated nodes.
3773 Subp_Def
: constant Entity_Id
:=
3775 (Specification
(Current_Declaration
));
3777 Subp_Val
: String_Id
;
3778 pragma Warnings
(Off
, Subp_Val
);
3781 -- Build receiving stub
3784 Build_Subprogram_Receiving_Stubs
3785 (Vis_Decl
=> Current_Declaration
,
3787 Nkind
(Specification
(Current_Declaration
)) =
3788 N_Procedure_Specification
3789 and then Is_Asynchronous
(Subp_Def
));
3791 Append_To
(Decls
, Current_Stubs
);
3792 Analyze
(Current_Stubs
);
3796 Add_RAS_Proxy_And_Analyze
(Decls
,
3797 Vis_Decl
=> Current_Declaration
,
3798 All_Calls_Remote_E
=> All_Calls_Remote_E
,
3799 Proxy_Object_Addr
=> Proxy_Object_Addr
);
3801 -- Compute distribution identifier
3803 Assign_Subprogram_Identifier
3805 Current_Subprogram_Number
,
3809 (Current_Subprogram_Number
= Get_Subprogram_Id
(Subp_Def
));
3811 -- Add subprogram descriptor (RCI_Subp_Info) to the
3812 -- subprograms table for this receiver. The aggregate
3813 -- below must be kept consistent with the declaration
3814 -- of type RCI_Subp_Info in System.Partition_Interface.
3816 Append_To
(Subp_Info_List
,
3817 Make_Component_Association
(Loc
,
3818 Choices
=> New_List
(
3819 Make_Integer_Literal
(Loc
,
3820 Current_Subprogram_Number
)),
3822 Make_Aggregate
(Loc
,
3823 Component_Associations
=> New_List
(
3824 Make_Component_Association
(Loc
,
3825 Choices
=> New_List
(
3826 Make_Identifier
(Loc
, Name_Addr
)),
3829 Proxy_Object_Addr
, Loc
))))));
3831 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3834 Subprogram_Number
=>
3835 Current_Subprogram_Number
);
3838 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
3841 Next
(Current_Declaration
);
3844 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3845 -- rather than raising an exception since we do not want someone
3846 -- to crash a remote partition by sending invalid subprogram ids.
3847 -- This is consistent with the other parts of the case statement
3848 -- since even in presence of incorrect parameters in the stream,
3849 -- every exception will be caught and (if the subprogram is not an
3850 -- APC) put into the result stream and sent away.
3852 Append_To
(Pkg_RPC_Receiver_Cases
,
3853 Make_Case_Statement_Alternative
(Loc
,
3855 New_List
(Make_Others_Choice
(Loc
)),
3857 New_List
(Make_Null_Statement
(Loc
))));
3859 Append_To
(Pkg_RPC_Receiver_Statements
,
3860 Make_Case_Statement
(Loc
,
3862 New_Occurrence_Of
(Subp_Id
, Loc
),
3863 Alternatives
=> Pkg_RPC_Receiver_Cases
));
3866 Make_Object_Declaration
(Loc
,
3867 Defining_Identifier
=> Subp_Info_Array
,
3868 Constant_Present
=> True,
3869 Aliased_Present
=> True,
3870 Object_Definition
=>
3871 Make_Subtype_Indication
(Loc
,
3873 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
3875 Make_Index_Or_Discriminant_Constraint
(Loc
,
3878 Low_Bound
=> Make_Integer_Literal
(Loc
,
3879 First_RCI_Subprogram_Id
),
3881 Make_Integer_Literal
(Loc
,
3882 First_RCI_Subprogram_Id
3883 + List_Length
(Subp_Info_List
) - 1)))))));
3885 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
3886 -- has zero length, and the declaration is for an empty array, in
3887 -- which case no initialization aggregate must be generated.
3889 if Present
(First
(Subp_Info_List
)) then
3890 Set_Expression
(Last
(Decls
),
3891 Make_Aggregate
(Loc
,
3892 Component_Associations
=> Subp_Info_List
));
3894 -- No initialization provided: remove CONSTANT so that the
3895 -- declaration is not an incomplete deferred constant.
3898 Set_Constant_Present
(Last
(Decls
), False);
3901 Analyze
(Last
(Decls
));
3904 Subp_Info_Addr
: Node_Id
;
3905 -- Return statement for Lookup_RAS_Info: address of the subprogram
3906 -- information record for the requested subprogram id.
3909 if Present
(First
(Subp_Info_List
)) then
3911 Make_Selected_Component
(Loc
,
3913 Make_Indexed_Component
(Loc
,
3915 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3916 Expressions
=> New_List
(
3917 Convert_To
(Standard_Integer
,
3918 Make_Identifier
(Loc
, Name_Subp_Id
)))),
3920 Make_Identifier
(Loc
, Name_Addr
));
3922 -- Case of no visible subprogram: just raise Constraint_Error, we
3923 -- know for sure we got junk from a remote partition.
3927 Make_Raise_Constraint_Error
(Loc
,
3928 Reason
=> CE_Range_Check_Failed
);
3929 Set_Etype
(Subp_Info_Addr
, RTE
(RE_Unsigned_64
));
3933 Make_Subprogram_Body
(Loc
,
3935 Copy_Specification
(Loc
, Parent
(Lookup_RAS_Info
)),
3938 Handled_Statement_Sequence
=>
3939 Make_Handled_Sequence_Of_Statements
(Loc
,
3940 Statements
=> New_List
(
3941 Make_Simple_Return_Statement
(Loc
,
3943 OK_Convert_To
(RTE
(RE_Unsigned_64
),
3944 Subp_Info_Addr
))))));
3947 Analyze
(Last
(Decls
));
3949 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
3950 Analyze
(Last
(Decls
));
3952 Get_Library_Unit_Name_String
(Pkg_Spec
);
3956 Append_To
(Register_Pkg_Actuals
,
3957 Make_String_Literal
(Loc
,
3958 Strval
=> String_From_Name_Buffer
));
3962 Append_To
(Register_Pkg_Actuals
,
3963 Make_Attribute_Reference
(Loc
,
3965 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
3967 Name_Unrestricted_Access
));
3971 Append_To
(Register_Pkg_Actuals
,
3972 Make_Attribute_Reference
(Loc
,
3974 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
3980 Append_To
(Register_Pkg_Actuals
,
3981 Make_Attribute_Reference
(Loc
,
3983 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3989 Append_To
(Register_Pkg_Actuals
,
3990 Make_Attribute_Reference
(Loc
,
3992 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3996 -- Generate the call
3999 Make_Procedure_Call_Statement
(Loc
,
4001 New_Occurrence_Of
(RTE
(RE_Register_Receiving_Stub
), Loc
),
4002 Parameter_Associations
=> Register_Pkg_Actuals
));
4003 Analyze
(Last
(Stmts
));
4004 end Add_Receiving_Stubs_To_Declarations
;
4006 ---------------------------------
4007 -- Build_General_Calling_Stubs --
4008 ---------------------------------
4010 procedure Build_General_Calling_Stubs
4012 Statements
: List_Id
;
4013 Target_Partition
: Entity_Id
;
4014 Target_RPC_Receiver
: Node_Id
;
4015 Subprogram_Id
: Node_Id
;
4016 Asynchronous
: Node_Id
:= Empty
;
4017 Is_Known_Asynchronous
: Boolean := False;
4018 Is_Known_Non_Asynchronous
: Boolean := False;
4019 Is_Function
: Boolean;
4021 Stub_Type
: Entity_Id
:= Empty
;
4022 RACW_Type
: Entity_Id
:= Empty
;
4025 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
4027 Stream_Parameter
: Node_Id
;
4028 -- Name of the stream used to transmit parameters to the
4031 Result_Parameter
: Node_Id
;
4032 -- Name of the result parameter (in non-APC cases) which get the
4033 -- result of the remote subprogram.
4035 Exception_Return_Parameter
: Node_Id
;
4036 -- Name of the parameter which will hold the exception sent by the
4037 -- remote subprogram.
4039 Current_Parameter
: Node_Id
;
4040 -- Current parameter being handled
4042 Ordered_Parameters_List
: constant List_Id
:=
4043 Build_Ordered_Parameters_List
(Spec
);
4045 Asynchronous_Statements
: List_Id
:= No_List
;
4046 Non_Asynchronous_Statements
: List_Id
:= No_List
;
4047 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4049 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4050 -- List of statements for extra formal parameters. It will appear
4051 -- after the regular statements for writing out parameters.
4053 pragma Warnings
(Off
);
4054 pragma Unreferenced
(RACW_Type
);
4055 -- Used only for the PolyORB case
4056 pragma Warnings
(On
);
4059 -- The general form of a calling stub for a given subprogram is:
4061 -- procedure X (...) is P : constant Partition_ID :=
4062 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4063 -- System.RPC.Params_Stream_Type (0); begin
4064 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4065 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4066 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4067 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4069 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4071 -- There are some variations: Do_APC is called for an asynchronous
4072 -- procedure and the part after the call is completely ommitted as
4073 -- well as the declaration of Result. For a function call, 'Input is
4074 -- always used to read the result even if it is constrained.
4077 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
4080 Make_Object_Declaration
(Loc
,
4081 Defining_Identifier
=> Stream_Parameter
,
4082 Aliased_Present
=> True,
4083 Object_Definition
=>
4084 Make_Subtype_Indication
(Loc
,
4086 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
4088 Make_Index_Or_Discriminant_Constraint
(Loc
,
4090 New_List
(Make_Integer_Literal
(Loc
, 0))))));
4092 if not Is_Known_Asynchronous
then
4094 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4097 Make_Object_Declaration
(Loc
,
4098 Defining_Identifier
=> Result_Parameter
,
4099 Aliased_Present
=> True,
4100 Object_Definition
=>
4101 Make_Subtype_Indication
(Loc
,
4103 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
4105 Make_Index_Or_Discriminant_Constraint
(Loc
,
4107 New_List
(Make_Integer_Literal
(Loc
, 0))))));
4109 Exception_Return_Parameter
:=
4110 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
4113 Make_Object_Declaration
(Loc
,
4114 Defining_Identifier
=> Exception_Return_Parameter
,
4115 Object_Definition
=>
4116 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
4119 Result_Parameter
:= Empty
;
4120 Exception_Return_Parameter
:= Empty
;
4123 -- Put first the RPC receiver corresponding to the remote package
4125 Append_To
(Statements
,
4126 Make_Attribute_Reference
(Loc
,
4128 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
4129 Attribute_Name
=> Name_Write
,
4130 Expressions
=> New_List
(
4131 Make_Attribute_Reference
(Loc
,
4133 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4136 Target_RPC_Receiver
)));
4138 -- Then put the Subprogram_Id of the subprogram we want to call in
4141 Append_To
(Statements
,
4142 Make_Attribute_Reference
(Loc
,
4144 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4147 Expressions
=> New_List
(
4148 Make_Attribute_Reference
(Loc
,
4150 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4151 Attribute_Name
=> Name_Access
),
4154 Current_Parameter
:= First
(Ordered_Parameters_List
);
4155 while Present
(Current_Parameter
) loop
4157 Typ
: constant Node_Id
:=
4158 Parameter_Type
(Current_Parameter
);
4160 Constrained
: Boolean;
4162 Extra_Parameter
: Entity_Id
;
4165 if Is_RACW_Controlling_Formal
4166 (Current_Parameter
, Stub_Type
)
4168 -- In the case of a controlling formal argument, we marshall
4169 -- its addr field rather than the local stub.
4171 Append_To
(Statements
,
4172 Pack_Node_Into_Stream
(Loc
,
4173 Stream
=> Stream_Parameter
,
4175 Make_Selected_Component
(Loc
,
4177 Defining_Identifier
(Current_Parameter
),
4178 Selector_Name
=> Name_Addr
),
4179 Etyp
=> RTE
(RE_Unsigned_64
)));
4182 Value
:= New_Occurrence_Of
4183 (Defining_Identifier
(Current_Parameter
), Loc
);
4185 -- Access type parameters are transmitted as in out
4186 -- parameters. However, a dereference is needed so that
4187 -- we marshall the designated object.
4189 if Nkind
(Typ
) = N_Access_Definition
then
4190 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4191 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4193 Etyp
:= Etype
(Typ
);
4197 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
4199 -- Any parameter but unconstrained out parameters are
4200 -- transmitted to the peer.
4202 if In_Present
(Current_Parameter
)
4203 or else not Out_Present
(Current_Parameter
)
4204 or else not Constrained
4206 Append_To
(Statements
,
4207 Make_Attribute_Reference
(Loc
,
4209 New_Occurrence_Of
(Etyp
, Loc
),
4211 Output_From_Constrained
(Constrained
),
4212 Expressions
=> New_List
(
4213 Make_Attribute_Reference
(Loc
,
4215 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4216 Attribute_Name
=> Name_Access
),
4221 -- If the current parameter has a dynamic constrained status,
4222 -- then this status is transmitted as well.
4223 -- This should be done for accessibility as well ???
4225 if Nkind
(Typ
) /= N_Access_Definition
4226 and then Need_Extra_Constrained
(Current_Parameter
)
4228 -- In this block, we do not use the extra formal that has
4229 -- been created because it does not exist at the time of
4230 -- expansion when building calling stubs for remote access
4231 -- to subprogram types. We create an extra variable of this
4232 -- type and push it in the stream after the regular
4235 Extra_Parameter
:= Make_Defining_Identifier
4236 (Loc
, New_Internal_Name
('P'));
4239 Make_Object_Declaration
(Loc
,
4240 Defining_Identifier
=> Extra_Parameter
,
4241 Constant_Present
=> True,
4242 Object_Definition
=>
4243 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4245 Make_Attribute_Reference
(Loc
,
4248 Defining_Identifier
(Current_Parameter
), Loc
),
4249 Attribute_Name
=> Name_Constrained
)));
4251 Append_To
(Extra_Formal_Statements
,
4252 Make_Attribute_Reference
(Loc
,
4254 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4257 Expressions
=> New_List
(
4258 Make_Attribute_Reference
(Loc
,
4260 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4263 New_Occurrence_Of
(Extra_Parameter
, Loc
))));
4266 Next
(Current_Parameter
);
4270 -- Append the formal statements list to the statements
4272 Append_List_To
(Statements
, Extra_Formal_Statements
);
4274 if not Is_Known_Non_Asynchronous
then
4276 -- Build the call to System.RPC.Do_APC
4278 Asynchronous_Statements
:= New_List
(
4279 Make_Procedure_Call_Statement
(Loc
,
4281 New_Occurrence_Of
(RTE
(RE_Do_Apc
), Loc
),
4282 Parameter_Associations
=> New_List
(
4283 New_Occurrence_Of
(Target_Partition
, Loc
),
4284 Make_Attribute_Reference
(Loc
,
4286 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4290 Asynchronous_Statements
:= No_List
;
4293 if not Is_Known_Asynchronous
then
4295 -- Build the call to System.RPC.Do_RPC
4297 Non_Asynchronous_Statements
:= New_List
(
4298 Make_Procedure_Call_Statement
(Loc
,
4300 New_Occurrence_Of
(RTE
(RE_Do_Rpc
), Loc
),
4301 Parameter_Associations
=> New_List
(
4302 New_Occurrence_Of
(Target_Partition
, Loc
),
4304 Make_Attribute_Reference
(Loc
,
4306 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4310 Make_Attribute_Reference
(Loc
,
4312 New_Occurrence_Of
(Result_Parameter
, Loc
),
4316 -- Read the exception occurrence from the result stream and
4317 -- reraise it. It does no harm if this is a Null_Occurrence since
4318 -- this does nothing.
4320 Append_To
(Non_Asynchronous_Statements
,
4321 Make_Attribute_Reference
(Loc
,
4323 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4328 Expressions
=> New_List
(
4329 Make_Attribute_Reference
(Loc
,
4331 New_Occurrence_Of
(Result_Parameter
, Loc
),
4334 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
4336 Append_To
(Non_Asynchronous_Statements
,
4337 Make_Procedure_Call_Statement
(Loc
,
4339 New_Occurrence_Of
(RTE
(RE_Reraise_Occurrence
), Loc
),
4340 Parameter_Associations
=> New_List
(
4341 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
4345 -- If this is a function call, then read the value and return
4346 -- it. The return value is written/read using 'Output/'Input.
4348 Append_To
(Non_Asynchronous_Statements
,
4349 Make_Tag_Check
(Loc
,
4350 Make_Simple_Return_Statement
(Loc
,
4352 Make_Attribute_Reference
(Loc
,
4355 Etype
(Result_Definition
(Spec
)), Loc
),
4357 Attribute_Name
=> Name_Input
,
4359 Expressions
=> New_List
(
4360 Make_Attribute_Reference
(Loc
,
4362 New_Occurrence_Of
(Result_Parameter
, Loc
),
4363 Attribute_Name
=> Name_Access
))))));
4366 -- Loop around parameters and assign out (or in out)
4367 -- parameters. In the case of RACW, controlling arguments
4368 -- cannot possibly have changed since they are remote, so we do
4369 -- not read them from the stream.
4371 Current_Parameter
:= First
(Ordered_Parameters_List
);
4372 while Present
(Current_Parameter
) loop
4374 Typ
: constant Node_Id
:=
4375 Parameter_Type
(Current_Parameter
);
4382 (Defining_Identifier
(Current_Parameter
), Loc
);
4384 if Nkind
(Typ
) = N_Access_Definition
then
4385 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4386 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4388 Etyp
:= Etype
(Typ
);
4391 if (Out_Present
(Current_Parameter
)
4392 or else Nkind
(Typ
) = N_Access_Definition
)
4393 and then Etyp
/= Stub_Type
4395 Append_To
(Non_Asynchronous_Statements
,
4396 Make_Attribute_Reference
(Loc
,
4398 New_Occurrence_Of
(Etyp
, Loc
),
4400 Attribute_Name
=> Name_Read
,
4402 Expressions
=> New_List
(
4403 Make_Attribute_Reference
(Loc
,
4405 New_Occurrence_Of
(Result_Parameter
, Loc
),
4412 Next
(Current_Parameter
);
4417 if Is_Known_Asynchronous
then
4418 Append_List_To
(Statements
, Asynchronous_Statements
);
4420 elsif Is_Known_Non_Asynchronous
then
4421 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
4424 pragma Assert
(Present
(Asynchronous
));
4425 Prepend_To
(Asynchronous_Statements
,
4426 Make_Attribute_Reference
(Loc
,
4427 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4428 Attribute_Name
=> Name_Write
,
4429 Expressions
=> New_List
(
4430 Make_Attribute_Reference
(Loc
,
4432 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4433 Attribute_Name
=> Name_Access
),
4434 New_Occurrence_Of
(Standard_True
, Loc
))));
4436 Prepend_To
(Non_Asynchronous_Statements
,
4437 Make_Attribute_Reference
(Loc
,
4438 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4439 Attribute_Name
=> Name_Write
,
4440 Expressions
=> New_List
(
4441 Make_Attribute_Reference
(Loc
,
4443 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4444 Attribute_Name
=> Name_Access
),
4445 New_Occurrence_Of
(Standard_False
, Loc
))));
4447 Append_To
(Statements
,
4448 Make_Implicit_If_Statement
(Nod
,
4449 Condition
=> Asynchronous
,
4450 Then_Statements
=> Asynchronous_Statements
,
4451 Else_Statements
=> Non_Asynchronous_Statements
));
4453 end Build_General_Calling_Stubs
;
4455 -----------------------------
4456 -- Build_RPC_Receiver_Body --
4457 -----------------------------
4459 procedure Build_RPC_Receiver_Body
4460 (RPC_Receiver
: Entity_Id
;
4461 Request
: out Entity_Id
;
4462 Subp_Id
: out Entity_Id
;
4463 Subp_Index
: out Entity_Id
;
4464 Stmts
: out List_Id
;
4467 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
4469 RPC_Receiver_Spec
: Node_Id
;
4470 RPC_Receiver_Decls
: List_Id
;
4473 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
4475 RPC_Receiver_Spec
:=
4476 Build_RPC_Receiver_Specification
4477 (RPC_Receiver
=> RPC_Receiver
,
4478 Request_Parameter
=> Request
);
4480 Subp_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4481 Subp_Index
:= Subp_Id
;
4483 -- Subp_Id may not be a constant, because in the case of the RPC
4484 -- receiver for an RCI package, when a call is received from a RAS
4485 -- dereference, it will be assigned during subsequent processing.
4487 RPC_Receiver_Decls
:= New_List
(
4488 Make_Object_Declaration
(Loc
,
4489 Defining_Identifier
=> Subp_Id
,
4490 Object_Definition
=>
4491 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4493 Make_Attribute_Reference
(Loc
,
4495 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4496 Attribute_Name
=> Name_Input
,
4497 Expressions
=> New_List
(
4498 Make_Selected_Component
(Loc
,
4500 Selector_Name
=> Name_Params
)))));
4505 Make_Subprogram_Body
(Loc
,
4506 Specification
=> RPC_Receiver_Spec
,
4507 Declarations
=> RPC_Receiver_Decls
,
4508 Handled_Statement_Sequence
=>
4509 Make_Handled_Sequence_Of_Statements
(Loc
,
4510 Statements
=> Stmts
));
4511 end Build_RPC_Receiver_Body
;
4513 -----------------------
4514 -- Build_Stub_Target --
4515 -----------------------
4517 function Build_Stub_Target
4520 RCI_Locator
: Entity_Id
;
4521 Controlling_Parameter
: Entity_Id
) return RPC_Target
4523 Target_Info
: RPC_Target
(PCS_Kind
=> Name_GARLIC_DSA
);
4525 Target_Info
.Partition
:=
4526 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4527 if Present
(Controlling_Parameter
) then
4529 Make_Object_Declaration
(Loc
,
4530 Defining_Identifier
=> Target_Info
.Partition
,
4531 Constant_Present
=> True,
4532 Object_Definition
=>
4533 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4536 Make_Selected_Component
(Loc
,
4537 Prefix
=> Controlling_Parameter
,
4538 Selector_Name
=> Name_Origin
)));
4540 Target_Info
.RPC_Receiver
:=
4541 Make_Selected_Component
(Loc
,
4542 Prefix
=> Controlling_Parameter
,
4543 Selector_Name
=> Name_Receiver
);
4547 Make_Object_Declaration
(Loc
,
4548 Defining_Identifier
=> Target_Info
.Partition
,
4549 Constant_Present
=> True,
4550 Object_Definition
=>
4551 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4554 Make_Function_Call
(Loc
,
4555 Name
=> Make_Selected_Component
(Loc
,
4557 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4559 Make_Identifier
(Loc
,
4560 Name_Get_Active_Partition_ID
)))));
4562 Target_Info
.RPC_Receiver
:=
4563 Make_Selected_Component
(Loc
,
4565 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4567 Make_Identifier
(Loc
, Name_Get_RCI_Package_Receiver
));
4570 end Build_Stub_Target
;
4572 ---------------------
4573 -- Build_Stub_Type --
4574 ---------------------
4576 procedure Build_Stub_Type
4577 (RACW_Type
: Entity_Id
;
4578 Stub_Type
: Entity_Id
;
4579 Stub_Type_Decl
: out Node_Id
;
4580 RPC_Receiver_Decl
: out Node_Id
)
4582 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
4583 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
4587 Make_Full_Type_Declaration
(Loc
,
4588 Defining_Identifier
=> Stub_Type
,
4590 Make_Record_Definition
(Loc
,
4591 Tagged_Present
=> True,
4592 Limited_Present
=> True,
4594 Make_Component_List
(Loc
,
4595 Component_Items
=> New_List
(
4597 Make_Component_Declaration
(Loc
,
4598 Defining_Identifier
=>
4599 Make_Defining_Identifier
(Loc
, Name_Origin
),
4600 Component_Definition
=>
4601 Make_Component_Definition
(Loc
,
4602 Aliased_Present
=> False,
4603 Subtype_Indication
=>
4605 RTE
(RE_Partition_ID
), Loc
))),
4607 Make_Component_Declaration
(Loc
,
4608 Defining_Identifier
=>
4609 Make_Defining_Identifier
(Loc
, Name_Receiver
),
4610 Component_Definition
=>
4611 Make_Component_Definition
(Loc
,
4612 Aliased_Present
=> False,
4613 Subtype_Indication
=>
4614 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4616 Make_Component_Declaration
(Loc
,
4617 Defining_Identifier
=>
4618 Make_Defining_Identifier
(Loc
, Name_Addr
),
4619 Component_Definition
=>
4620 Make_Component_Definition
(Loc
,
4621 Aliased_Present
=> False,
4622 Subtype_Indication
=>
4623 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4625 Make_Component_Declaration
(Loc
,
4626 Defining_Identifier
=>
4627 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
4628 Component_Definition
=>
4629 Make_Component_Definition
(Loc
,
4630 Aliased_Present
=> False,
4631 Subtype_Indication
=>
4633 Standard_Boolean
, Loc
)))))));
4636 RPC_Receiver_Decl
:= Empty
;
4639 RPC_Receiver_Request
: constant Entity_Id
:=
4640 Make_Defining_Identifier
(Loc
, Name_R
);
4642 RPC_Receiver_Decl
:=
4643 Make_Subprogram_Declaration
(Loc
,
4644 Build_RPC_Receiver_Specification
(
4645 RPC_Receiver
=> Make_Defining_Identifier
(Loc
,
4646 New_Internal_Name
('R')),
4647 Request_Parameter
=> RPC_Receiver_Request
));
4650 end Build_Stub_Type
;
4652 --------------------------------------
4653 -- Build_Subprogram_Receiving_Stubs --
4654 --------------------------------------
4656 function Build_Subprogram_Receiving_Stubs
4657 (Vis_Decl
: Node_Id
;
4658 Asynchronous
: Boolean;
4659 Dynamically_Asynchronous
: Boolean := False;
4660 Stub_Type
: Entity_Id
:= Empty
;
4661 RACW_Type
: Entity_Id
:= Empty
;
4662 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
4664 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
4666 Request_Parameter
: constant Entity_Id
:=
4667 Make_Defining_Identifier
(Loc
,
4668 New_Internal_Name
('R'));
4669 -- Formal parameter for receiving stubs: a descriptor for an incoming
4672 Decls
: constant List_Id
:= New_List
;
4673 -- All the parameters will get declared before calling the real
4674 -- subprograms. Also the out parameters will be declared.
4676 Statements
: constant List_Id
:= New_List
;
4678 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4679 -- Statements concerning extra formal parameters
4681 After_Statements
: constant List_Id
:= New_List
;
4682 -- Statements to be executed after the subprogram call
4684 Inner_Decls
: List_Id
:= No_List
;
4685 -- In case of a function, the inner declarations are needed since
4686 -- the result may be unconstrained.
4688 Excep_Handlers
: List_Id
:= No_List
;
4689 Excep_Choice
: Entity_Id
;
4690 Excep_Code
: List_Id
;
4692 Parameter_List
: constant List_Id
:= New_List
;
4693 -- List of parameters to be passed to the subprogram
4695 Current_Parameter
: Node_Id
;
4697 Ordered_Parameters_List
: constant List_Id
:=
4698 Build_Ordered_Parameters_List
4699 (Specification
(Vis_Decl
));
4701 Subp_Spec
: Node_Id
;
4702 -- Subprogram specification
4704 Called_Subprogram
: Node_Id
;
4705 -- The subprogram to call
4707 Null_Raise_Statement
: Node_Id
;
4709 Dynamic_Async
: Entity_Id
;
4712 if Present
(RACW_Type
) then
4713 Called_Subprogram
:= New_Occurrence_Of
(Parent_Primitive
, Loc
);
4715 Called_Subprogram
:=
4717 (Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
4720 if Dynamically_Asynchronous
then
4722 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
4724 Dynamic_Async
:= Empty
;
4727 if not Asynchronous
or Dynamically_Asynchronous
then
4729 -- The first statement after the subprogram call is a statement to
4730 -- write a Null_Occurrence into the result stream.
4732 Null_Raise_Statement
:=
4733 Make_Attribute_Reference
(Loc
,
4735 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4736 Attribute_Name
=> Name_Write
,
4737 Expressions
=> New_List
(
4738 Make_Selected_Component
(Loc
,
4739 Prefix
=> Request_Parameter
,
4740 Selector_Name
=> Name_Result
),
4741 New_Occurrence_Of
(RTE
(RE_Null_Occurrence
), Loc
)));
4743 if Dynamically_Asynchronous
then
4744 Null_Raise_Statement
:=
4745 Make_Implicit_If_Statement
(Vis_Decl
,
4747 Make_Op_Not
(Loc
, New_Occurrence_Of
(Dynamic_Async
, Loc
)),
4748 Then_Statements
=> New_List
(Null_Raise_Statement
));
4751 Append_To
(After_Statements
, Null_Raise_Statement
);
4754 -- Loop through every parameter and get its value from the stream. If
4755 -- the parameter is unconstrained, then the parameter is read using
4756 -- 'Input at the point of declaration.
4758 Current_Parameter
:= First
(Ordered_Parameters_List
);
4759 while Present
(Current_Parameter
) loop
4762 Constrained
: Boolean;
4764 Need_Extra_Constrained
: Boolean;
4765 -- True when an Extra_Constrained actual is required
4767 Object
: constant Entity_Id
:=
4768 Make_Defining_Identifier
(Loc
,
4769 New_Internal_Name
('P'));
4771 Expr
: Node_Id
:= Empty
;
4773 Is_Controlling_Formal
: constant Boolean :=
4774 Is_RACW_Controlling_Formal
4775 (Current_Parameter
, Stub_Type
);
4778 if Is_Controlling_Formal
then
4780 -- We have a controlling formal parameter. Read its address
4781 -- rather than a real object. The address is in Unsigned_64
4784 Etyp
:= RTE
(RE_Unsigned_64
);
4786 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
4790 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
4792 if In_Present
(Current_Parameter
)
4793 or else not Out_Present
(Current_Parameter
)
4794 or else not Constrained
4795 or else Is_Controlling_Formal
4797 -- If an input parameter is constrained, then the read of
4798 -- the parameter is deferred until the beginning of the
4799 -- subprogram body. If it is unconstrained, then an
4800 -- expression is built for the object declaration and the
4801 -- variable is set using 'Input instead of 'Read. Note that
4802 -- this deferral does not change the order in which the
4803 -- actuals are read because Build_Ordered_Parameter_List
4804 -- puts them unconstrained first.
4807 Append_To
(Statements
,
4808 Make_Attribute_Reference
(Loc
,
4809 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4810 Attribute_Name
=> Name_Read
,
4811 Expressions
=> New_List
(
4812 Make_Selected_Component
(Loc
,
4813 Prefix
=> Request_Parameter
,
4814 Selector_Name
=> Name_Params
),
4815 New_Occurrence_Of
(Object
, Loc
))));
4819 -- Build and append Input_With_Tag_Check function
4822 Input_With_Tag_Check
(Loc
,
4824 Stream
=> Make_Selected_Component
(Loc
,
4825 Prefix
=> Request_Parameter
,
4826 Selector_Name
=> Name_Params
)));
4828 -- Prepare function call expression
4830 Expr
:= Make_Function_Call
(Loc
,
4831 New_Occurrence_Of
(Defining_Unit_Name
4832 (Specification
(Last
(Decls
))), Loc
));
4836 Need_Extra_Constrained
:=
4837 Nkind
(Parameter_Type
(Current_Parameter
)) /=
4840 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
4842 Present
(Extra_Constrained
4843 (Defining_Identifier
(Current_Parameter
)));
4845 -- We may not associate an extra constrained actual to a
4846 -- constant object, so if one is needed, declare the actual
4847 -- as a variable even if it won't be modified.
4849 Build_Actual_Object_Declaration
4852 Variable
=> Need_Extra_Constrained
4853 or else Out_Present
(Current_Parameter
),
4857 -- An out parameter may be written back using a 'Write
4858 -- attribute instead of a 'Output because it has been
4859 -- constrained by the parameter given to the caller. Note that
4860 -- out controlling arguments in the case of a RACW are not put
4861 -- back in the stream because the pointer on them has not
4864 if Out_Present
(Current_Parameter
)
4866 Etype
(Parameter_Type
(Current_Parameter
)) /= Stub_Type
4868 Append_To
(After_Statements
,
4869 Make_Attribute_Reference
(Loc
,
4870 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4871 Attribute_Name
=> Name_Write
,
4872 Expressions
=> New_List
(
4873 Make_Selected_Component
(Loc
,
4874 Prefix
=> Request_Parameter
,
4875 Selector_Name
=> Name_Result
),
4876 New_Occurrence_Of
(Object
, Loc
))));
4879 -- For RACW controlling formals, the Etyp of Object is always
4880 -- an RACW, even if the parameter is not of an anonymous access
4881 -- type. In such case, we need to dereference it at call time.
4883 if Is_Controlling_Formal
then
4884 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
4887 Append_To
(Parameter_List
,
4888 Make_Parameter_Association
(Loc
,
4891 Defining_Identifier
(Current_Parameter
), Loc
),
4892 Explicit_Actual_Parameter
=>
4893 Make_Explicit_Dereference
(Loc
,
4894 Unchecked_Convert_To
(RACW_Type
,
4895 OK_Convert_To
(RTE
(RE_Address
),
4896 New_Occurrence_Of
(Object
, Loc
))))));
4899 Append_To
(Parameter_List
,
4900 Make_Parameter_Association
(Loc
,
4903 Defining_Identifier
(Current_Parameter
), Loc
),
4904 Explicit_Actual_Parameter
=>
4905 Unchecked_Convert_To
(RACW_Type
,
4906 OK_Convert_To
(RTE
(RE_Address
),
4907 New_Occurrence_Of
(Object
, Loc
)))));
4911 Append_To
(Parameter_List
,
4912 Make_Parameter_Association
(Loc
,
4915 Defining_Identifier
(Current_Parameter
), Loc
),
4916 Explicit_Actual_Parameter
=>
4917 New_Occurrence_Of
(Object
, Loc
)));
4920 -- If the current parameter needs an extra formal, then read it
4921 -- from the stream and set the corresponding semantic field in
4922 -- the variable. If the kind of the parameter identifier is
4923 -- E_Void, then this is a compiler generated parameter that
4924 -- doesn't need an extra constrained status.
4926 -- The case of Extra_Accessibility should also be handled ???
4928 if Need_Extra_Constrained
then
4930 Extra_Parameter
: constant Entity_Id
:=
4932 (Defining_Identifier
4933 (Current_Parameter
));
4935 Formal_Entity
: constant Entity_Id
:=
4936 Make_Defining_Identifier
4937 (Loc
, Chars
(Extra_Parameter
));
4939 Formal_Type
: constant Entity_Id
:=
4940 Etype
(Extra_Parameter
);
4944 Make_Object_Declaration
(Loc
,
4945 Defining_Identifier
=> Formal_Entity
,
4946 Object_Definition
=>
4947 New_Occurrence_Of
(Formal_Type
, Loc
)));
4949 Append_To
(Extra_Formal_Statements
,
4950 Make_Attribute_Reference
(Loc
,
4951 Prefix
=> New_Occurrence_Of
(
4953 Attribute_Name
=> Name_Read
,
4954 Expressions
=> New_List
(
4955 Make_Selected_Component
(Loc
,
4956 Prefix
=> Request_Parameter
,
4957 Selector_Name
=> Name_Params
),
4958 New_Occurrence_Of
(Formal_Entity
, Loc
))));
4960 -- Note: the call to Set_Extra_Constrained below relies
4961 -- on the fact that Object's Ekind has been set by
4962 -- Build_Actual_Object_Declaration.
4964 Set_Extra_Constrained
(Object
, Formal_Entity
);
4969 Next
(Current_Parameter
);
4972 -- Append the formal statements list at the end of regular statements
4974 Append_List_To
(Statements
, Extra_Formal_Statements
);
4976 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
4978 -- The remote subprogram is a function. We build an inner block to
4979 -- be able to hold a potentially unconstrained result in a
4983 Etyp
: constant Entity_Id
:=
4984 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
4985 Result
: constant Node_Id
:=
4986 Make_Defining_Identifier
(Loc
,
4987 New_Internal_Name
('R'));
4989 Inner_Decls
:= New_List
(
4990 Make_Object_Declaration
(Loc
,
4991 Defining_Identifier
=> Result
,
4992 Constant_Present
=> True,
4993 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
4995 Make_Function_Call
(Loc
,
4996 Name
=> Called_Subprogram
,
4997 Parameter_Associations
=> Parameter_List
)));
4999 if Is_Class_Wide_Type
(Etyp
) then
5001 -- For a remote call to a function with a class-wide type,
5002 -- check that the returned value satisfies the requirements
5005 Append_To
(Inner_Decls
,
5006 Make_Transportable_Check
(Loc
,
5007 New_Occurrence_Of
(Result
, Loc
)));
5011 Append_To
(After_Statements
,
5012 Make_Attribute_Reference
(Loc
,
5013 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5014 Attribute_Name
=> Name_Output
,
5015 Expressions
=> New_List
(
5016 Make_Selected_Component
(Loc
,
5017 Prefix
=> Request_Parameter
,
5018 Selector_Name
=> Name_Result
),
5019 New_Occurrence_Of
(Result
, Loc
))));
5022 Append_To
(Statements
,
5023 Make_Block_Statement
(Loc
,
5024 Declarations
=> Inner_Decls
,
5025 Handled_Statement_Sequence
=>
5026 Make_Handled_Sequence_Of_Statements
(Loc
,
5027 Statements
=> After_Statements
)));
5030 -- The remote subprogram is a procedure. We do not need any inner
5031 -- block in this case.
5033 if Dynamically_Asynchronous
then
5035 Make_Object_Declaration
(Loc
,
5036 Defining_Identifier
=> Dynamic_Async
,
5037 Object_Definition
=>
5038 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
5040 Append_To
(Statements
,
5041 Make_Attribute_Reference
(Loc
,
5042 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
5043 Attribute_Name
=> Name_Read
,
5044 Expressions
=> New_List
(
5045 Make_Selected_Component
(Loc
,
5046 Prefix
=> Request_Parameter
,
5047 Selector_Name
=> Name_Params
),
5048 New_Occurrence_Of
(Dynamic_Async
, Loc
))));
5051 Append_To
(Statements
,
5052 Make_Procedure_Call_Statement
(Loc
,
5053 Name
=> Called_Subprogram
,
5054 Parameter_Associations
=> Parameter_List
));
5056 Append_List_To
(Statements
, After_Statements
);
5059 if Asynchronous
and then not Dynamically_Asynchronous
then
5061 -- For an asynchronous procedure, add a null exception handler
5063 Excep_Handlers
:= New_List
(
5064 Make_Implicit_Exception_Handler
(Loc
,
5065 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5066 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
5069 -- In the other cases, if an exception is raised, then the
5070 -- exception occurrence is copied into the output stream and
5071 -- no other output parameter is written.
5074 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
5076 Excep_Code
:= New_List
(
5077 Make_Attribute_Reference
(Loc
,
5079 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
5080 Attribute_Name
=> Name_Write
,
5081 Expressions
=> New_List
(
5082 Make_Selected_Component
(Loc
,
5083 Prefix
=> Request_Parameter
,
5084 Selector_Name
=> Name_Result
),
5085 New_Occurrence_Of
(Excep_Choice
, Loc
))));
5087 if Dynamically_Asynchronous
then
5088 Excep_Code
:= New_List
(
5089 Make_Implicit_If_Statement
(Vis_Decl
,
5090 Condition
=> Make_Op_Not
(Loc
,
5091 New_Occurrence_Of
(Dynamic_Async
, Loc
)),
5092 Then_Statements
=> Excep_Code
));
5095 Excep_Handlers
:= New_List
(
5096 Make_Implicit_Exception_Handler
(Loc
,
5097 Choice_Parameter
=> Excep_Choice
,
5098 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5099 Statements
=> Excep_Code
));
5104 Make_Procedure_Specification
(Loc
,
5105 Defining_Unit_Name
=>
5106 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
5108 Parameter_Specifications
=> New_List
(
5109 Make_Parameter_Specification
(Loc
,
5110 Defining_Identifier
=> Request_Parameter
,
5112 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
5115 Make_Subprogram_Body
(Loc
,
5116 Specification
=> Subp_Spec
,
5117 Declarations
=> Decls
,
5118 Handled_Statement_Sequence
=>
5119 Make_Handled_Sequence_Of_Statements
(Loc
,
5120 Statements
=> Statements
,
5121 Exception_Handlers
=> Excep_Handlers
));
5122 end Build_Subprogram_Receiving_Stubs
;
5128 function Result
return Node_Id
is
5130 return Make_Identifier
(Loc
, Name_V
);
5133 ----------------------
5134 -- Stream_Parameter --
5135 ----------------------
5137 function Stream_Parameter
return Node_Id
is
5139 return Make_Identifier
(Loc
, Name_S
);
5140 end Stream_Parameter
;
5144 -------------------------------
5145 -- Get_And_Reset_RACW_Bodies --
5146 -------------------------------
5148 function Get_And_Reset_RACW_Bodies
(RACW_Type
: Entity_Id
) return List_Id
is
5149 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
5150 Stub_Elements
: Stub_Structure
:= Stubs_Table
.Get
(Desig
);
5152 Body_Decls
: List_Id
;
5153 -- Returned list of declarations
5156 if Stub_Elements
= Empty_Stub_Structure
then
5158 -- Stub elements may be missing as a consequence of a previously
5164 Body_Decls
:= Stub_Elements
.Body_Decls
;
5165 Stub_Elements
.Body_Decls
:= No_List
;
5166 Stubs_Table
.Set
(Desig
, Stub_Elements
);
5168 end Get_And_Reset_RACW_Bodies
;
5170 -----------------------
5171 -- Get_Subprogram_Id --
5172 -----------------------
5174 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
is
5175 Result
: constant String_Id
:= Get_Subprogram_Ids
(Def
).Str_Identifier
;
5177 pragma Assert
(Result
/= No_String
);
5179 end Get_Subprogram_Id
;
5181 -----------------------
5182 -- Get_Subprogram_Id --
5183 -----------------------
5185 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
is
5187 return Get_Subprogram_Ids
(Def
).Int_Identifier
;
5188 end Get_Subprogram_Id
;
5190 ------------------------
5191 -- Get_Subprogram_Ids --
5192 ------------------------
5194 function Get_Subprogram_Ids
5195 (Def
: Entity_Id
) return Subprogram_Identifiers
5198 return Subprogram_Identifier_Table
.Get
(Def
);
5199 end Get_Subprogram_Ids
;
5205 function Hash
(F
: Entity_Id
) return Hash_Index
is
5207 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
5210 function Hash
(F
: Name_Id
) return Hash_Index
is
5212 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
5215 --------------------------
5216 -- Input_With_Tag_Check --
5217 --------------------------
5219 function Input_With_Tag_Check
5221 Var_Type
: Entity_Id
;
5222 Stream
: Node_Id
) return Node_Id
5226 Make_Subprogram_Body
(Loc
,
5227 Specification
=> Make_Function_Specification
(Loc
,
5228 Defining_Unit_Name
=>
5229 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S')),
5230 Result_Definition
=> New_Occurrence_Of
(Var_Type
, Loc
)),
5231 Declarations
=> No_List
,
5232 Handled_Statement_Sequence
=>
5233 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
5234 Make_Tag_Check
(Loc
,
5235 Make_Simple_Return_Statement
(Loc
,
5236 Make_Attribute_Reference
(Loc
,
5237 Prefix
=> New_Occurrence_Of
(Var_Type
, Loc
),
5238 Attribute_Name
=> Name_Input
,
5240 New_List
(Stream
)))))));
5241 end Input_With_Tag_Check
;
5243 --------------------------------
5244 -- Is_RACW_Controlling_Formal --
5245 --------------------------------
5247 function Is_RACW_Controlling_Formal
5248 (Parameter
: Node_Id
;
5249 Stub_Type
: Entity_Id
) return Boolean
5254 -- If the kind of the parameter is E_Void, then it is not a
5255 -- controlling formal (this can happen in the context of RAS).
5257 if Ekind
(Defining_Identifier
(Parameter
)) = E_Void
then
5261 -- If the parameter is not a controlling formal, then it cannot
5262 -- be possibly a RACW_Controlling_Formal.
5264 if not Is_Controlling_Formal
(Defining_Identifier
(Parameter
)) then
5268 Typ
:= Parameter_Type
(Parameter
);
5269 return (Nkind
(Typ
) = N_Access_Definition
5270 and then Etype
(Subtype_Mark
(Typ
)) = Stub_Type
)
5271 or else Etype
(Typ
) = Stub_Type
;
5272 end Is_RACW_Controlling_Formal
;
5274 ------------------------------
5275 -- Make_Transportable_Check --
5276 ------------------------------
5278 function Make_Transportable_Check
5280 Expr
: Node_Id
) return Node_Id
is
5283 Make_Raise_Program_Error
(Loc
,
5286 Build_Get_Transportable
(Loc
,
5287 Make_Selected_Component
(Loc
,
5289 Selector_Name
=> Make_Identifier
(Loc
, Name_uTag
)))),
5290 Reason
=> PE_Non_Transportable_Actual
);
5291 end Make_Transportable_Check
;
5293 -----------------------------
5294 -- Make_Selected_Component --
5295 -----------------------------
5297 function Make_Selected_Component
5300 Selector_Name
: Name_Id
) return Node_Id
5303 return Make_Selected_Component
(Loc
,
5304 Prefix
=> New_Occurrence_Of
(Prefix
, Loc
),
5305 Selector_Name
=> Make_Identifier
(Loc
, Selector_Name
));
5306 end Make_Selected_Component
;
5308 --------------------
5309 -- Make_Tag_Check --
5310 --------------------
5312 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
is
5313 Occ
: constant Entity_Id
:=
5314 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
5317 return Make_Block_Statement
(Loc
,
5318 Handled_Statement_Sequence
=>
5319 Make_Handled_Sequence_Of_Statements
(Loc
,
5320 Statements
=> New_List
(N
),
5322 Exception_Handlers
=> New_List
(
5323 Make_Implicit_Exception_Handler
(Loc
,
5324 Choice_Parameter
=> Occ
,
5326 Exception_Choices
=>
5327 New_List
(New_Occurrence_Of
(RTE
(RE_Tag_Error
), Loc
)),
5330 New_List
(Make_Procedure_Call_Statement
(Loc
,
5332 (RTE
(RE_Raise_Program_Error_Unknown_Tag
), Loc
),
5333 New_List
(New_Occurrence_Of
(Occ
, Loc
))))))));
5336 ----------------------------
5337 -- Need_Extra_Constrained --
5338 ----------------------------
5340 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean is
5341 Etyp
: constant Entity_Id
:= Etype
(Parameter_Type
(Parameter
));
5343 return Out_Present
(Parameter
)
5344 and then Has_Discriminants
(Etyp
)
5345 and then not Is_Constrained
(Etyp
)
5346 and then not Is_Indefinite_Subtype
(Etyp
);
5347 end Need_Extra_Constrained
;
5349 ------------------------------------
5350 -- Pack_Entity_Into_Stream_Access --
5351 ------------------------------------
5353 function Pack_Entity_Into_Stream_Access
5357 Etyp
: Entity_Id
:= Empty
) return Node_Id
5362 if Present
(Etyp
) then
5365 Typ
:= Etype
(Object
);
5369 Pack_Node_Into_Stream_Access
(Loc
,
5371 Object
=> New_Occurrence_Of
(Object
, Loc
),
5373 end Pack_Entity_Into_Stream_Access
;
5375 ---------------------------
5376 -- Pack_Node_Into_Stream --
5377 ---------------------------
5379 function Pack_Node_Into_Stream
5383 Etyp
: Entity_Id
) return Node_Id
5385 Write_Attribute
: Name_Id
:= Name_Write
;
5388 if not Is_Constrained
(Etyp
) then
5389 Write_Attribute
:= Name_Output
;
5393 Make_Attribute_Reference
(Loc
,
5394 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5395 Attribute_Name
=> Write_Attribute
,
5396 Expressions
=> New_List
(
5397 Make_Attribute_Reference
(Loc
,
5398 Prefix
=> New_Occurrence_Of
(Stream
, Loc
),
5399 Attribute_Name
=> Name_Access
),
5401 end Pack_Node_Into_Stream
;
5403 ----------------------------------
5404 -- Pack_Node_Into_Stream_Access --
5405 ----------------------------------
5407 function Pack_Node_Into_Stream_Access
5411 Etyp
: Entity_Id
) return Node_Id
5413 Write_Attribute
: Name_Id
:= Name_Write
;
5416 if not Is_Constrained
(Etyp
) then
5417 Write_Attribute
:= Name_Output
;
5421 Make_Attribute_Reference
(Loc
,
5422 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5423 Attribute_Name
=> Write_Attribute
,
5424 Expressions
=> New_List
(
5427 end Pack_Node_Into_Stream_Access
;
5429 ---------------------
5430 -- PolyORB_Support --
5431 ---------------------
5433 package body PolyORB_Support
is
5435 -- Local subprograms
5437 procedure Add_RACW_Read_Attribute
5438 (RACW_Type
: Entity_Id
;
5439 Stub_Type
: Entity_Id
;
5440 Stub_Type_Access
: Entity_Id
;
5441 Body_Decls
: List_Id
);
5442 -- Add Read attribute for the RACW type. The declaration and attribute
5443 -- definition clauses are inserted right after the declaration of
5444 -- RACW_Type, while the subprogram body is appended to Body_Decls.
5446 procedure Add_RACW_Write_Attribute
5447 (RACW_Type
: Entity_Id
;
5448 Stub_Type
: Entity_Id
;
5449 Stub_Type_Access
: Entity_Id
;
5450 Body_Decls
: List_Id
);
5451 -- Same as above for the Write attribute
5453 procedure Add_RACW_From_Any
5454 (RACW_Type
: Entity_Id
;
5455 Stub_Type
: Entity_Id
;
5456 Stub_Type_Access
: Entity_Id
;
5457 Body_Decls
: List_Id
);
5458 -- Add the From_Any TSS for this RACW type
5460 procedure Add_RACW_To_Any
5461 (Designated_Type
: Entity_Id
;
5462 RACW_Type
: Entity_Id
;
5463 Stub_Type
: Entity_Id
;
5464 Stub_Type_Access
: Entity_Id
;
5465 Body_Decls
: List_Id
);
5466 -- Add the To_Any TSS for this RACW type
5468 procedure Add_RACW_TypeCode
5469 (Designated_Type
: Entity_Id
;
5470 RACW_Type
: Entity_Id
;
5471 Body_Decls
: List_Id
);
5472 -- Add the TypeCode TSS for this RACW type
5474 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
);
5475 -- Add the From_Any TSS for this RAS type
5477 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
);
5478 -- Add the To_Any TSS for this RAS type
5480 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
);
5481 -- Add the TypeCode TSS for this RAS type
5483 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
5484 -- Add a subprogram body for RAS Access TSS
5486 -------------------------------------
5487 -- Add_Obj_RPC_Receiver_Completion --
5488 -------------------------------------
5490 procedure Add_Obj_RPC_Receiver_Completion
5493 RPC_Receiver
: Entity_Id
;
5494 Stub_Elements
: Stub_Structure
)
5496 Desig
: constant Entity_Id
:=
5497 Etype
(Designated_Type
(Stub_Elements
.RACW_Type
));
5500 Make_Procedure_Call_Statement
(Loc
,
5503 RTE
(RE_Register_Obj_Receiving_Stub
), Loc
),
5505 Parameter_Associations
=> New_List
(
5509 Make_String_Literal
(Loc
,
5510 Full_Qualified_Name
(Desig
)),
5514 Make_Attribute_Reference
(Loc
,
5517 Defining_Unit_Name
(Parent
(RPC_Receiver
)), Loc
),
5523 Make_Attribute_Reference
(Loc
,
5526 Defining_Identifier
(
5527 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5530 end Add_Obj_RPC_Receiver_Completion
;
5532 -----------------------
5533 -- Add_RACW_Features --
5534 -----------------------
5536 procedure Add_RACW_Features
5537 (RACW_Type
: Entity_Id
;
5539 Stub_Type
: Entity_Id
;
5540 Stub_Type_Access
: Entity_Id
;
5541 RPC_Receiver_Decl
: Node_Id
;
5542 Body_Decls
: List_Id
)
5544 pragma Warnings
(Off
);
5545 pragma Unreferenced
(RPC_Receiver_Decl
);
5546 pragma Warnings
(On
);
5550 (RACW_Type
=> RACW_Type
,
5551 Stub_Type
=> Stub_Type
,
5552 Stub_Type_Access
=> Stub_Type_Access
,
5553 Body_Decls
=> Body_Decls
);
5556 (Designated_Type
=> Desig
,
5557 RACW_Type
=> RACW_Type
,
5558 Stub_Type
=> Stub_Type
,
5559 Stub_Type_Access
=> Stub_Type_Access
,
5560 Body_Decls
=> Body_Decls
);
5562 -- In the PolyORB case, the RACW 'Read and 'Write attributes are
5563 -- implemented in terms of the From_Any and To_Any TSSs, so these
5564 -- TSSs must be expanded before 'Read and 'Write.
5566 Add_RACW_Write_Attribute
5567 (RACW_Type
=> RACW_Type
,
5568 Stub_Type
=> Stub_Type
,
5569 Stub_Type_Access
=> Stub_Type_Access
,
5570 Body_Decls
=> Body_Decls
);
5572 Add_RACW_Read_Attribute
5573 (RACW_Type
=> RACW_Type
,
5574 Stub_Type
=> Stub_Type
,
5575 Stub_Type_Access
=> Stub_Type_Access
,
5576 Body_Decls
=> Body_Decls
);
5579 (Designated_Type
=> Desig
,
5580 RACW_Type
=> RACW_Type
,
5581 Body_Decls
=> Body_Decls
);
5582 end Add_RACW_Features
;
5584 -----------------------
5585 -- Add_RACW_From_Any --
5586 -----------------------
5588 procedure Add_RACW_From_Any
5589 (RACW_Type
: Entity_Id
;
5590 Stub_Type
: Entity_Id
;
5591 Stub_Type_Access
: Entity_Id
;
5592 Body_Decls
: List_Id
)
5594 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5595 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5597 Fnam
: constant Entity_Id
:=
5598 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F'));
5600 Func_Spec
: Node_Id
;
5601 Func_Decl
: Node_Id
;
5602 Func_Body
: Node_Id
;
5605 Statements
: List_Id
;
5606 Stub_Statements
: List_Id
;
5607 Local_Statements
: List_Id
;
5608 -- Various parts of the subprogram
5610 Any_Parameter
: constant Entity_Id
:=
5611 Make_Defining_Identifier
(Loc
, Name_A
);
5612 Reference
: constant Entity_Id
:=
5613 Make_Defining_Identifier
5614 (Loc
, New_Internal_Name
('R'));
5615 Is_Local
: constant Entity_Id
:=
5616 Make_Defining_Identifier
5617 (Loc
, New_Internal_Name
('L'));
5618 Addr
: constant Entity_Id
:=
5619 Make_Defining_Identifier
5620 (Loc
, New_Internal_Name
('A'));
5621 Local_Stub
: constant Entity_Id
:=
5622 Make_Defining_Identifier
5623 (Loc
, New_Internal_Name
('L'));
5624 Stubbed_Result
: constant Entity_Id
:=
5625 Make_Defining_Identifier
5626 (Loc
, New_Internal_Name
('S'));
5628 Stub_Condition
: Node_Id
;
5629 -- An expression that determines whether we create a stub for the
5630 -- newly-unpacked RACW. Normally we create a stub only for remote
5631 -- objects, but in the case of an RACW used to implement a RAS, we
5632 -- also create a stub for local subprograms if a pragma
5633 -- All_Calls_Remote applies.
5635 Asynchronous_Flag
: constant Entity_Id
:=
5636 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5637 -- The flag object declared in Add_RACW_Asynchronous_Flag
5641 -- Object declarations
5644 Make_Object_Declaration
(Loc
,
5645 Defining_Identifier
=>
5647 Object_Definition
=>
5648 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5650 Make_Function_Call
(Loc
,
5652 New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
5653 Parameter_Associations
=> New_List
(
5654 New_Occurrence_Of
(Any_Parameter
, Loc
)))),
5656 Make_Object_Declaration
(Loc
,
5657 Defining_Identifier
=> Local_Stub
,
5658 Aliased_Present
=> True,
5659 Object_Definition
=> New_Occurrence_Of
(Stub_Type
, Loc
)),
5661 Make_Object_Declaration
(Loc
,
5662 Defining_Identifier
=> Stubbed_Result
,
5663 Object_Definition
=>
5664 New_Occurrence_Of
(Stub_Type_Access
, Loc
),
5666 Make_Attribute_Reference
(Loc
,
5668 New_Occurrence_Of
(Local_Stub
, Loc
),
5670 Name_Unchecked_Access
)),
5672 Make_Object_Declaration
(Loc
,
5673 Defining_Identifier
=> Is_Local
,
5674 Object_Definition
=>
5675 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
5677 Make_Object_Declaration
(Loc
,
5678 Defining_Identifier
=> Addr
,
5679 Object_Definition
=>
5680 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
5682 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
5684 Set_Etype
(Stubbed_Result
, Stub_Type_Access
);
5686 -- If the ref Is_Nil, return a null pointer
5688 Statements
:= New_List
(
5689 Make_Implicit_If_Statement
(RACW_Type
,
5691 Make_Function_Call
(Loc
,
5693 New_Occurrence_Of
(RTE
(RE_Is_Nil
), Loc
),
5694 Parameter_Associations
=> New_List
(
5695 New_Occurrence_Of
(Reference
, Loc
))),
5696 Then_Statements
=> New_List
(
5697 Make_Simple_Return_Statement
(Loc
,
5699 Make_Null
(Loc
)))));
5701 Append_To
(Statements
,
5702 Make_Procedure_Call_Statement
(Loc
,
5704 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
5705 Parameter_Associations
=> New_List
(
5706 New_Occurrence_Of
(Reference
, Loc
),
5707 New_Occurrence_Of
(Is_Local
, Loc
),
5708 New_Occurrence_Of
(Addr
, Loc
))));
5710 -- If the object is located on another partition, then a stub object
5711 -- will be created with all the information needed to rebuild the
5712 -- real object at the other end. This stanza is always used in the
5713 -- case of RAS types, for which a stub is required even for local
5716 Stub_Statements
:= New_List
(
5717 Make_Assignment_Statement
(Loc
,
5718 Name
=> Make_Selected_Component
(Loc
,
5719 Prefix
=> Stubbed_Result
,
5720 Selector_Name
=> Name_Target
),
5722 Make_Function_Call
(Loc
,
5724 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
5725 Parameter_Associations
=> New_List
(
5726 New_Occurrence_Of
(Reference
, Loc
)))),
5728 Make_Procedure_Call_Statement
(Loc
,
5730 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
5731 Parameter_Associations
=> New_List
(
5732 Make_Selected_Component
(Loc
,
5733 Prefix
=> Stubbed_Result
,
5734 Selector_Name
=> Name_Target
))),
5736 Make_Assignment_Statement
(Loc
,
5737 Name
=> Make_Selected_Component
(Loc
,
5738 Prefix
=> Stubbed_Result
,
5739 Selector_Name
=> Name_Asynchronous
),
5741 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)));
5743 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5744 -- set on the stub type if, and only if, the RACW type has a pragma
5745 -- Asynchronous. This is incorrect for RACWs that implement RAS
5746 -- types, because in that case the /designated subprogram/ (not the
5747 -- type) might be asynchronous, and that causes the stub to need to
5748 -- be asynchronous too. A solution is to transport a RAS as a struct
5749 -- containing a RACW and an asynchronous flag, and to properly alter
5750 -- the Asynchronous component in the stub type in the RAS's _From_Any
5753 Append_List_To
(Stub_Statements
,
5754 Build_Get_Unique_RP_Call
(Loc
, Stubbed_Result
, Stub_Type
));
5756 -- Distinguish between the local and remote cases, and execute the
5757 -- appropriate piece of code.
5759 Stub_Condition
:= New_Occurrence_Of
(Is_Local
, Loc
);
5762 Stub_Condition
:= Make_And_Then
(Loc
,
5766 Make_Selected_Component
(Loc
,
5768 Unchecked_Convert_To
(
5769 RTE
(RE_RAS_Proxy_Type_Access
),
5770 New_Occurrence_Of
(Addr
, Loc
)),
5772 Make_Identifier
(Loc
,
5773 Name_All_Calls_Remote
)));
5776 Local_Statements
:= New_List
(
5777 Make_Simple_Return_Statement
(Loc
,
5779 Unchecked_Convert_To
(RACW_Type
,
5780 New_Occurrence_Of
(Addr
, Loc
))));
5782 Append_To
(Statements
,
5783 Make_Implicit_If_Statement
(RACW_Type
,
5786 Then_Statements
=> Local_Statements
,
5787 Else_Statements
=> Stub_Statements
));
5789 Append_To
(Statements
,
5790 Make_Simple_Return_Statement
(Loc
,
5791 Expression
=> Unchecked_Convert_To
(RACW_Type
,
5792 New_Occurrence_Of
(Stubbed_Result
, Loc
))));
5795 Make_Function_Specification
(Loc
,
5796 Defining_Unit_Name
=>
5798 Parameter_Specifications
=> New_List
(
5799 Make_Parameter_Specification
(Loc
,
5800 Defining_Identifier
=>
5803 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
5804 Result_Definition
=> New_Occurrence_Of
(RACW_Type
, Loc
));
5806 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5807 -- entity in the declaration spec, not those of the body spec.
5809 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5812 Make_Subprogram_Body
(Loc
,
5814 Copy_Specification
(Loc
, Func_Spec
),
5815 Declarations
=> Decls
,
5816 Handled_Statement_Sequence
=>
5817 Make_Handled_Sequence_Of_Statements
(Loc
,
5818 Statements
=> Statements
));
5820 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5821 Append_To
(Body_Decls
, Func_Body
);
5823 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_From_Any
);
5824 end Add_RACW_From_Any
;
5826 -----------------------------
5827 -- Add_RACW_Read_Attribute --
5828 -----------------------------
5830 procedure Add_RACW_Read_Attribute
5831 (RACW_Type
: Entity_Id
;
5832 Stub_Type
: Entity_Id
;
5833 Stub_Type_Access
: Entity_Id
;
5834 Body_Decls
: List_Id
)
5836 pragma Warnings
(Off
);
5837 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
5838 pragma Warnings
(On
);
5839 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5841 Proc_Decl
: Node_Id
;
5842 Attr_Decl
: Node_Id
;
5844 Body_Node
: Node_Id
;
5847 Statements
: List_Id
;
5848 -- Various parts of the procedure
5850 Procedure_Name
: constant Name_Id
:=
5851 New_Internal_Name
('R');
5852 Source_Ref
: constant Entity_Id
:=
5853 Make_Defining_Identifier
5854 (Loc
, New_Internal_Name
('R'));
5855 Asynchronous_Flag
: constant Entity_Id
:=
5856 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5857 pragma Assert
(Present
(Asynchronous_Flag
));
5859 function Stream_Parameter
return Node_Id
;
5860 function Result
return Node_Id
;
5861 -- Functions to create occurrences of the formal parameter names
5867 function Result
return Node_Id
is
5869 return Make_Identifier
(Loc
, Name_V
);
5872 ----------------------
5873 -- Stream_Parameter --
5874 ----------------------
5876 function Stream_Parameter
return Node_Id
is
5878 return Make_Identifier
(Loc
, Name_S
);
5879 end Stream_Parameter
;
5881 -- Start of processing for Add_RACW_Read_Attribute
5884 -- Generate object declarations
5887 Make_Object_Declaration
(Loc
,
5888 Defining_Identifier
=> Source_Ref
,
5889 Object_Definition
=>
5890 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)));
5892 Statements
:= New_List
(
5893 Make_Attribute_Reference
(Loc
,
5895 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5896 Attribute_Name
=> Name_Read
,
5897 Expressions
=> New_List
(
5899 New_Occurrence_Of
(Source_Ref
, Loc
))),
5900 Make_Assignment_Statement
(Loc
,
5904 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
5906 Make_Function_Call
(Loc
,
5908 New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
5909 Parameter_Associations
=> New_List
(
5910 New_Occurrence_Of
(Source_Ref
, Loc
))),
5913 Build_Stream_Procedure
5914 (Loc
, RACW_Type
, Body_Node
,
5915 Make_Defining_Identifier
(Loc
, Procedure_Name
),
5916 Statements
, Outp
=> True);
5917 Set_Declarations
(Body_Node
, Decls
);
5919 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
5920 Copy_Specification
(Loc
, Specification
(Body_Node
)));
5923 Make_Attribute_Definition_Clause
(Loc
,
5924 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
5928 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
5930 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
5931 Insert_After
(Proc_Decl
, Attr_Decl
);
5932 Append_To
(Body_Decls
, Body_Node
);
5933 end Add_RACW_Read_Attribute
;
5935 ---------------------
5936 -- Add_RACW_To_Any --
5937 ---------------------
5939 procedure Add_RACW_To_Any
5940 (Designated_Type
: Entity_Id
;
5941 RACW_Type
: Entity_Id
;
5942 Stub_Type
: Entity_Id
;
5943 Stub_Type_Access
: Entity_Id
;
5944 Body_Decls
: List_Id
)
5946 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5948 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5952 Stub_Elements
: constant Stub_Structure
:=
5953 Stubs_Table
.Get
(Designated_Type
);
5954 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5956 Func_Spec
: Node_Id
;
5957 Func_Decl
: Node_Id
;
5958 Func_Body
: Node_Id
;
5961 Statements
: List_Id
;
5962 Null_Statements
: List_Id
;
5963 Local_Statements
: List_Id
:= No_List
;
5964 Stub_Statements
: List_Id
;
5966 -- Various parts of the subprogram
5968 RACW_Parameter
: constant Entity_Id
5969 := Make_Defining_Identifier
(Loc
, Name_R
);
5971 Reference
: constant Entity_Id
:=
5972 Make_Defining_Identifier
5973 (Loc
, New_Internal_Name
('R'));
5974 Any
: constant Entity_Id
:=
5975 Make_Defining_Identifier
5976 (Loc
, New_Internal_Name
('A'));
5980 -- Object declarations
5983 Make_Object_Declaration
(Loc
,
5984 Defining_Identifier
=>
5986 Object_Definition
=>
5987 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
5988 Make_Object_Declaration
(Loc
,
5989 Defining_Identifier
=>
5991 Object_Definition
=>
5992 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
5994 -- If the object is null, nothing to do (Reference is already
5997 Null_Statements
:= New_List
(Make_Null_Statement
(Loc
));
6001 -- If the object is a RAS designating a local subprogram, we
6002 -- already have a target reference.
6004 Local_Statements
:= New_List
(
6005 Make_Procedure_Call_Statement
(Loc
,
6007 New_Occurrence_Of
(RTE
(RE_Set_Ref
), Loc
),
6008 Parameter_Associations
=> New_List
(
6009 New_Occurrence_Of
(Reference
, Loc
),
6010 Make_Selected_Component
(Loc
,
6012 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
6013 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
6014 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)))));
6017 -- If the object is a local RACW object, use Get_Reference now to
6018 -- obtain a reference.
6020 Local_Statements
:= New_List
(
6021 Make_Procedure_Call_Statement
(Loc
,
6023 New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
6024 Parameter_Associations
=> New_List
(
6025 Unchecked_Convert_To
(
6027 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
6028 Make_String_Literal
(Loc
,
6029 Full_Qualified_Name
(Designated_Type
)),
6030 Make_Attribute_Reference
(Loc
,
6033 Defining_Identifier
(
6034 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
6037 New_Occurrence_Of
(Reference
, Loc
))));
6040 -- If the object is located on another partition, use the target from
6043 Stub_Statements
:= New_List
(
6044 Make_Procedure_Call_Statement
(Loc
,
6046 New_Occurrence_Of
(RTE
(RE_Set_Ref
), Loc
),
6047 Parameter_Associations
=> New_List
(
6048 New_Occurrence_Of
(Reference
, Loc
),
6049 Make_Selected_Component
(Loc
,
6050 Prefix
=> Unchecked_Convert_To
(Stub_Type_Access
,
6051 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
6053 Make_Identifier
(Loc
, Name_Target
)))));
6055 -- Distinguish between the null, local and remote cases, and execute
6056 -- the appropriate piece of code.
6059 Make_Implicit_If_Statement
(RACW_Type
,
6062 Left_Opnd
=> New_Occurrence_Of
(RACW_Parameter
, Loc
),
6063 Right_Opnd
=> Make_Null
(Loc
)),
6064 Then_Statements
=> Null_Statements
,
6065 Elsif_Parts
=> New_List
(
6066 Make_Elsif_Part
(Loc
,
6070 Make_Attribute_Reference
(Loc
,
6072 New_Occurrence_Of
(RACW_Parameter
, Loc
),
6073 Attribute_Name
=> Name_Tag
),
6075 Make_Attribute_Reference
(Loc
,
6076 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
6077 Attribute_Name
=> Name_Tag
)),
6078 Then_Statements
=> Local_Statements
)),
6079 Else_Statements
=> Stub_Statements
);
6081 Statements
:= New_List
(
6083 Make_Assignment_Statement
(Loc
,
6085 New_Occurrence_Of
(Any
, Loc
),
6087 Make_Function_Call
(Loc
,
6088 Name
=> New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
6089 Parameter_Associations
=> New_List
(
6090 New_Occurrence_Of
(Reference
, Loc
)))),
6091 Make_Procedure_Call_Statement
(Loc
,
6093 New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
6094 Parameter_Associations
=> New_List
(
6095 New_Occurrence_Of
(Any
, Loc
),
6096 Make_Selected_Component
(Loc
,
6098 Defining_Identifier
(
6099 Stub_Elements
.RPC_Receiver_Decl
),
6100 Selector_Name
=> Name_Obj_TypeCode
))),
6101 Make_Simple_Return_Statement
(Loc
,
6103 New_Occurrence_Of
(Any
, Loc
)));
6105 Fnam
:= Make_Defining_Identifier
(
6106 Loc
, New_Internal_Name
('T'));
6109 Make_Function_Specification
(Loc
,
6110 Defining_Unit_Name
=>
6112 Parameter_Specifications
=> New_List
(
6113 Make_Parameter_Specification
(Loc
,
6114 Defining_Identifier
=>
6117 New_Occurrence_Of
(RACW_Type
, Loc
))),
6118 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
6120 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6121 -- entity in the declaration spec, not in the body spec.
6123 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
6126 Make_Subprogram_Body
(Loc
,
6128 Copy_Specification
(Loc
, Func_Spec
),
6129 Declarations
=> Decls
,
6130 Handled_Statement_Sequence
=>
6131 Make_Handled_Sequence_Of_Statements
(Loc
,
6132 Statements
=> Statements
));
6134 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
6135 Append_To
(Body_Decls
, Func_Body
);
6137 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_To_Any
);
6138 end Add_RACW_To_Any
;
6140 -----------------------
6141 -- Add_RACW_TypeCode --
6142 -----------------------
6144 procedure Add_RACW_TypeCode
6145 (Designated_Type
: Entity_Id
;
6146 RACW_Type
: Entity_Id
;
6147 Body_Decls
: List_Id
)
6149 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
6153 Stub_Elements
: constant Stub_Structure
:=
6154 Stubs_Table
.Get
(Designated_Type
);
6155 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
6157 Func_Spec
: Node_Id
;
6158 Func_Decl
: Node_Id
;
6159 Func_Body
: Node_Id
;
6163 Make_Defining_Identifier
(Loc
,
6164 Chars
=> New_Internal_Name
('T'));
6166 -- The spec for this subprogram has a dummy 'access RACW' argument,
6167 -- which serves only for overloading purposes.
6170 Make_Function_Specification
(Loc
,
6171 Defining_Unit_Name
=>
6173 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6175 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6176 -- entity in the declaration spec, not those of the body spec.
6178 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
6181 Make_Subprogram_Body
(Loc
,
6183 Copy_Specification
(Loc
, Func_Spec
),
6184 Declarations
=> Empty_List
,
6185 Handled_Statement_Sequence
=>
6186 Make_Handled_Sequence_Of_Statements
(Loc
,
6187 Statements
=> New_List
(
6188 Make_Simple_Return_Statement
(Loc
,
6190 Make_Selected_Component
(Loc
,
6192 Defining_Identifier
(
6193 Stub_Elements
.RPC_Receiver_Decl
),
6194 Selector_Name
=> Name_Obj_TypeCode
)))));
6196 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
6197 Append_To
(Body_Decls
, Func_Body
);
6199 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_TypeCode
);
6200 end Add_RACW_TypeCode
;
6202 ------------------------------
6203 -- Add_RACW_Write_Attribute --
6204 ------------------------------
6206 procedure Add_RACW_Write_Attribute
6207 (RACW_Type
: Entity_Id
;
6208 Stub_Type
: Entity_Id
;
6209 Stub_Type_Access
: Entity_Id
;
6210 Body_Decls
: List_Id
)
6212 pragma Warnings
(Off
);
6213 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
6214 pragma Warnings
(On
);
6216 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
6218 Body_Node
: Node_Id
;
6219 Proc_Decl
: Node_Id
;
6220 Attr_Decl
: Node_Id
;
6222 Statements
: List_Id
;
6223 Procedure_Name
: constant Name_Id
:= New_Internal_Name
('R');
6225 function Stream_Parameter
return Node_Id
;
6226 function Object
return Node_Id
;
6227 -- Functions to create occurrences of the formal parameter names
6233 function Object
return Node_Id
is
6234 Object_Ref
: constant Node_Id
:=
6235 Make_Identifier
(Loc
, Name_V
);
6238 -- Etype must be set for Build_To_Any_Call
6240 Set_Etype
(Object_Ref
, RACW_Type
);
6245 ----------------------
6246 -- Stream_Parameter --
6247 ----------------------
6249 function Stream_Parameter
return Node_Id
is
6251 return Make_Identifier
(Loc
, Name_S
);
6252 end Stream_Parameter
;
6254 -- Start of processing for Add_RACW_Write_Attribute
6257 Statements
:= New_List
(
6258 Pack_Node_Into_Stream_Access
(Loc
,
6259 Stream
=> Stream_Parameter
,
6261 Make_Function_Call
(Loc
,
6263 New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
6264 Parameter_Associations
=> New_List
(
6265 PolyORB_Support
.Helpers
.Build_To_Any_Call
6266 (Object
, Body_Decls
))),
6267 Etyp
=> RTE
(RE_Object_Ref
)));
6269 Build_Stream_Procedure
6270 (Loc
, RACW_Type
, Body_Node
,
6271 Make_Defining_Identifier
(Loc
, Procedure_Name
),
6272 Statements
, Outp
=> False);
6275 Make_Subprogram_Declaration
(Loc
,
6276 Copy_Specification
(Loc
, Specification
(Body_Node
)));
6279 Make_Attribute_Definition_Clause
(Loc
,
6280 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
6281 Chars
=> Name_Write
,
6284 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
6286 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
6287 Insert_After
(Proc_Decl
, Attr_Decl
);
6288 Append_To
(Body_Decls
, Body_Node
);
6289 end Add_RACW_Write_Attribute
;
6291 -----------------------
6292 -- Add_RAST_Features --
6293 -----------------------
6295 procedure Add_RAST_Features
6296 (Vis_Decl
: Node_Id
;
6297 RAS_Type
: Entity_Id
)
6300 Add_RAS_Access_TSS
(Vis_Decl
);
6302 Add_RAS_From_Any
(RAS_Type
);
6303 Add_RAS_TypeCode
(RAS_Type
);
6305 -- To_Any uses TypeCode, and therefore needs to be generated last
6307 Add_RAS_To_Any
(RAS_Type
);
6308 end Add_RAST_Features
;
6310 ------------------------
6311 -- Add_RAS_Access_TSS --
6312 ------------------------
6314 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
6315 Loc
: constant Source_Ptr
:= Sloc
(N
);
6317 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
6318 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
6319 -- Ras_Type is the access to subprogram type; Fat_Type is the
6320 -- corresponding record type.
6322 RACW_Type
: constant Entity_Id
:=
6323 Underlying_RACW_Type
(Ras_Type
);
6324 Desig
: constant Entity_Id
:=
6325 Etype
(Designated_Type
(RACW_Type
));
6327 Stub_Elements
: constant Stub_Structure
:=
6328 Stubs_Table
.Get
(Desig
);
6329 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
6331 Proc
: constant Entity_Id
:=
6332 Make_Defining_Identifier
(Loc
,
6333 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
6335 Proc_Spec
: Node_Id
;
6337 -- Formal parameters
6339 Package_Name
: constant Entity_Id
:=
6340 Make_Defining_Identifier
(Loc
,
6345 Subp_Id
: constant Entity_Id
:=
6346 Make_Defining_Identifier
(Loc
,
6349 -- Target subprogram
6351 Asynch_P
: constant Entity_Id
:=
6352 Make_Defining_Identifier
(Loc
,
6353 Chars
=> Name_Asynchronous
);
6354 -- Is the procedure to which the 'Access applies asynchronous?
6356 All_Calls_Remote
: constant Entity_Id
:=
6357 Make_Defining_Identifier
(Loc
,
6358 Chars
=> Name_All_Calls_Remote
);
6359 -- True if an All_Calls_Remote pragma applies to the RCI unit
6360 -- that contains the subprogram.
6362 -- Common local variables
6364 Proc_Decls
: List_Id
;
6365 Proc_Statements
: List_Id
;
6367 Subp_Ref
: constant Entity_Id
:=
6368 Make_Defining_Identifier
(Loc
, Name_R
);
6369 -- Reference that designates the target subprogram (returned
6370 -- by Get_RAS_Info).
6372 Is_Local
: constant Entity_Id
:=
6373 Make_Defining_Identifier
(Loc
, Name_L
);
6374 Local_Addr
: constant Entity_Id
:=
6375 Make_Defining_Identifier
(Loc
, Name_A
);
6376 -- For the call to Get_Local_Address
6378 -- Additional local variables for the remote case
6380 Local_Stub
: constant Entity_Id
:=
6381 Make_Defining_Identifier
(Loc
,
6382 Chars
=> New_Internal_Name
('L'));
6384 Stub_Ptr
: constant Entity_Id
:=
6385 Make_Defining_Identifier
(Loc
,
6386 Chars
=> New_Internal_Name
('S'));
6389 (Field_Name
: Name_Id
;
6390 Value
: Node_Id
) return Node_Id
;
6391 -- Construct an assignment that sets the named component in the
6399 (Field_Name
: Name_Id
;
6400 Value
: Node_Id
) return Node_Id
6404 Make_Assignment_Statement
(Loc
,
6406 Make_Selected_Component
(Loc
,
6408 Selector_Name
=> Field_Name
),
6409 Expression
=> Value
);
6412 -- Start of processing for Add_RAS_Access_TSS
6415 Proc_Decls
:= New_List
(
6417 -- Common declarations
6419 Make_Object_Declaration
(Loc
,
6420 Defining_Identifier
=> Subp_Ref
,
6421 Object_Definition
=>
6422 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
6424 Make_Object_Declaration
(Loc
,
6425 Defining_Identifier
=> Is_Local
,
6426 Object_Definition
=>
6427 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6429 Make_Object_Declaration
(Loc
,
6430 Defining_Identifier
=> Local_Addr
,
6431 Object_Definition
=>
6432 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
6434 Make_Object_Declaration
(Loc
,
6435 Defining_Identifier
=> Local_Stub
,
6436 Aliased_Present
=> True,
6437 Object_Definition
=>
6438 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
6440 Make_Object_Declaration
(Loc
,
6441 Defining_Identifier
=>
6443 Object_Definition
=>
6444 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
6446 Make_Attribute_Reference
(Loc
,
6447 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
6448 Attribute_Name
=> Name_Unchecked_Access
)));
6450 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
6451 -- Build_Get_Unique_RP_Call needs this information
6453 -- Get_RAS_Info (Pkg, Subp, R);
6454 -- Obtain a reference to the target subprogram
6456 Proc_Statements
:= New_List
(
6457 Make_Procedure_Call_Statement
(Loc
,
6459 New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
6460 Parameter_Associations
=> New_List
(
6461 New_Occurrence_Of
(Package_Name
, Loc
),
6462 New_Occurrence_Of
(Subp_Id
, Loc
),
6463 New_Occurrence_Of
(Subp_Ref
, Loc
))),
6465 -- Get_Local_Address (R, L, A);
6466 -- Determine whether the subprogram is local (L), and if so
6467 -- obtain the local address of its proxy (A).
6469 Make_Procedure_Call_Statement
(Loc
,
6471 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6472 Parameter_Associations
=> New_List
(
6473 New_Occurrence_Of
(Subp_Ref
, Loc
),
6474 New_Occurrence_Of
(Is_Local
, Loc
),
6475 New_Occurrence_Of
(Local_Addr
, Loc
))));
6477 -- Note: Here we assume that the Fat_Type is a record containing just
6478 -- an access to a proxy or stub object.
6480 Append_To
(Proc_Statements
,
6484 Make_Implicit_If_Statement
(N
,
6486 New_Occurrence_Of
(Is_Local
, Loc
),
6488 Then_Statements
=> New_List
(
6490 -- if A.Target = null then
6492 Make_Implicit_If_Statement
(N
,
6495 Make_Selected_Component
(Loc
,
6497 Unchecked_Convert_To
(
6498 RTE
(RE_RAS_Proxy_Type_Access
),
6499 New_Occurrence_Of
(Local_Addr
, Loc
)),
6501 Make_Identifier
(Loc
, Name_Target
)),
6504 Then_Statements
=> New_List
(
6506 -- A.Target := Entity_Of (Ref);
6508 Make_Assignment_Statement
(Loc
,
6510 Make_Selected_Component
(Loc
,
6512 Unchecked_Convert_To
(
6513 RTE
(RE_RAS_Proxy_Type_Access
),
6514 New_Occurrence_Of
(Local_Addr
, Loc
)),
6516 Make_Identifier
(Loc
, Name_Target
)),
6518 Make_Function_Call
(Loc
,
6520 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6521 Parameter_Associations
=> New_List
(
6522 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6524 -- Inc_Usage (A.Target);
6526 Make_Procedure_Call_Statement
(Loc
,
6528 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6529 Parameter_Associations
=> New_List
(
6530 Make_Selected_Component
(Loc
,
6532 Unchecked_Convert_To
(
6533 RTE
(RE_RAS_Proxy_Type_Access
),
6534 New_Occurrence_Of
(Local_Addr
, Loc
)),
6535 Selector_Name
=> Make_Identifier
(Loc
,
6539 -- if not All_Calls_Remote then
6540 -- return Fat_Type!(A);
6543 Make_Implicit_If_Statement
(N
,
6546 New_Occurrence_Of
(All_Calls_Remote
, Loc
)),
6548 Then_Statements
=> New_List
(
6549 Make_Simple_Return_Statement
(Loc
,
6550 Unchecked_Convert_To
(Fat_Type
,
6551 New_Occurrence_Of
(Local_Addr
, Loc
))))))));
6553 Append_List_To
(Proc_Statements
, New_List
(
6555 -- Stub.Target := Entity_Of (Ref);
6557 Set_Field
(Name_Target
,
6558 Make_Function_Call
(Loc
,
6560 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6561 Parameter_Associations
=> New_List
(
6562 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6564 -- Inc_Usage (Stub.Target);
6566 Make_Procedure_Call_Statement
(Loc
,
6568 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6569 Parameter_Associations
=> New_List
(
6570 Make_Selected_Component
(Loc
,
6572 Selector_Name
=> Name_Target
))),
6574 -- E.4.1(9) A remote call is asynchronous if it is a call to
6575 -- a procedure, or a call through a value of an access-to-procedure
6576 -- type, to which a pragma Asynchronous applies.
6578 -- Parameter Asynch_P is true when the procedure is asynchronous;
6579 -- Expression Asynch_T is true when the type is asynchronous.
6581 Set_Field
(Name_Asynchronous
,
6583 New_Occurrence_Of
(Asynch_P
, Loc
),
6584 New_Occurrence_Of
(Boolean_Literals
(
6585 Is_Asynchronous
(Ras_Type
)), Loc
)))));
6587 Append_List_To
(Proc_Statements
,
6588 Build_Get_Unique_RP_Call
(Loc
,
6589 Stub_Ptr
, Stub_Elements
.Stub_Type
));
6591 Append_To
(Proc_Statements
,
6592 Make_Simple_Return_Statement
(Loc
,
6594 Unchecked_Convert_To
(Fat_Type
,
6595 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
6598 Make_Function_Specification
(Loc
,
6599 Defining_Unit_Name
=> Proc
,
6600 Parameter_Specifications
=> New_List
(
6601 Make_Parameter_Specification
(Loc
,
6602 Defining_Identifier
=> Package_Name
,
6604 New_Occurrence_Of
(Standard_String
, Loc
)),
6606 Make_Parameter_Specification
(Loc
,
6607 Defining_Identifier
=> Subp_Id
,
6609 New_Occurrence_Of
(Standard_String
, Loc
)),
6611 Make_Parameter_Specification
(Loc
,
6612 Defining_Identifier
=> Asynch_P
,
6614 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6616 Make_Parameter_Specification
(Loc
,
6617 Defining_Identifier
=> All_Calls_Remote
,
6619 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
6621 Result_Definition
=>
6622 New_Occurrence_Of
(Fat_Type
, Loc
));
6624 -- Set the kind and return type of the function to prevent
6625 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6627 Set_Ekind
(Proc
, E_Function
);
6628 Set_Etype
(Proc
, Fat_Type
);
6631 Make_Subprogram_Body
(Loc
,
6632 Specification
=> Proc_Spec
,
6633 Declarations
=> Proc_Decls
,
6634 Handled_Statement_Sequence
=>
6635 Make_Handled_Sequence_Of_Statements
(Loc
,
6636 Statements
=> Proc_Statements
)));
6638 Set_TSS
(Fat_Type
, Proc
);
6639 end Add_RAS_Access_TSS
;
6641 ----------------------
6642 -- Add_RAS_From_Any --
6643 ----------------------
6645 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
) is
6646 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6648 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6649 Make_TSS_Name
(RAS_Type
, TSS_From_Any
));
6651 Func_Spec
: Node_Id
;
6653 Statements
: List_Id
;
6655 Any_Parameter
: constant Entity_Id
:=
6656 Make_Defining_Identifier
(Loc
, Name_A
);
6659 Statements
:= New_List
(
6660 Make_Simple_Return_Statement
(Loc
,
6662 Make_Aggregate
(Loc
,
6663 Component_Associations
=> New_List
(
6664 Make_Component_Association
(Loc
,
6665 Choices
=> New_List
(
6666 Make_Identifier
(Loc
, Name_Ras
)),
6668 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
6669 Underlying_RACW_Type
(RAS_Type
),
6670 New_Occurrence_Of
(Any_Parameter
, Loc
),
6674 Make_Function_Specification
(Loc
,
6675 Defining_Unit_Name
=>
6677 Parameter_Specifications
=> New_List
(
6678 Make_Parameter_Specification
(Loc
,
6679 Defining_Identifier
=>
6682 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
6683 Result_Definition
=> New_Occurrence_Of
(RAS_Type
, Loc
));
6686 Make_Subprogram_Body
(Loc
,
6687 Specification
=> Func_Spec
,
6688 Declarations
=> No_List
,
6689 Handled_Statement_Sequence
=>
6690 Make_Handled_Sequence_Of_Statements
(Loc
,
6691 Statements
=> Statements
)));
6692 Set_TSS
(RAS_Type
, Fnam
);
6693 end Add_RAS_From_Any
;
6695 --------------------
6696 -- Add_RAS_To_Any --
6697 --------------------
6699 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
) is
6700 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6702 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6703 Make_TSS_Name
(RAS_Type
, TSS_To_Any
));
6706 Statements
: List_Id
;
6708 Func_Spec
: Node_Id
;
6710 Any
: constant Entity_Id
:=
6711 Make_Defining_Identifier
(Loc
,
6712 Chars
=> New_Internal_Name
('A'));
6713 RAS_Parameter
: constant Entity_Id
:=
6714 Make_Defining_Identifier
(Loc
,
6715 Chars
=> New_Internal_Name
('R'));
6716 RACW_Parameter
: constant Node_Id
:=
6717 Make_Selected_Component
(Loc
,
6718 Prefix
=> RAS_Parameter
,
6719 Selector_Name
=> Name_Ras
);
6722 -- Object declarations
6724 Set_Etype
(RACW_Parameter
, Underlying_RACW_Type
(RAS_Type
));
6726 Make_Object_Declaration
(Loc
,
6727 Defining_Identifier
=>
6729 Object_Definition
=>
6730 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
6732 PolyORB_Support
.Helpers
.Build_To_Any_Call
6733 (RACW_Parameter
, No_List
)));
6735 Statements
:= New_List
(
6736 Make_Procedure_Call_Statement
(Loc
,
6738 New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
6739 Parameter_Associations
=> New_List
(
6740 New_Occurrence_Of
(Any
, Loc
),
6741 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
6743 Make_Simple_Return_Statement
(Loc
,
6745 New_Occurrence_Of
(Any
, Loc
)));
6748 Make_Function_Specification
(Loc
,
6749 Defining_Unit_Name
=>
6751 Parameter_Specifications
=> New_List
(
6752 Make_Parameter_Specification
(Loc
,
6753 Defining_Identifier
=>
6756 New_Occurrence_Of
(RAS_Type
, Loc
))),
6757 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
6760 Make_Subprogram_Body
(Loc
,
6761 Specification
=> Func_Spec
,
6762 Declarations
=> Decls
,
6763 Handled_Statement_Sequence
=>
6764 Make_Handled_Sequence_Of_Statements
(Loc
,
6765 Statements
=> Statements
)));
6766 Set_TSS
(RAS_Type
, Fnam
);
6769 ----------------------
6770 -- Add_RAS_TypeCode --
6771 ----------------------
6773 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
) is
6774 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6776 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6777 Make_TSS_Name
(RAS_Type
, TSS_TypeCode
));
6779 Func_Spec
: Node_Id
;
6781 Decls
: constant List_Id
:= New_List
;
6782 Name_String
, Repo_Id_String
: String_Id
;
6786 Make_Function_Specification
(Loc
,
6787 Defining_Unit_Name
=>
6789 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6791 PolyORB_Support
.Helpers
.Build_Name_And_Repository_Id
6792 (RAS_Type
, Name_Str
=> Name_String
, Repo_Id_Str
=> Repo_Id_String
);
6795 Make_Subprogram_Body
(Loc
,
6796 Specification
=> Func_Spec
,
6797 Declarations
=> Decls
,
6798 Handled_Statement_Sequence
=>
6799 Make_Handled_Sequence_Of_Statements
(Loc
,
6800 Statements
=> New_List
(
6801 Make_Simple_Return_Statement
(Loc
,
6803 Make_Function_Call
(Loc
,
6805 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
6806 Parameter_Associations
=> New_List
(
6807 New_Occurrence_Of
(RTE
(RE_TC_Object
), Loc
),
6808 Make_Aggregate
(Loc
,
6811 Make_Function_Call
(Loc
,
6812 Name
=> New_Occurrence_Of
(
6813 RTE
(RE_TA_String
), Loc
),
6814 Parameter_Associations
=> New_List
(
6815 Make_String_Literal
(Loc
, Name_String
))),
6816 Make_Function_Call
(Loc
,
6817 Name
=> New_Occurrence_Of
(
6818 RTE
(RE_TA_String
), Loc
),
6819 Parameter_Associations
=> New_List
(
6820 Make_String_Literal
(Loc
,
6821 Repo_Id_String
))))))))))));
6822 Set_TSS
(RAS_Type
, Fnam
);
6823 end Add_RAS_TypeCode
;
6825 -----------------------------------------
6826 -- Add_Receiving_Stubs_To_Declarations --
6827 -----------------------------------------
6829 procedure Add_Receiving_Stubs_To_Declarations
6830 (Pkg_Spec
: Node_Id
;
6834 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
6836 Pkg_RPC_Receiver
: constant Entity_Id
:=
6837 Make_Defining_Identifier
(Loc
,
6838 New_Internal_Name
('H'));
6839 Pkg_RPC_Receiver_Object
: Node_Id
;
6841 Pkg_RPC_Receiver_Body
: Node_Id
;
6842 Pkg_RPC_Receiver_Decls
: List_Id
;
6843 Pkg_RPC_Receiver_Statements
: List_Id
;
6844 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
6845 -- A Pkg_RPC_Receiver is built to decode the request
6848 -- Request object received from neutral layer
6850 Subp_Id
: Entity_Id
;
6851 -- Subprogram identifier as received from the neutral
6852 -- distribution core.
6854 Subp_Index
: Entity_Id
;
6855 -- Internal index as determined by matching either the
6856 -- method name from the request structure, or the local
6857 -- subprogram address (in case of a RAS).
6859 Is_Local
: constant Entity_Id
:=
6860 Make_Defining_Identifier
(Loc
, New_Internal_Name
('L'));
6861 Local_Address
: constant Entity_Id
:=
6862 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
6863 -- Address of a local subprogram designated by a
6864 -- reference corresponding to a RAS.
6866 Dispatch_On_Address
: constant List_Id
:= New_List
;
6867 Dispatch_On_Name
: constant List_Id
:= New_List
;
6869 Current_Declaration
: Node_Id
;
6870 Current_Stubs
: Node_Id
;
6871 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
6873 Subp_Info_Array
: constant Entity_Id
:=
6874 Make_Defining_Identifier
(Loc
,
6875 Chars
=> New_Internal_Name
('I'));
6877 Subp_Info_List
: constant List_Id
:= New_List
;
6879 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
6881 All_Calls_Remote_E
: Entity_Id
;
6883 procedure Append_Stubs_To
6884 (RPC_Receiver_Cases
: List_Id
;
6885 Declaration
: Node_Id
;
6888 Subp_Dist_Name
: Entity_Id
;
6889 Subp_Proxy_Addr
: Entity_Id
);
6890 -- Add one case to the specified RPC receiver case list associating
6891 -- Subprogram_Number with the subprogram declared by Declaration, for
6892 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6893 -- subprogram index. Subp_Dist_Name is the string used to call the
6894 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6895 -- object, used in the context of calls through remote
6896 -- access-to-subprogram types.
6898 ---------------------
6899 -- Append_Stubs_To --
6900 ---------------------
6902 procedure Append_Stubs_To
6903 (RPC_Receiver_Cases
: List_Id
;
6904 Declaration
: Node_Id
;
6907 Subp_Dist_Name
: Entity_Id
;
6908 Subp_Proxy_Addr
: Entity_Id
)
6910 Case_Stmts
: List_Id
;
6912 Case_Stmts
:= New_List
(
6913 Make_Procedure_Call_Statement
(Loc
,
6916 Defining_Entity
(Stubs
), Loc
),
6917 Parameter_Associations
=>
6918 New_List
(New_Occurrence_Of
(Request
, Loc
))));
6919 if Nkind
(Specification
(Declaration
))
6920 = N_Function_Specification
6922 Is_Asynchronous
(Defining_Entity
(Specification
(Declaration
)))
6924 Append_To
(Case_Stmts
, Make_Simple_Return_Statement
(Loc
));
6927 Append_To
(RPC_Receiver_Cases
,
6928 Make_Case_Statement_Alternative
(Loc
,
6930 New_List
(Make_Integer_Literal
(Loc
, Subp_Number
)),
6934 Append_To
(Dispatch_On_Name
,
6935 Make_Elsif_Part
(Loc
,
6937 Make_Function_Call
(Loc
,
6939 New_Occurrence_Of
(RTE
(RE_Caseless_String_Eq
), Loc
),
6940 Parameter_Associations
=> New_List
(
6941 New_Occurrence_Of
(Subp_Id
, Loc
),
6942 New_Occurrence_Of
(Subp_Dist_Name
, Loc
))),
6943 Then_Statements
=> New_List
(
6944 Make_Assignment_Statement
(Loc
,
6945 New_Occurrence_Of
(Subp_Index
, Loc
),
6946 Make_Integer_Literal
(Loc
,
6949 Append_To
(Dispatch_On_Address
,
6950 Make_Elsif_Part
(Loc
,
6954 New_Occurrence_Of
(Local_Address
, Loc
),
6956 New_Occurrence_Of
(Subp_Proxy_Addr
, Loc
)),
6957 Then_Statements
=> New_List
(
6958 Make_Assignment_Statement
(Loc
,
6959 New_Occurrence_Of
(Subp_Index
, Loc
),
6960 Make_Integer_Literal
(Loc
,
6962 end Append_Stubs_To
;
6964 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6967 -- Building receiving stubs consist in several operations:
6969 -- - a package RPC receiver must be built. This subprogram
6970 -- will get a Subprogram_Id from the incoming stream
6971 -- and will dispatch the call to the right subprogram;
6973 -- - a receiving stub for each subprogram visible in the package
6974 -- spec. This stub will read all the parameters from the stream,
6975 -- and put the result as well as the exception occurrence in the
6978 -- - a dummy package with an empty spec and a body made of an
6979 -- elaboration part, whose job is to register the receiving
6980 -- part of this RCI package on the name server. This is done
6981 -- by calling System.Partition_Interface.Register_Receiving_Stub.
6983 Build_RPC_Receiver_Body
(
6984 RPC_Receiver
=> Pkg_RPC_Receiver
,
6987 Subp_Index
=> Subp_Index
,
6988 Stmts
=> Pkg_RPC_Receiver_Statements
,
6989 Decl
=> Pkg_RPC_Receiver_Body
);
6990 Pkg_RPC_Receiver_Decls
:= Declarations
(Pkg_RPC_Receiver_Body
);
6992 -- Extract local address information from the target reference:
6993 -- if non-null, that means that this is a reference that denotes
6994 -- one particular operation, and hence that the operation name
6995 -- must not be taken into account for dispatching.
6997 Append_To
(Pkg_RPC_Receiver_Decls
,
6998 Make_Object_Declaration
(Loc
,
6999 Defining_Identifier
=>
7001 Object_Definition
=>
7002 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7003 Append_To
(Pkg_RPC_Receiver_Decls
,
7004 Make_Object_Declaration
(Loc
,
7005 Defining_Identifier
=>
7007 Object_Definition
=>
7008 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
7009 Append_To
(Pkg_RPC_Receiver_Statements
,
7010 Make_Procedure_Call_Statement
(Loc
,
7012 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
7013 Parameter_Associations
=> New_List
(
7014 Make_Selected_Component
(Loc
,
7016 Selector_Name
=> Name_Target
),
7017 New_Occurrence_Of
(Is_Local
, Loc
),
7018 New_Occurrence_Of
(Local_Address
, Loc
))));
7020 -- For each subprogram, the receiving stub will be built and a
7021 -- case statement will be made on the Subprogram_Id to dispatch
7022 -- to the right subprogram.
7024 All_Calls_Remote_E
:= Boolean_Literals
(
7025 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
7027 Overload_Counter_Table
.Reset
;
7028 Reserve_NamingContext_Methods
;
7030 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
7031 while Present
(Current_Declaration
) loop
7032 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
7033 and then Comes_From_Source
(Current_Declaration
)
7036 Loc
: constant Source_Ptr
:= Sloc
(Current_Declaration
);
7037 -- While specifically processing Current_Declaration, use
7038 -- its Sloc as the location of all generated nodes.
7040 Subp_Def
: constant Entity_Id
:=
7042 (Specification
(Current_Declaration
));
7044 Subp_Val
: String_Id
;
7046 Subp_Dist_Name
: constant Entity_Id
:=
7047 Make_Defining_Identifier
(Loc
,
7049 Related_Id
=> Chars
(Subp_Def
),
7051 Suffix_Index
=> -1));
7053 Proxy_Object_Addr
: Entity_Id
;
7056 -- Build receiving stub
7059 Build_Subprogram_Receiving_Stubs
7060 (Vis_Decl
=> Current_Declaration
,
7062 Nkind
(Specification
(Current_Declaration
)) =
7063 N_Procedure_Specification
7064 and then Is_Asynchronous
(Subp_Def
));
7066 Append_To
(Decls
, Current_Stubs
);
7067 Analyze
(Current_Stubs
);
7071 Add_RAS_Proxy_And_Analyze
(Decls
,
7073 Current_Declaration
,
7074 All_Calls_Remote_E
=>
7076 Proxy_Object_Addr
=>
7079 -- Compute distribution identifier
7081 Assign_Subprogram_Identifier
(
7083 Current_Subprogram_Number
,
7086 pragma Assert
(Current_Subprogram_Number
=
7087 Get_Subprogram_Id
(Subp_Def
));
7090 Make_Object_Declaration
(Loc
,
7091 Defining_Identifier
=> Subp_Dist_Name
,
7092 Constant_Present
=> True,
7093 Object_Definition
=> New_Occurrence_Of
(
7094 Standard_String
, Loc
),
7096 Make_String_Literal
(Loc
, Subp_Val
)));
7097 Analyze
(Last
(Decls
));
7099 -- Add subprogram descriptor (RCI_Subp_Info) to the
7100 -- subprograms table for this receiver. The aggregate
7101 -- below must be kept consistent with the declaration
7102 -- of type RCI_Subp_Info in System.Partition_Interface.
7104 Append_To
(Subp_Info_List
,
7105 Make_Component_Association
(Loc
,
7106 Choices
=> New_List
(
7107 Make_Integer_Literal
(Loc
,
7108 Current_Subprogram_Number
)),
7110 Make_Aggregate
(Loc
,
7111 Expressions
=> New_List
(
7112 Make_Attribute_Reference
(Loc
,
7115 Subp_Dist_Name
, Loc
),
7116 Attribute_Name
=> Name_Address
),
7117 Make_Attribute_Reference
(Loc
,
7120 Subp_Dist_Name
, Loc
),
7121 Attribute_Name
=> Name_Length
),
7122 New_Occurrence_Of
(Proxy_Object_Addr
, Loc
)))));
7124 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
7125 Declaration
=> Current_Declaration
,
7126 Stubs
=> Current_Stubs
,
7127 Subp_Number
=> Current_Subprogram_Number
,
7128 Subp_Dist_Name
=> Subp_Dist_Name
,
7129 Subp_Proxy_Addr
=> Proxy_Object_Addr
);
7132 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
7135 Next
(Current_Declaration
);
7139 Make_Object_Declaration
(Loc
,
7140 Defining_Identifier
=> Subp_Info_Array
,
7141 Constant_Present
=> True,
7142 Aliased_Present
=> True,
7143 Object_Definition
=>
7144 Make_Subtype_Indication
(Loc
,
7146 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
7148 Make_Index_Or_Discriminant_Constraint
(Loc
,
7151 Low_Bound
=> Make_Integer_Literal
(Loc
,
7152 First_RCI_Subprogram_Id
),
7154 Make_Integer_Literal
(Loc
,
7155 First_RCI_Subprogram_Id
7156 + List_Length
(Subp_Info_List
) - 1)))))));
7158 if Present
(First
(Subp_Info_List
)) then
7159 Set_Expression
(Last
(Decls
),
7160 Make_Aggregate
(Loc
,
7161 Component_Associations
=> Subp_Info_List
));
7163 -- Generate the dispatch statement to determine the subprogram id
7164 -- of the called subprogram.
7166 -- We first test whether the reference that was used to make the
7167 -- call was the base RCI reference (in which case Local_Address is
7168 -- zero, and the method identifier from the request must be used
7169 -- to determine which subprogram is called) or a reference
7170 -- identifying one particular subprogram (in which case
7171 -- Local_Address is the address of that subprogram, and the
7172 -- method name from the request is ignored). The latter occurs
7173 -- for the case of a call through a remote access-to-subprogram.
7175 -- In each case, cascaded elsifs are used to determine the proper
7176 -- subprogram index. Using hash tables might be more efficient.
7178 Append_To
(Pkg_RPC_Receiver_Statements
,
7179 Make_Implicit_If_Statement
(Pkg_Spec
,
7182 Left_Opnd
=> New_Occurrence_Of
7183 (Local_Address
, Loc
),
7184 Right_Opnd
=> New_Occurrence_Of
7185 (RTE
(RE_Null_Address
), Loc
)),
7186 Then_Statements
=> New_List
(
7187 Make_Implicit_If_Statement
(Pkg_Spec
,
7189 New_Occurrence_Of
(Standard_False
, Loc
),
7190 Then_Statements
=> New_List
(
7191 Make_Null_Statement
(Loc
)),
7193 Dispatch_On_Address
)),
7195 Else_Statements
=> New_List
(
7196 Make_Implicit_If_Statement
(Pkg_Spec
,
7198 New_Occurrence_Of
(Standard_False
, Loc
),
7199 Then_Statements
=> New_List
(
7200 Make_Null_Statement
(Loc
)),
7202 Dispatch_On_Name
))));
7205 -- For a degenerate RCI with no visible subprograms,
7206 -- Subp_Info_List has zero length, and the declaration is for an
7207 -- empty array, in which case no initialization aggregate must be
7208 -- generated. We do not generate a Dispatch_Statement either.
7210 -- No initialization provided: remove CONSTANT so that the
7211 -- declaration is not an incomplete deferred constant.
7213 Set_Constant_Present
(Last
(Decls
), False);
7216 -- Analyze Subp_Info_Array declaration
7218 Analyze
(Last
(Decls
));
7220 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7221 -- rather than raising an exception since we do not want someone
7222 -- to crash a remote partition by sending invalid subprogram ids.
7223 -- This is consistent with the other parts of the case statement
7224 -- since even in presence of incorrect parameters in the stream,
7225 -- every exception will be caught and (if the subprogram is not an
7226 -- APC) put into the result stream and sent away.
7228 Append_To
(Pkg_RPC_Receiver_Cases
,
7229 Make_Case_Statement_Alternative
(Loc
,
7231 New_List
(Make_Others_Choice
(Loc
)),
7233 New_List
(Make_Null_Statement
(Loc
))));
7235 Append_To
(Pkg_RPC_Receiver_Statements
,
7236 Make_Case_Statement
(Loc
,
7238 New_Occurrence_Of
(Subp_Index
, Loc
),
7239 Alternatives
=> Pkg_RPC_Receiver_Cases
));
7241 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7244 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
7245 Analyze
(Last
(Decls
));
7247 Pkg_RPC_Receiver_Object
:=
7248 Make_Object_Declaration
(Loc
,
7249 Defining_Identifier
=>
7250 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
7251 Aliased_Present
=> True,
7252 Object_Definition
=>
7253 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7254 Append_To
(Decls
, Pkg_RPC_Receiver_Object
);
7255 Analyze
(Last
(Decls
));
7257 Get_Library_Unit_Name_String
(Pkg_Spec
);
7258 Append_To
(Register_Pkg_Actuals
,
7260 Make_String_Literal
(Loc
,
7261 Strval
=> String_From_Name_Buffer
));
7263 Append_To
(Register_Pkg_Actuals
,
7265 Make_Attribute_Reference
(Loc
,
7268 (Defining_Entity
(Pkg_Spec
), Loc
),
7272 Append_To
(Register_Pkg_Actuals
,
7274 Make_Attribute_Reference
(Loc
,
7276 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
7277 Attribute_Name
=> Name_Access
));
7279 Append_To
(Register_Pkg_Actuals
,
7281 Make_Attribute_Reference
(Loc
,
7284 Defining_Identifier
(
7285 Pkg_RPC_Receiver_Object
), Loc
),
7289 Append_To
(Register_Pkg_Actuals
,
7291 Make_Attribute_Reference
(Loc
,
7293 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
7297 Append_To
(Register_Pkg_Actuals
,
7299 Make_Attribute_Reference
(Loc
,
7301 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
7305 Append_To
(Register_Pkg_Actuals
,
7306 -- Is_All_Calls_Remote
7307 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
));
7310 Make_Procedure_Call_Statement
(Loc
,
7312 New_Occurrence_Of
(RTE
(RE_Register_Pkg_Receiving_Stub
), Loc
),
7313 Parameter_Associations
=> Register_Pkg_Actuals
));
7314 Analyze
(Last
(Stmts
));
7316 end Add_Receiving_Stubs_To_Declarations
;
7318 ---------------------------------
7319 -- Build_General_Calling_Stubs --
7320 ---------------------------------
7322 procedure Build_General_Calling_Stubs
7324 Statements
: List_Id
;
7325 Target_Object
: Node_Id
;
7326 Subprogram_Id
: Node_Id
;
7327 Asynchronous
: Node_Id
:= Empty
;
7328 Is_Known_Asynchronous
: Boolean := False;
7329 Is_Known_Non_Asynchronous
: Boolean := False;
7330 Is_Function
: Boolean;
7332 Stub_Type
: Entity_Id
:= Empty
;
7333 RACW_Type
: Entity_Id
:= Empty
;
7336 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
7338 Arguments
: Node_Id
;
7339 -- Name of the named values list used to transmit parameters
7340 -- to the remote package
7343 -- The request object constructed by these stubs
7346 -- Name of the result named value (in non-APC cases) which get the
7347 -- result of the remote subprogram.
7349 Result_TC
: Node_Id
;
7350 -- Typecode expression for the result of the request (void
7351 -- typecode for procedures).
7353 Exception_Return_Parameter
: Node_Id
;
7354 -- Name of the parameter which will hold the exception sent by the
7355 -- remote subprogram.
7357 Current_Parameter
: Node_Id
;
7358 -- Current parameter being handled
7360 Ordered_Parameters_List
: constant List_Id
:=
7361 Build_Ordered_Parameters_List
(Spec
);
7363 Asynchronous_P
: Node_Id
;
7364 -- A Boolean expression indicating whether this call is asynchronous
7366 Asynchronous_Statements
: List_Id
:= No_List
;
7367 Non_Asynchronous_Statements
: List_Id
:= No_List
;
7368 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7370 Extra_Formal_Statements
: constant List_Id
:= New_List
;
7371 -- List of statements for extra formal parameters. It will appear
7372 -- after the regular statements for writing out parameters.
7374 After_Statements
: constant List_Id
:= New_List
;
7375 -- Statements to be executed after call returns (to assign
7376 -- in out or out parameter values).
7379 -- The type of the formal parameter being processed
7381 Is_Controlling_Formal
: Boolean;
7382 Is_First_Controlling_Formal
: Boolean;
7383 First_Controlling_Formal_Seen
: Boolean := False;
7384 -- Controlling formal parameters of distributed object primitives
7385 -- require special handling, and the first such parameter needs even
7386 -- more special handling.
7389 -- ??? document general form of stub subprograms for the PolyORB case
7391 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
7394 Make_Object_Declaration
(Loc
,
7395 Defining_Identifier
=> Request
,
7396 Aliased_Present
=> False,
7397 Object_Definition
=>
7398 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
)));
7401 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
7404 Result_TC
:= PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
7405 Etype
(Result_Definition
(Spec
)), Decls
);
7407 Result_TC
:= New_Occurrence_Of
(RTE
(RE_TC_Void
), Loc
);
7411 Make_Object_Declaration
(Loc
,
7412 Defining_Identifier
=> Result
,
7413 Aliased_Present
=> False,
7414 Object_Definition
=>
7415 New_Occurrence_Of
(RTE
(RE_NamedValue
), Loc
),
7417 Make_Aggregate
(Loc
,
7418 Component_Associations
=> New_List
(
7419 Make_Component_Association
(Loc
,
7420 Choices
=> New_List
(
7421 Make_Identifier
(Loc
, Name_Name
)),
7423 New_Occurrence_Of
(RTE
(RE_Result_Name
), Loc
)),
7424 Make_Component_Association
(Loc
,
7425 Choices
=> New_List
(
7426 Make_Identifier
(Loc
, Name_Argument
)),
7428 Make_Function_Call
(Loc
,
7430 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7431 Parameter_Associations
=> New_List
(
7433 Make_Component_Association
(Loc
,
7434 Choices
=> New_List
(
7435 Make_Identifier
(Loc
, Name_Arg_Modes
)),
7437 Make_Integer_Literal
(Loc
, 0))))));
7439 if not Is_Known_Asynchronous
then
7440 Exception_Return_Parameter
:=
7441 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
7444 Make_Object_Declaration
(Loc
,
7445 Defining_Identifier
=> Exception_Return_Parameter
,
7446 Object_Definition
=>
7447 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
7450 Exception_Return_Parameter
:= Empty
;
7453 -- Initialize and fill in arguments list
7456 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
7457 Declare_Create_NVList
(Loc
, Arguments
, Decls
, Statements
);
7459 Current_Parameter
:= First
(Ordered_Parameters_List
);
7460 while Present
(Current_Parameter
) loop
7461 if Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
) then
7462 Is_Controlling_Formal
:= True;
7463 Is_First_Controlling_Formal
:=
7464 not First_Controlling_Formal_Seen
;
7465 First_Controlling_Formal_Seen
:= True;
7467 Is_Controlling_Formal
:= False;
7468 Is_First_Controlling_Formal
:= False;
7471 if Is_Controlling_Formal
then
7473 -- In the case of a controlling formal argument, we send its
7479 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7482 -- The first controlling formal parameter is treated specially: it
7483 -- is used to set the target object of the call.
7485 if not Is_First_Controlling_Formal
then
7488 Constrained
: constant Boolean :=
7489 Is_Constrained
(Etyp
)
7490 or else Is_Elementary_Type
(Etyp
);
7492 Any
: constant Entity_Id
:=
7493 Make_Defining_Identifier
(Loc
,
7494 New_Internal_Name
('A'));
7496 Actual_Parameter
: Node_Id
:=
7498 Defining_Identifier
(
7499 Current_Parameter
), Loc
);
7504 if Is_Controlling_Formal
then
7506 -- For a controlling formal parameter (other than the
7507 -- first one), use the corresponding RACW. If the
7508 -- parameter is not an anonymous access parameter, that
7509 -- involves taking its 'Unrestricted_Access.
7511 if Nkind
(Parameter_Type
(Current_Parameter
))
7512 = N_Access_Definition
7514 Actual_Parameter
:= OK_Convert_To
7515 (Etyp
, Actual_Parameter
);
7517 Actual_Parameter
:= OK_Convert_To
(Etyp
,
7518 Make_Attribute_Reference
(Loc
,
7522 Name_Unrestricted_Access
));
7527 if In_Present
(Current_Parameter
)
7528 or else not Out_Present
(Current_Parameter
)
7529 or else not Constrained
7530 or else Is_Controlling_Formal
7532 -- The parameter has an input value, is constrained at
7533 -- runtime by an input value, or is a controlling formal
7534 -- parameter (always passed as a reference) other than
7537 Expr
:= PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7538 Actual_Parameter
, Decls
);
7540 Expr
:= Make_Function_Call
(Loc
,
7542 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7543 Parameter_Associations
=> New_List
(
7544 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
7549 Make_Object_Declaration
(Loc
,
7550 Defining_Identifier
=>
7552 Aliased_Present
=> False,
7553 Object_Definition
=>
7554 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7558 Append_To
(Statements
,
7559 Add_Parameter_To_NVList
(Loc
,
7560 Parameter
=> Current_Parameter
,
7561 NVList
=> Arguments
,
7562 Constrained
=> Constrained
,
7565 if Out_Present
(Current_Parameter
)
7566 and then not Is_Controlling_Formal
7568 Append_To
(After_Statements
,
7569 Make_Assignment_Statement
(Loc
,
7572 Defining_Identifier
(Current_Parameter
), Loc
),
7574 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7575 Etype
(Parameter_Type
(Current_Parameter
)),
7576 New_Occurrence_Of
(Any
, Loc
),
7583 -- If the current parameter has a dynamic constrained status, then
7584 -- this status is transmitted as well.
7585 -- This should be done for accessibility as well ???
7587 if Nkind
(Parameter_Type
(Current_Parameter
))
7588 /= N_Access_Definition
7589 and then Need_Extra_Constrained
(Current_Parameter
)
7591 -- In this block, we do not use the extra formal that has been
7592 -- created because it does not exist at the time of expansion
7593 -- when building calling stubs for remote access to subprogram
7594 -- types. We create an extra variable of this type and push it
7595 -- in the stream after the regular parameters.
7598 Extra_Any_Parameter
: constant Entity_Id
:=
7599 Make_Defining_Identifier
7600 (Loc
, New_Internal_Name
('P'));
7602 Parameter_Exp
: constant Node_Id
:=
7603 Make_Attribute_Reference
(Loc
,
7604 Prefix
=> New_Occurrence_Of
(
7605 Defining_Identifier
(Current_Parameter
), Loc
),
7606 Attribute_Name
=> Name_Constrained
);
7608 Set_Etype
(Parameter_Exp
, Etype
(Standard_Boolean
));
7611 Make_Object_Declaration
(Loc
,
7612 Defining_Identifier
=>
7613 Extra_Any_Parameter
,
7614 Aliased_Present
=> False,
7615 Object_Definition
=>
7616 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7618 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7622 Append_To
(Extra_Formal_Statements
,
7623 Add_Parameter_To_NVList
(Loc
,
7624 Parameter
=> Extra_Any_Parameter
,
7625 NVList
=> Arguments
,
7626 Constrained
=> True,
7627 Any
=> Extra_Any_Parameter
));
7631 Next
(Current_Parameter
);
7634 -- Append the formal statements list to the statements
7636 Append_List_To
(Statements
, Extra_Formal_Statements
);
7638 Append_To
(Statements
,
7639 Make_Procedure_Call_Statement
(Loc
,
7641 New_Occurrence_Of
(RTE
(RE_Request_Create
), Loc
),
7642 Parameter_Associations
=> New_List
(
7645 New_Occurrence_Of
(Arguments
, Loc
),
7646 New_Occurrence_Of
(Result
, Loc
),
7647 New_Occurrence_Of
(RTE
(RE_Nil_Exc_List
), Loc
))));
7649 Append_To
(Parameter_Associations
(Last
(Statements
)),
7650 New_Occurrence_Of
(Request
, Loc
));
7653 not (Is_Known_Non_Asynchronous
and Is_Known_Asynchronous
));
7654 if Is_Known_Non_Asynchronous
or Is_Known_Asynchronous
then
7655 Asynchronous_P
:= New_Occurrence_Of
(
7656 Boolean_Literals
(Is_Known_Asynchronous
), Loc
);
7658 pragma Assert
(Present
(Asynchronous
));
7659 Asynchronous_P
:= New_Copy_Tree
(Asynchronous
);
7660 -- The expression node Asynchronous will be used to build an 'if'
7661 -- statement at the end of Build_General_Calling_Stubs: we need to
7662 -- make a copy here.
7665 Append_To
(Parameter_Associations
(Last
(Statements
)),
7666 Make_Indexed_Component
(Loc
,
7669 RTE
(RE_Asynchronous_P_To_Sync_Scope
), Loc
),
7670 Expressions
=> New_List
(Asynchronous_P
)));
7672 Append_To
(Statements
,
7673 Make_Procedure_Call_Statement
(Loc
,
7675 New_Occurrence_Of
(RTE
(RE_Request_Invoke
), Loc
),
7676 Parameter_Associations
=> New_List
(
7677 New_Occurrence_Of
(Request
, Loc
))));
7679 Non_Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7680 Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7682 if not Is_Known_Asynchronous
then
7684 -- Reraise an exception occurrence from the completed request.
7685 -- If the exception occurrence is empty, this is a no-op.
7687 Append_To
(Non_Asynchronous_Statements
,
7688 Make_Procedure_Call_Statement
(Loc
,
7690 New_Occurrence_Of
(RTE
(RE_Request_Raise_Occurrence
), Loc
),
7691 Parameter_Associations
=> New_List
(
7692 New_Occurrence_Of
(Request
, Loc
))));
7696 -- If this is a function call, read the value and return it
7698 Append_To
(Non_Asynchronous_Statements
,
7699 Make_Tag_Check
(Loc
,
7700 Make_Simple_Return_Statement
(Loc
,
7701 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7702 Etype
(Result_Definition
(Spec
)),
7703 Make_Selected_Component
(Loc
,
7705 Selector_Name
=> Name_Argument
),
7710 Append_List_To
(Non_Asynchronous_Statements
,
7713 if Is_Known_Asynchronous
then
7714 Append_List_To
(Statements
, Asynchronous_Statements
);
7716 elsif Is_Known_Non_Asynchronous
then
7717 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
7720 pragma Assert
(Present
(Asynchronous
));
7721 Append_To
(Statements
,
7722 Make_Implicit_If_Statement
(Nod
,
7723 Condition
=> Asynchronous
,
7724 Then_Statements
=> Asynchronous_Statements
,
7725 Else_Statements
=> Non_Asynchronous_Statements
));
7727 end Build_General_Calling_Stubs
;
7729 -----------------------
7730 -- Build_Stub_Target --
7731 -----------------------
7733 function Build_Stub_Target
7736 RCI_Locator
: Entity_Id
;
7737 Controlling_Parameter
: Entity_Id
) return RPC_Target
7739 Target_Info
: RPC_Target
(PCS_Kind
=> Name_PolyORB_DSA
);
7740 Target_Reference
: constant Entity_Id
:=
7741 Make_Defining_Identifier
(Loc
,
7742 New_Internal_Name
('T'));
7744 if Present
(Controlling_Parameter
) then
7746 Make_Object_Declaration
(Loc
,
7747 Defining_Identifier
=> Target_Reference
,
7748 Object_Definition
=>
7749 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
7751 Make_Function_Call
(Loc
,
7753 New_Occurrence_Of
(RTE
(RE_Make_Ref
), Loc
),
7754 Parameter_Associations
=> New_List
(
7755 Make_Selected_Component
(Loc
,
7756 Prefix
=> Controlling_Parameter
,
7757 Selector_Name
=> Name_Target
)))));
7758 -- Controlling_Parameter has the same components as
7759 -- System.Partition_Interface.RACW_Stub_Type.
7761 Target_Info
.Object
:= New_Occurrence_Of
(Target_Reference
, Loc
);
7764 Target_Info
.Object
:=
7765 Make_Selected_Component
(Loc
,
7767 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
7769 Make_Identifier
(Loc
, Name_Get_RCI_Package_Ref
));
7772 end Build_Stub_Target
;
7774 ---------------------
7775 -- Build_Stub_Type --
7776 ---------------------
7778 procedure Build_Stub_Type
7779 (RACW_Type
: Entity_Id
;
7780 Stub_Type
: Entity_Id
;
7781 Stub_Type_Decl
: out Node_Id
;
7782 RPC_Receiver_Decl
: out Node_Id
)
7784 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
7785 pragma Warnings
(Off
);
7786 pragma Unreferenced
(RACW_Type
);
7787 pragma Warnings
(On
);
7791 Make_Full_Type_Declaration
(Loc
,
7792 Defining_Identifier
=> Stub_Type
,
7794 Make_Record_Definition
(Loc
,
7795 Tagged_Present
=> True,
7796 Limited_Present
=> True,
7798 Make_Component_List
(Loc
,
7799 Component_Items
=> New_List
(
7801 Make_Component_Declaration
(Loc
,
7802 Defining_Identifier
=>
7803 Make_Defining_Identifier
(Loc
, Name_Target
),
7804 Component_Definition
=>
7805 Make_Component_Definition
(Loc
,
7808 Subtype_Indication
=>
7809 New_Occurrence_Of
(RTE
(RE_Entity_Ptr
), Loc
))),
7811 Make_Component_Declaration
(Loc
,
7812 Defining_Identifier
=>
7813 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
7814 Component_Definition
=>
7815 Make_Component_Definition
(Loc
,
7816 Aliased_Present
=> False,
7817 Subtype_Indication
=>
7819 Standard_Boolean
, Loc
)))))));
7821 RPC_Receiver_Decl
:=
7822 Make_Object_Declaration
(Loc
,
7823 Defining_Identifier
=> Make_Defining_Identifier
(Loc
,
7824 New_Internal_Name
('R')),
7825 Aliased_Present
=> True,
7826 Object_Definition
=>
7827 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7828 end Build_Stub_Type
;
7830 -----------------------------
7831 -- Build_RPC_Receiver_Body --
7832 -----------------------------
7834 procedure Build_RPC_Receiver_Body
7835 (RPC_Receiver
: Entity_Id
;
7836 Request
: out Entity_Id
;
7837 Subp_Id
: out Entity_Id
;
7838 Subp_Index
: out Entity_Id
;
7839 Stmts
: out List_Id
;
7842 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
7844 RPC_Receiver_Spec
: Node_Id
;
7845 RPC_Receiver_Decls
: List_Id
;
7848 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
7850 RPC_Receiver_Spec
:=
7851 Build_RPC_Receiver_Specification
(
7852 RPC_Receiver
=> RPC_Receiver
,
7853 Request_Parameter
=> Request
);
7855 Subp_Id
:= Make_Defining_Identifier
(Loc
, Name_P
);
7856 Subp_Index
:= Make_Defining_Identifier
(Loc
, Name_I
);
7858 RPC_Receiver_Decls
:= New_List
(
7859 Make_Object_Renaming_Declaration
(Loc
,
7860 Defining_Identifier
=> Subp_Id
,
7861 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
7863 Make_Explicit_Dereference
(Loc
,
7865 Make_Selected_Component
(Loc
,
7867 Selector_Name
=> Name_Operation
))),
7869 Make_Object_Declaration
(Loc
,
7870 Defining_Identifier
=> Subp_Index
,
7871 Object_Definition
=>
7872 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7874 Make_Attribute_Reference
(Loc
,
7876 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7877 Attribute_Name
=> Name_Last
)));
7882 Make_Subprogram_Body
(Loc
,
7883 Specification
=> RPC_Receiver_Spec
,
7884 Declarations
=> RPC_Receiver_Decls
,
7885 Handled_Statement_Sequence
=>
7886 Make_Handled_Sequence_Of_Statements
(Loc
,
7887 Statements
=> Stmts
));
7888 end Build_RPC_Receiver_Body
;
7890 --------------------------------------
7891 -- Build_Subprogram_Receiving_Stubs --
7892 --------------------------------------
7894 function Build_Subprogram_Receiving_Stubs
7895 (Vis_Decl
: Node_Id
;
7896 Asynchronous
: Boolean;
7897 Dynamically_Asynchronous
: Boolean := False;
7898 Stub_Type
: Entity_Id
:= Empty
;
7899 RACW_Type
: Entity_Id
:= Empty
;
7900 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
7902 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
7904 Request_Parameter
: constant Entity_Id
:=
7905 Make_Defining_Identifier
(Loc
,
7906 New_Internal_Name
('R'));
7907 -- Formal parameter for receiving stubs: a descriptor for an incoming
7910 Outer_Decls
: constant List_Id
:= New_List
;
7911 -- At the outermost level, an NVList and Any's are declared for all
7912 -- parameters. The Dynamic_Async flag also needs to be declared there
7913 -- to be visible from the exception handling code.
7915 Outer_Statements
: constant List_Id
:= New_List
;
7916 -- Statements that occur prior to the declaration of the actual
7917 -- parameter variables.
7919 Outer_Extra_Formal_Statements
: constant List_Id
:= New_List
;
7920 -- Statements concerning extra formal parameters, prior to the
7921 -- declaration of the actual parameter variables.
7923 Decls
: constant List_Id
:= New_List
;
7924 -- All the parameters will get declared before calling the real
7925 -- subprograms. Also the out parameters will be declared.
7926 -- At this level, parameters may be unconstrained.
7928 Statements
: constant List_Id
:= New_List
;
7930 After_Statements
: constant List_Id
:= New_List
;
7931 -- Statements to be executed after the subprogram call
7933 Inner_Decls
: List_Id
:= No_List
;
7934 -- In case of a function, the inner declarations are needed since
7935 -- the result may be unconstrained.
7937 Excep_Handlers
: List_Id
:= No_List
;
7939 Parameter_List
: constant List_Id
:= New_List
;
7940 -- List of parameters to be passed to the subprogram
7942 First_Controlling_Formal_Seen
: Boolean := False;
7944 Current_Parameter
: Node_Id
;
7946 Ordered_Parameters_List
: constant List_Id
:=
7947 Build_Ordered_Parameters_List
7948 (Specification
(Vis_Decl
));
7950 Arguments
: constant Entity_Id
:=
7951 Make_Defining_Identifier
(Loc
,
7952 New_Internal_Name
('A'));
7953 -- Name of the named values list used to retrieve parameters
7955 Subp_Spec
: Node_Id
;
7956 -- Subprogram specification
7958 Called_Subprogram
: Node_Id
;
7959 -- The subprogram to call
7962 if Present
(RACW_Type
) then
7963 Called_Subprogram
:=
7964 New_Occurrence_Of
(Parent_Primitive
, Loc
);
7966 Called_Subprogram
:=
7968 Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
7971 Declare_Create_NVList
(Loc
, Arguments
, Outer_Decls
, Outer_Statements
);
7973 -- Loop through every parameter and get its value from the stream. If
7974 -- the parameter is unconstrained, then the parameter is read using
7975 -- 'Input at the point of declaration.
7977 Current_Parameter
:= First
(Ordered_Parameters_List
);
7978 while Present
(Current_Parameter
) loop
7981 Constrained
: Boolean;
7982 Any
: Entity_Id
:= Empty
;
7983 Object
: constant Entity_Id
:=
7984 Make_Defining_Identifier
(Loc
,
7985 New_Internal_Name
('P'));
7986 Expr
: Node_Id
:= Empty
;
7988 Is_Controlling_Formal
: constant Boolean
7989 := Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
);
7991 Is_First_Controlling_Formal
: Boolean := False;
7993 Need_Extra_Constrained
: Boolean;
7994 -- True when an extra constrained actual is required
7997 if Is_Controlling_Formal
then
7999 -- Controlling formals in distributed object primitive
8000 -- operations are handled specially:
8001 -- - the first controlling formal is used as the
8002 -- target of the call;
8003 -- - the remaining controlling formals are transmitted
8007 Is_First_Controlling_Formal
:=
8008 not First_Controlling_Formal_Seen
;
8009 First_Controlling_Formal_Seen
:= True;
8011 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
8015 Is_Constrained
(Etyp
)
8016 or else Is_Elementary_Type
(Etyp
);
8018 if not Is_First_Controlling_Formal
then
8019 Any
:= Make_Defining_Identifier
(Loc
,
8020 New_Internal_Name
('A'));
8021 Append_To
(Outer_Decls
,
8022 Make_Object_Declaration
(Loc
,
8023 Defining_Identifier
=>
8025 Object_Definition
=>
8026 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8028 Make_Function_Call
(Loc
,
8030 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
8031 Parameter_Associations
=> New_List
(
8032 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
8033 Etyp
, Outer_Decls
)))));
8035 Append_To
(Outer_Statements
,
8036 Add_Parameter_To_NVList
(Loc
,
8037 Parameter
=> Current_Parameter
,
8038 NVList
=> Arguments
,
8039 Constrained
=> Constrained
,
8043 if Is_First_Controlling_Formal
then
8045 Addr
: constant Entity_Id
:=
8046 Make_Defining_Identifier
(Loc
,
8047 New_Internal_Name
('A'));
8048 Is_Local
: constant Entity_Id
:=
8049 Make_Defining_Identifier
(Loc
,
8050 New_Internal_Name
('L'));
8053 -- Special case: obtain the first controlling formal
8054 -- from the target of the remote call, instead of the
8057 Append_To
(Outer_Decls
,
8058 Make_Object_Declaration
(Loc
,
8059 Defining_Identifier
=>
8061 Object_Definition
=>
8062 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
8063 Append_To
(Outer_Decls
,
8064 Make_Object_Declaration
(Loc
,
8065 Defining_Identifier
=>
8067 Object_Definition
=>
8068 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
8069 Append_To
(Outer_Statements
,
8070 Make_Procedure_Call_Statement
(Loc
,
8073 RTE
(RE_Get_Local_Address
), Loc
),
8074 Parameter_Associations
=> New_List
(
8075 Make_Selected_Component
(Loc
,
8078 Request_Parameter
, Loc
),
8080 Make_Identifier
(Loc
, Name_Target
)),
8081 New_Occurrence_Of
(Is_Local
, Loc
),
8082 New_Occurrence_Of
(Addr
, Loc
))));
8084 Expr
:= Unchecked_Convert_To
(RACW_Type
,
8085 New_Occurrence_Of
(Addr
, Loc
));
8088 elsif In_Present
(Current_Parameter
)
8089 or else not Out_Present
(Current_Parameter
)
8090 or else not Constrained
8092 -- If an input parameter is constrained, then its reading is
8093 -- deferred until the beginning of the subprogram body. If
8094 -- it is unconstrained, then an expression is built for
8095 -- the object declaration and the variable is set using
8096 -- 'Input instead of 'Read.
8098 Expr
:= PolyORB_Support
.Helpers
.Build_From_Any_Call
(
8099 Etyp
, New_Occurrence_Of
(Any
, Loc
), Decls
);
8102 Append_To
(Statements
,
8103 Make_Assignment_Statement
(Loc
,
8105 New_Occurrence_Of
(Object
, Loc
),
8111 -- Expr will be used to initialize (and constrain) the
8112 -- parameter when it is declared.
8117 Need_Extra_Constrained
:=
8118 Nkind
(Parameter_Type
(Current_Parameter
)) /=
8121 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
8123 Present
(Extra_Constrained
8124 (Defining_Identifier
(Current_Parameter
)));
8126 -- We may not associate an extra constrained actual to a
8127 -- constant object, so if one is needed, declare the actual
8128 -- as a variable even if it won't be modified.
8130 Build_Actual_Object_Declaration
8133 Variable
=> Need_Extra_Constrained
8134 or else Out_Present
(Current_Parameter
),
8137 Set_Etype
(Object
, Etyp
);
8139 -- An out parameter may be written back using a 'Write
8140 -- attribute instead of a 'Output because it has been
8141 -- constrained by the parameter given to the caller. Note that
8142 -- out controlling arguments in the case of a RACW are not put
8143 -- back in the stream because the pointer on them has not
8146 if Out_Present
(Current_Parameter
)
8147 and then not Is_Controlling_Formal
8149 Append_To
(After_Statements
,
8150 Make_Procedure_Call_Statement
(Loc
,
8152 New_Occurrence_Of
(RTE
(RE_Move_Any_Value
), Loc
),
8153 Parameter_Associations
=> New_List
(
8154 New_Occurrence_Of
(Any
, Loc
),
8155 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
8156 New_Occurrence_Of
(Object
, Loc
),
8160 -- For RACW controlling formals, the Etyp of Object is always
8161 -- an RACW, even if the parameter is not of an anonymous access
8162 -- type. In such case, we need to dereference it at call time.
8164 if Is_Controlling_Formal
then
8165 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
8168 Append_To
(Parameter_List
,
8169 Make_Parameter_Association
(Loc
,
8172 Defining_Identifier
(Current_Parameter
), Loc
),
8173 Explicit_Actual_Parameter
=>
8174 Make_Explicit_Dereference
(Loc
,
8175 Unchecked_Convert_To
(RACW_Type
,
8176 OK_Convert_To
(RTE
(RE_Address
),
8177 New_Occurrence_Of
(Object
, Loc
))))));
8180 Append_To
(Parameter_List
,
8181 Make_Parameter_Association
(Loc
,
8184 Defining_Identifier
(Current_Parameter
), Loc
),
8185 Explicit_Actual_Parameter
=>
8186 Unchecked_Convert_To
(RACW_Type
,
8187 OK_Convert_To
(RTE
(RE_Address
),
8188 New_Occurrence_Of
(Object
, Loc
)))));
8192 Append_To
(Parameter_List
,
8193 Make_Parameter_Association
(Loc
,
8196 Defining_Identifier
(Current_Parameter
), Loc
),
8197 Explicit_Actual_Parameter
=>
8198 New_Occurrence_Of
(Object
, Loc
)));
8201 -- If the current parameter needs an extra formal, then read it
8202 -- from the stream and set the corresponding semantic field in
8203 -- the variable. If the kind of the parameter identifier is
8204 -- E_Void, then this is a compiler generated parameter that
8205 -- doesn't need an extra constrained status.
8207 -- The case of Extra_Accessibility should also be handled ???
8209 if Need_Extra_Constrained
then
8211 Extra_Parameter
: constant Entity_Id
:=
8213 (Defining_Identifier
8214 (Current_Parameter
));
8215 Extra_Any
: constant Entity_Id
:=
8216 Make_Defining_Identifier
8217 (Loc
, New_Internal_Name
('A'));
8219 Formal_Entity
: constant Entity_Id
:=
8220 Make_Defining_Identifier
8221 (Loc
, Chars
(Extra_Parameter
));
8223 Formal_Type
: constant Entity_Id
:=
8224 Etype
(Extra_Parameter
);
8226 Append_To
(Outer_Decls
,
8227 Make_Object_Declaration
(Loc
,
8228 Defining_Identifier
=>
8230 Object_Definition
=>
8231 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8233 Make_Function_Call
(Loc
,
8235 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
8236 Parameter_Associations
=> New_List
(
8237 PolyORB_Support
.Helpers
.Build_TypeCode_Call
8238 (Loc
, Formal_Type
, Outer_Decls
)))));
8240 Append_To
(Outer_Extra_Formal_Statements
,
8241 Add_Parameter_To_NVList
(Loc
,
8242 Parameter
=> Extra_Parameter
,
8243 NVList
=> Arguments
,
8244 Constrained
=> True,
8248 Make_Object_Declaration
(Loc
,
8249 Defining_Identifier
=> Formal_Entity
,
8250 Object_Definition
=>
8251 New_Occurrence_Of
(Formal_Type
, Loc
)));
8253 Append_To
(Statements
,
8254 Make_Assignment_Statement
(Loc
,
8256 New_Occurrence_Of
(Formal_Entity
, Loc
),
8258 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
8260 New_Occurrence_Of
(Extra_Any
, Loc
),
8262 Set_Extra_Constrained
(Object
, Formal_Entity
);
8267 Next
(Current_Parameter
);
8270 -- Extra Formals should go after all the other parameters
8272 Append_List_To
(Outer_Statements
, Outer_Extra_Formal_Statements
);
8274 Append_To
(Outer_Statements
,
8275 Make_Procedure_Call_Statement
(Loc
,
8277 New_Occurrence_Of
(RTE
(RE_Request_Arguments
), Loc
),
8278 Parameter_Associations
=> New_List
(
8279 New_Occurrence_Of
(Request_Parameter
, Loc
),
8280 New_Occurrence_Of
(Arguments
, Loc
))));
8282 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
8284 -- The remote subprogram is a function. We build an inner block to
8285 -- be able to hold a potentially unconstrained result in a
8289 Etyp
: constant Entity_Id
:=
8290 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
8291 Result
: constant Node_Id
:=
8292 Make_Defining_Identifier
(Loc
,
8293 New_Internal_Name
('R'));
8295 Inner_Decls
:= New_List
(
8296 Make_Object_Declaration
(Loc
,
8297 Defining_Identifier
=> Result
,
8298 Constant_Present
=> True,
8299 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
8301 Make_Function_Call
(Loc
,
8302 Name
=> Called_Subprogram
,
8303 Parameter_Associations
=> Parameter_List
)));
8305 if Is_Class_Wide_Type
(Etyp
) then
8307 -- For a remote call to a function with a class-wide type,
8308 -- check that the returned value satisfies the requirements
8311 Append_To
(Inner_Decls
,
8312 Make_Transportable_Check
(Loc
,
8313 New_Occurrence_Of
(Result
, Loc
)));
8317 Set_Etype
(Result
, Etyp
);
8318 Append_To
(After_Statements
,
8319 Make_Procedure_Call_Statement
(Loc
,
8321 New_Occurrence_Of
(RTE
(RE_Set_Result
), Loc
),
8322 Parameter_Associations
=> New_List
(
8323 New_Occurrence_Of
(Request_Parameter
, Loc
),
8324 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
8325 New_Occurrence_Of
(Result
, Loc
),
8327 -- A DSA function does not have out or inout arguments
8330 Append_To
(Statements
,
8331 Make_Block_Statement
(Loc
,
8332 Declarations
=> Inner_Decls
,
8333 Handled_Statement_Sequence
=>
8334 Make_Handled_Sequence_Of_Statements
(Loc
,
8335 Statements
=> After_Statements
)));
8338 -- The remote subprogram is a procedure. We do not need any inner
8339 -- block in this case. No specific processing is required here for
8340 -- the dynamically asynchronous case: the indication of whether
8341 -- call is asynchronous or not is managed by the Sync_Scope
8342 -- attibute of the request, and is handled entirely in the
8345 Append_To
(After_Statements
,
8346 Make_Procedure_Call_Statement
(Loc
,
8348 New_Occurrence_Of
(RTE
(RE_Request_Set_Out
), Loc
),
8349 Parameter_Associations
=> New_List
(
8350 New_Occurrence_Of
(Request_Parameter
, Loc
))));
8352 Append_To
(Statements
,
8353 Make_Procedure_Call_Statement
(Loc
,
8354 Name
=> Called_Subprogram
,
8355 Parameter_Associations
=> Parameter_List
));
8357 Append_List_To
(Statements
, After_Statements
);
8361 Make_Procedure_Specification
(Loc
,
8362 Defining_Unit_Name
=>
8363 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
8365 Parameter_Specifications
=> New_List
(
8366 Make_Parameter_Specification
(Loc
,
8367 Defining_Identifier
=> Request_Parameter
,
8369 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
8371 -- An exception raised during the execution of an incoming
8372 -- remote subprogram call and that needs to be sent back
8373 -- to the caller is propagated by the receiving stubs, and
8374 -- will be handled by the caller (the distribution runtime).
8376 if Asynchronous
and then not Dynamically_Asynchronous
then
8378 -- For an asynchronous procedure, add a null exception handler
8380 Excep_Handlers
:= New_List
(
8381 Make_Implicit_Exception_Handler
(Loc
,
8382 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8383 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
8387 -- In the other cases, if an exception is raised, then the
8388 -- exception occurrence is propagated.
8393 Append_To
(Outer_Statements
,
8394 Make_Block_Statement
(Loc
,
8397 Handled_Statement_Sequence
=>
8398 Make_Handled_Sequence_Of_Statements
(Loc
,
8399 Statements
=> Statements
)));
8402 Make_Subprogram_Body
(Loc
,
8403 Specification
=> Subp_Spec
,
8404 Declarations
=> Outer_Decls
,
8405 Handled_Statement_Sequence
=>
8406 Make_Handled_Sequence_Of_Statements
(Loc
,
8407 Statements
=> Outer_Statements
,
8408 Exception_Handlers
=> Excep_Handlers
));
8409 end Build_Subprogram_Receiving_Stubs
;
8415 package body Helpers
is
8417 -----------------------
8418 -- Local Subprograms --
8419 -----------------------
8421 function Find_Numeric_Representation
8422 (Typ
: Entity_Id
) return Entity_Id
;
8423 -- Given a numeric type Typ, return the smallest integer or floarting
8424 -- point type from Standard, or the smallest unsigned (modular) type
8425 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8427 function Make_Stream_Procedure_Function_Name
8430 Nam
: Name_Id
) return Entity_Id
;
8431 -- Return the name to be assigned for stream subprogram Nam of Typ.
8432 -- (copied from exp_strm.adb, should be shared???)
8434 ------------------------------------------------------------
8435 -- Common subprograms for building various tree fragments --
8436 ------------------------------------------------------------
8438 function Build_Get_Aggregate_Element
8442 Idx
: Node_Id
) return Node_Id
;
8443 -- Build a call to Get_Aggregate_Element on Any
8444 -- for typecode TC, returning the Idx'th element.
8447 Subprogram
: Entity_Id
;
8448 -- Reference location for constructed nodes
8451 -- For 'Range and Etype
8454 -- For the construction of the innermost element expression
8456 with procedure Add_Process_Element
8459 Counter
: Entity_Id
;
8462 procedure Append_Array_Traversal
8465 Counter
: Entity_Id
:= Empty
;
8467 -- Build nested loop statements that iterate over the elements of an
8468 -- array Arry. The statement(s) built by Add_Process_Element are
8469 -- executed for each element; Indices is the list of indices to be
8470 -- used in the construction of the indexed component that denotes the
8471 -- current element. Subprogram is the entity for the subprogram for
8472 -- which this iterator is generated. The generated statements are
8473 -- appended to Stmts.
8477 -- The record entity being dealt with
8479 with procedure Add_Process_Element
8481 Container
: Node_Or_Entity_Id
;
8482 Counter
: in out Int
;
8485 -- Rec is the instance of the record type, or Empty.
8486 -- Field is either the N_Defining_Identifier for a component,
8487 -- or an N_Variant_Part.
8489 procedure Append_Record_Traversal
8492 Container
: Node_Or_Entity_Id
;
8493 Counter
: in out Int
);
8494 -- Process component list Clist. Individual fields are passed
8495 -- to Field_Processing. Each variant part is also processed.
8496 -- Container is the outer Any (for From_Any/To_Any),
8497 -- the outer typecode (for TC) to which the operation applies.
8499 -----------------------------
8500 -- Append_Record_Traversal --
8501 -----------------------------
8503 procedure Append_Record_Traversal
8506 Container
: Node_Or_Entity_Id
;
8507 Counter
: in out Int
)
8511 -- Clist's Component_Items and Variant_Part
8521 CI
:= Component_Items
(Clist
);
8522 VP
:= Variant_Part
(Clist
);
8525 while Present
(Item
) loop
8526 Def
:= Defining_Identifier
(Item
);
8528 if not Is_Internal_Name
(Chars
(Def
)) then
8530 (Stmts
, Container
, Counter
, Rec
, Def
);
8536 if Present
(VP
) then
8537 Add_Process_Element
(Stmts
, Container
, Counter
, Rec
, VP
);
8539 end Append_Record_Traversal
;
8541 -------------------------
8542 -- Build_From_Any_Call --
8543 -------------------------
8545 function Build_From_Any_Call
8548 Decls
: List_Id
) return Node_Id
8550 Loc
: constant Source_Ptr
:= Sloc
(N
);
8552 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
8554 Fnam
: Entity_Id
:= Empty
;
8555 Lib_RE
: RE_Id
:= RE_Null
;
8559 -- First simple case where the From_Any function is present
8560 -- in the type's TSS.
8562 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_From_Any
);
8564 if Sloc
(U_Type
) <= Standard_Location
then
8565 U_Type
:= Base_Type
(U_Type
);
8568 -- Check first for Boolean and Character. These are enumeration
8569 -- types, but we treat them specially, since they may require
8570 -- special handling in the transfer protocol. However, this
8571 -- special handling only applies if they have standard
8572 -- representation, otherwise they are treated like any other
8573 -- enumeration type.
8575 if Present
(Fnam
) then
8578 elsif U_Type
= Standard_Boolean
then
8581 elsif U_Type
= Standard_Character
then
8584 elsif U_Type
= Standard_Wide_Character
then
8587 elsif U_Type
= Standard_Wide_Wide_Character
then
8588 Lib_RE
:= RE_FA_WWC
;
8590 -- Floating point types
8592 elsif U_Type
= Standard_Short_Float
then
8595 elsif U_Type
= Standard_Float
then
8598 elsif U_Type
= Standard_Long_Float
then
8601 elsif U_Type
= Standard_Long_Long_Float
then
8602 Lib_RE
:= RE_FA_LLF
;
8606 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
8607 Lib_RE
:= RE_FA_SSI
;
8609 elsif U_Type
= Etype
(Standard_Short_Integer
) then
8612 elsif U_Type
= Etype
(Standard_Integer
) then
8615 elsif U_Type
= Etype
(Standard_Long_Integer
) then
8618 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
8619 Lib_RE
:= RE_FA_LLI
;
8621 -- Unsigned integer types
8623 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
8624 Lib_RE
:= RE_FA_SSU
;
8626 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
8629 elsif U_Type
= RTE
(RE_Unsigned
) then
8632 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
8635 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
8636 Lib_RE
:= RE_FA_LLU
;
8638 elsif U_Type
= Standard_String
then
8639 Lib_RE
:= RE_FA_String
;
8641 -- Other (non-primitive) types
8647 Build_From_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
8648 Append_To
(Decls
, Decl
);
8652 -- Call the function
8654 if Lib_RE
/= RE_Null
then
8655 pragma Assert
(No
(Fnam
));
8656 Fnam
:= RTE
(Lib_RE
);
8660 Make_Function_Call
(Loc
,
8661 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
8662 Parameter_Associations
=> New_List
(N
));
8664 -- We must set the type of Result, so the unchecked conversion
8665 -- from the underlying type to the base type is properly done.
8667 Set_Etype
(Result
, U_Type
);
8669 return Unchecked_Convert_To
(Typ
, Result
);
8670 end Build_From_Any_Call
;
8672 -----------------------------
8673 -- Build_From_Any_Function --
8674 -----------------------------
8676 procedure Build_From_Any_Function
8680 Fnam
: out Entity_Id
)
8683 Decls
: constant List_Id
:= New_List
;
8684 Stms
: constant List_Id
:= New_List
;
8685 Any_Parameter
: constant Entity_Id
8686 := Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
8688 if Is_Itype
(Typ
) then
8689 Build_From_Any_Function
8697 Fnam
:= Make_Stream_Procedure_Function_Name
(Loc
,
8698 Typ
, Name_uFrom_Any
);
8701 Make_Function_Specification
(Loc
,
8702 Defining_Unit_Name
=> Fnam
,
8703 Parameter_Specifications
=> New_List
(
8704 Make_Parameter_Specification
(Loc
,
8705 Defining_Identifier
=>
8708 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
8709 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
8711 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8714 (not (Is_Remote_Access_To_Class_Wide_Type
(Typ
)));
8716 if Is_Derived_Type
(Typ
)
8717 and then not Is_Tagged_Type
(Typ
)
8720 Make_Simple_Return_Statement
(Loc
,
8724 Build_From_Any_Call
(
8726 New_Occurrence_Of
(Any_Parameter
, Loc
),
8729 elsif Is_Record_Type
(Typ
)
8730 and then not Is_Derived_Type
(Typ
)
8731 and then not Is_Tagged_Type
(Typ
)
8733 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
8735 Make_Simple_Return_Statement
(Loc
,
8739 Build_From_Any_Call
(
8741 New_Occurrence_Of
(Any_Parameter
, Loc
),
8745 Disc
: Entity_Id
:= Empty
;
8746 Discriminant_Associations
: List_Id
;
8747 Rdef
: constant Node_Id
:=
8748 Type_Definition
(Declaration_Node
(Typ
));
8749 Component_Counter
: Int
:= 0;
8751 -- The returned object
8753 Res
: constant Entity_Id
:=
8754 Make_Defining_Identifier
(Loc
,
8755 New_Internal_Name
('R'));
8757 Res_Definition
: Node_Id
:= New_Occurrence_Of
(Typ
, Loc
);
8759 procedure FA_Rec_Add_Process_Element
8762 Counter
: in out Int
;
8766 procedure FA_Append_Record_Traversal
is
8767 new Append_Record_Traversal
8769 Add_Process_Element
=> FA_Rec_Add_Process_Element
);
8771 --------------------------------
8772 -- FA_Rec_Add_Process_Element --
8773 --------------------------------
8775 procedure FA_Rec_Add_Process_Element
8778 Counter
: in out Int
;
8783 if Nkind
(Field
) = N_Defining_Identifier
then
8785 -- A regular component
8788 Make_Assignment_Statement
(Loc
,
8789 Name
=> Make_Selected_Component
(Loc
,
8791 New_Occurrence_Of
(Rec
, Loc
),
8793 New_Occurrence_Of
(Field
, Loc
)),
8795 Build_From_Any_Call
(Etype
(Field
),
8796 Build_Get_Aggregate_Element
(Loc
,
8798 Tc
=> Build_TypeCode_Call
(Loc
,
8799 Etype
(Field
), Decls
),
8800 Idx
=> Make_Integer_Literal
(Loc
,
8809 Struct_Counter
: Int
:= 0;
8811 Block_Decls
: constant List_Id
:= New_List
;
8812 Block_Stmts
: constant List_Id
:= New_List
;
8815 Alt_List
: constant List_Id
:= New_List
;
8816 Choice_List
: List_Id
;
8818 Struct_Any
: constant Entity_Id
:=
8819 Make_Defining_Identifier
(Loc
,
8820 New_Internal_Name
('S'));
8824 Make_Object_Declaration
(Loc
,
8825 Defining_Identifier
=>
8829 Object_Definition
=>
8830 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8832 Make_Function_Call
(Loc
,
8833 Name
=> New_Occurrence_Of
(
8834 RTE
(RE_Extract_Union_Value
), Loc
),
8835 Parameter_Associations
=> New_List
(
8836 Build_Get_Aggregate_Element
(Loc
,
8838 Tc
=> Make_Function_Call
(Loc
,
8839 Name
=> New_Occurrence_Of
(
8840 RTE
(RE_Any_Member_Type
), Loc
),
8841 Parameter_Associations
=>
8843 New_Occurrence_Of
(Any
, Loc
),
8844 Make_Integer_Literal
(Loc
,
8846 Idx
=> Make_Integer_Literal
(Loc
,
8850 Make_Block_Statement
(Loc
,
8853 Handled_Statement_Sequence
=>
8854 Make_Handled_Sequence_Of_Statements
(Loc
,
8855 Statements
=> Block_Stmts
)));
8857 Append_To
(Block_Stmts
,
8858 Make_Case_Statement
(Loc
,
8860 Make_Selected_Component
(Loc
,
8863 Chars
(Name
(Field
))),
8867 Variant
:= First_Non_Pragma
(Variants
(Field
));
8868 while Present
(Variant
) loop
8869 Choice_List
:= New_Copy_List_Tree
8870 (Discrete_Choices
(Variant
));
8872 VP_Stmts
:= New_List
;
8874 -- Struct_Counter should be reset before
8875 -- handling a variant part. Indeed only one
8876 -- of the case statement alternatives will be
8877 -- executed at run-time, so the counter must
8878 -- start at 0 for every case statement.
8880 Struct_Counter
:= 0;
8882 FA_Append_Record_Traversal
(
8884 Clist
=> Component_List
(Variant
),
8885 Container
=> Struct_Any
,
8886 Counter
=> Struct_Counter
);
8888 Append_To
(Alt_List
,
8889 Make_Case_Statement_Alternative
(Loc
,
8890 Discrete_Choices
=> Choice_List
,
8893 Next_Non_Pragma
(Variant
);
8897 Counter
:= Counter
+ 1;
8898 end FA_Rec_Add_Process_Element
;
8901 -- First all discriminants
8903 if Has_Discriminants
(Typ
) then
8904 Discriminant_Associations
:= New_List
;
8906 Disc
:= First_Discriminant
(Typ
);
8907 while Present
(Disc
) loop
8909 Disc_Var_Name
: constant Entity_Id
:=
8910 Make_Defining_Identifier
(Loc
,
8911 Chars
=> Chars
(Disc
));
8912 Disc_Type
: constant Entity_Id
:=
8917 Make_Object_Declaration
(Loc
,
8918 Defining_Identifier
=>
8920 Constant_Present
=> True,
8921 Object_Definition
=>
8922 New_Occurrence_Of
(Disc_Type
, Loc
),
8924 Build_From_Any_Call
(Disc_Type
,
8925 Build_Get_Aggregate_Element
(Loc
,
8926 Any
=> Any_Parameter
,
8927 Tc
=> Build_TypeCode_Call
8928 (Loc
, Disc_Type
, Decls
),
8929 Idx
=> Make_Integer_Literal
8930 (Loc
, Component_Counter
)),
8932 Component_Counter
:= Component_Counter
+ 1;
8934 Append_To
(Discriminant_Associations
,
8935 Make_Discriminant_Association
(Loc
,
8936 Selector_Names
=> New_List
(
8937 New_Occurrence_Of
(Disc
, Loc
)),
8939 New_Occurrence_Of
(Disc_Var_Name
, Loc
)));
8941 Next_Discriminant
(Disc
);
8945 Make_Subtype_Indication
(Loc
,
8946 Subtype_Mark
=> Res_Definition
,
8948 Make_Index_Or_Discriminant_Constraint
(Loc
,
8949 Discriminant_Associations
));
8952 -- Now we have all the discriminants in variables, we can
8953 -- declared a constrained object. Note that we are not
8954 -- initializing (non-discriminant) components directly in
8955 -- the object declarations, because which fields to
8956 -- initialize depends (at run time) on the discriminant
8960 Make_Object_Declaration
(Loc
,
8961 Defining_Identifier
=>
8963 Object_Definition
=>
8966 -- ... then all components
8968 FA_Append_Record_Traversal
(Stms
,
8969 Clist
=> Component_List
(Rdef
),
8970 Container
=> Any_Parameter
,
8971 Counter
=> Component_Counter
);
8974 Make_Simple_Return_Statement
(Loc
,
8975 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
8979 elsif Is_Array_Type
(Typ
) then
8981 Constrained
: constant Boolean := Is_Constrained
(Typ
);
8983 procedure FA_Ary_Add_Process_Element
8986 Counter
: Entity_Id
;
8988 -- Assign the current element (as identified by Counter) of
8989 -- Any to the variable denoted by name Datum, and advance
8990 -- Counter by 1. If Datum is not an Any, a call to From_Any
8991 -- for its type is inserted.
8993 --------------------------------
8994 -- FA_Ary_Add_Process_Element --
8995 --------------------------------
8997 procedure FA_Ary_Add_Process_Element
9000 Counter
: Entity_Id
;
9003 Assignment
: constant Node_Id
:=
9004 Make_Assignment_Statement
(Loc
,
9006 Expression
=> Empty
);
9008 Element_Any
: Node_Id
;
9012 Element_TC
: Node_Id
;
9015 if Etype
(Datum
) = RTE
(RE_Any
) then
9017 -- When Datum is an Any the Etype field is not
9018 -- sufficient to determine the typecode of Datum
9019 -- (which can be a TC_SEQUENCE or TC_ARRAY
9020 -- depending on the value of Constrained).
9021 -- Therefore we retrieve the typecode which has
9022 -- been constructed in Append_Array_Traversal with
9023 -- a call to Get_Any_Type.
9026 Make_Function_Call
(Loc
,
9027 Name
=> New_Occurrence_Of
(
9028 RTE
(RE_Get_Any_Type
), Loc
),
9029 Parameter_Associations
=> New_List
(
9030 New_Occurrence_Of
(Entity
(Datum
), Loc
)));
9032 -- For non Any Datum we simply construct a typecode
9033 -- matching the Etype of the Datum.
9035 Element_TC
:= Build_TypeCode_Call
9036 (Loc
, Etype
(Datum
), Decls
);
9040 Build_Get_Aggregate_Element
(Loc
,
9043 Idx
=> New_Occurrence_Of
(Counter
, Loc
));
9046 -- Note: here we *prepend* statements to Stmts, so
9047 -- we must do it in reverse order.
9050 Make_Assignment_Statement
(Loc
,
9052 New_Occurrence_Of
(Counter
, Loc
),
9056 New_Occurrence_Of
(Counter
, Loc
),
9058 Make_Integer_Literal
(Loc
, 1))));
9060 if Nkind
(Datum
) /= N_Attribute_Reference
then
9062 -- We ignore the value of the length of each
9063 -- dimension, since the target array has already
9064 -- been constrained anyway.
9066 if Etype
(Datum
) /= RTE
(RE_Any
) then
9067 Set_Expression
(Assignment
,
9068 Build_From_Any_Call
(
9069 Component_Type
(Typ
),
9073 Set_Expression
(Assignment
, Element_Any
);
9076 Prepend_To
(Stmts
, Assignment
);
9078 end FA_Ary_Add_Process_Element
;
9080 ------------------------
9081 -- Local Declarations --
9082 ------------------------
9084 Counter
: constant Entity_Id
:=
9085 Make_Defining_Identifier
(Loc
, Name_J
);
9087 Initial_Counter_Value
: Int
:= 0;
9089 Component_TC
: constant Entity_Id
:=
9090 Make_Defining_Identifier
(Loc
, Name_T
);
9092 Res
: constant Entity_Id
:=
9093 Make_Defining_Identifier
(Loc
, Name_R
);
9095 procedure Append_From_Any_Array_Iterator
is
9096 new Append_Array_Traversal
(
9099 Indices
=> New_List
,
9100 Add_Process_Element
=> FA_Ary_Add_Process_Element
);
9102 Res_Subtype_Indication
: Node_Id
:=
9103 New_Occurrence_Of
(Typ
, Loc
);
9106 if not Constrained
then
9108 Ndim
: constant Int
:= Number_Dimensions
(Typ
);
9111 Indx
: Node_Id
:= First_Index
(Typ
);
9114 Ranges
: constant List_Id
:= New_List
;
9117 for J
in 1 .. Ndim
loop
9118 Lnam
:= New_External_Name
('L', J
);
9119 Hnam
:= New_External_Name
('H', J
);
9120 Indt
:= Etype
(Indx
);
9123 Make_Object_Declaration
(Loc
,
9124 Defining_Identifier
=>
9125 Make_Defining_Identifier
(Loc
, Lnam
),
9128 Object_Definition
=>
9129 New_Occurrence_Of
(Indt
, Loc
),
9131 Build_From_Any_Call
(
9133 Build_Get_Aggregate_Element
(Loc
,
9134 Any
=> Any_Parameter
,
9135 Tc
=> Build_TypeCode_Call
(Loc
,
9137 Idx
=> Make_Integer_Literal
(Loc
, J
- 1)),
9141 Make_Object_Declaration
(Loc
,
9142 Defining_Identifier
=>
9143 Make_Defining_Identifier
(Loc
, Hnam
),
9146 Object_Definition
=>
9147 New_Occurrence_Of
(Indt
, Loc
),
9148 Expression
=> Make_Attribute_Reference
(Loc
,
9150 New_Occurrence_Of
(Indt
, Loc
),
9151 Attribute_Name
=> Name_Val
,
9152 Expressions
=> New_List
(
9153 Make_Op_Subtract
(Loc
,
9158 Standard_Long_Integer
,
9159 Make_Identifier
(Loc
, Lnam
)),
9162 Standard_Long_Integer
,
9163 Make_Function_Call
(Loc
,
9164 Name
=> New_Occurrence_Of
(RTE
(
9165 RE_Get_Nested_Sequence_Length
9167 Parameter_Associations
=>
9170 Any_Parameter
, Loc
),
9171 Make_Integer_Literal
(Loc
,
9174 Make_Integer_Literal
(Loc
, 1))))));
9178 Low_Bound
=> Make_Identifier
(Loc
, Lnam
),
9179 High_Bound
=> Make_Identifier
(Loc
, Hnam
)));
9184 -- Now we have all the necessary bound information:
9185 -- apply the set of range constraints to the
9186 -- (unconstrained) nominal subtype of Res.
9188 Initial_Counter_Value
:= Ndim
;
9189 Res_Subtype_Indication
:= Make_Subtype_Indication
(Loc
,
9191 Res_Subtype_Indication
,
9193 Make_Index_Or_Discriminant_Constraint
(Loc
,
9194 Constraints
=> Ranges
));
9199 Make_Object_Declaration
(Loc
,
9200 Defining_Identifier
=> Res
,
9201 Object_Definition
=> Res_Subtype_Indication
));
9202 Set_Etype
(Res
, Typ
);
9205 Make_Object_Declaration
(Loc
,
9206 Defining_Identifier
=> Counter
,
9207 Object_Definition
=>
9208 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
9210 Make_Integer_Literal
(Loc
, Initial_Counter_Value
)));
9213 Make_Object_Declaration
(Loc
,
9214 Defining_Identifier
=> Component_TC
,
9215 Constant_Present
=> True,
9216 Object_Definition
=>
9217 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
),
9219 Build_TypeCode_Call
(Loc
,
9220 Component_Type
(Typ
), Decls
)));
9222 Append_From_Any_Array_Iterator
(Stms
,
9223 Any_Parameter
, Counter
);
9226 Make_Simple_Return_Statement
(Loc
,
9227 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
9230 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9232 Make_Simple_Return_Statement
(Loc
,
9234 Unchecked_Convert_To
(
9236 Build_From_Any_Call
(
9237 Find_Numeric_Representation
(Typ
),
9238 New_Occurrence_Of
(Any_Parameter
, Loc
),
9242 -- Default: type is represented as an opaque sequence of bytes
9245 Strm
: constant Entity_Id
:=
9246 Make_Defining_Identifier
(Loc
,
9247 Chars
=> New_Internal_Name
('S'));
9248 Res
: constant Entity_Id
:=
9249 Make_Defining_Identifier
(Loc
,
9250 Chars
=> New_Internal_Name
('R'));
9253 -- Strm : Buffer_Stream_Type;
9256 Make_Object_Declaration
(Loc
,
9257 Defining_Identifier
=>
9261 Object_Definition
=>
9262 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
9264 -- Allocate_Buffer (Strm);
9267 Make_Procedure_Call_Statement
(Loc
,
9269 New_Occurrence_Of
(RTE
(RE_Allocate_Buffer
), Loc
),
9270 Parameter_Associations
=> New_List
(
9271 New_Occurrence_Of
(Strm
, Loc
))));
9273 -- Any_To_BS (Strm, A);
9276 Make_Procedure_Call_Statement
(Loc
,
9278 New_Occurrence_Of
(RTE
(RE_Any_To_BS
), Loc
),
9279 Parameter_Associations
=> New_List
(
9280 New_Occurrence_Of
(Any_Parameter
, Loc
),
9281 New_Occurrence_Of
(Strm
, Loc
))));
9284 -- Res : constant T := T'Input (Strm);
9286 -- Release_Buffer (Strm);
9290 Append_To
(Stms
, Make_Block_Statement
(Loc
,
9291 Declarations
=> New_List
(
9292 Make_Object_Declaration
(Loc
,
9293 Defining_Identifier
=> Res
,
9294 Constant_Present
=> True,
9295 Object_Definition
=>
9296 New_Occurrence_Of
(Typ
, Loc
),
9298 Make_Attribute_Reference
(Loc
,
9299 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
9300 Attribute_Name
=> Name_Input
,
9301 Expressions
=> New_List
(
9302 Make_Attribute_Reference
(Loc
,
9303 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
9304 Attribute_Name
=> Name_Access
))))),
9306 Handled_Statement_Sequence
=>
9307 Make_Handled_Sequence_Of_Statements
(Loc
,
9308 Statements
=> New_List
(
9309 Make_Procedure_Call_Statement
(Loc
,
9311 New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
9312 Parameter_Associations
=>
9314 New_Occurrence_Of
(Strm
, Loc
))),
9315 Make_Simple_Return_Statement
(Loc
,
9316 Expression
=> New_Occurrence_Of
(Res
, Loc
))))));
9322 Make_Subprogram_Body
(Loc
,
9323 Specification
=> Spec
,
9324 Declarations
=> Decls
,
9325 Handled_Statement_Sequence
=>
9326 Make_Handled_Sequence_Of_Statements
(Loc
,
9327 Statements
=> Stms
));
9328 end Build_From_Any_Function
;
9330 ---------------------------------
9331 -- Build_Get_Aggregate_Element --
9332 ---------------------------------
9334 function Build_Get_Aggregate_Element
9338 Idx
: Node_Id
) return Node_Id
9341 return Make_Function_Call
(Loc
,
9344 RTE
(RE_Get_Aggregate_Element
), Loc
),
9345 Parameter_Associations
=> New_List
(
9346 New_Occurrence_Of
(Any
, Loc
),
9349 end Build_Get_Aggregate_Element
;
9351 -------------------------
9352 -- Build_Reposiroty_Id --
9353 -------------------------
9355 procedure Build_Name_And_Repository_Id
9357 Name_Str
: out String_Id
;
9358 Repo_Id_Str
: out String_Id
)
9362 Store_String_Chars
("DSA:");
9363 Get_Library_Unit_Name_String
(Scope
(E
));
9365 (Name_Buffer
(Name_Buffer
'First ..
9366 Name_Buffer
'First + Name_Len
- 1));
9367 Store_String_Char
('.');
9368 Get_Name_String
(Chars
(E
));
9370 (Name_Buffer
(Name_Buffer
'First ..
9371 Name_Buffer
'First + Name_Len
- 1));
9372 Store_String_Chars
(":1.0");
9373 Repo_Id_Str
:= End_String
;
9374 Name_Str
:= String_From_Name_Buffer
;
9375 end Build_Name_And_Repository_Id
;
9377 -----------------------
9378 -- Build_To_Any_Call --
9379 -----------------------
9381 function Build_To_Any_Call
9383 Decls
: List_Id
) return Node_Id
9385 Loc
: constant Source_Ptr
:= Sloc
(N
);
9387 Typ
: Entity_Id
:= Etype
(N
);
9389 Fnam
: Entity_Id
:= Empty
;
9390 Lib_RE
: RE_Id
:= RE_Null
;
9393 -- If N is a selected component, then maybe its Etype has not been
9394 -- set yet: try to use Etype of the selector_name in that case.
9396 if No
(Typ
) and then Nkind
(N
) = N_Selected_Component
then
9397 Typ
:= Etype
(Selector_Name
(N
));
9399 pragma Assert
(Present
(Typ
));
9401 -- Get full view for private type, completion for incomplete type
9403 U_Type
:= Underlying_Type
(Typ
);
9405 -- First simple case where the To_Any function is present in the
9408 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_To_Any
);
9410 -- Check first for Boolean and Character. These are enumeration
9411 -- types, but we treat them specially, since they may require
9412 -- special handling in the transfer protocol. However, this
9413 -- special handling only applies if they have standard
9414 -- representation, otherwise they are treated like any other
9415 -- enumeration type.
9417 if Sloc
(U_Type
) <= Standard_Location
then
9418 U_Type
:= Base_Type
(U_Type
);
9421 if Present
(Fnam
) then
9424 elsif U_Type
= Standard_Boolean
then
9427 elsif U_Type
= Standard_Character
then
9430 elsif U_Type
= Standard_Wide_Character
then
9433 elsif U_Type
= Standard_Wide_Wide_Character
then
9434 Lib_RE
:= RE_TA_WWC
;
9436 -- Floating point types
9438 elsif U_Type
= Standard_Short_Float
then
9441 elsif U_Type
= Standard_Float
then
9444 elsif U_Type
= Standard_Long_Float
then
9447 elsif U_Type
= Standard_Long_Long_Float
then
9448 Lib_RE
:= RE_TA_LLF
;
9452 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
9453 Lib_RE
:= RE_TA_SSI
;
9455 elsif U_Type
= Etype
(Standard_Short_Integer
) then
9458 elsif U_Type
= Etype
(Standard_Integer
) then
9461 elsif U_Type
= Etype
(Standard_Long_Integer
) then
9464 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
9465 Lib_RE
:= RE_TA_LLI
;
9467 -- Unsigned integer types
9469 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
9470 Lib_RE
:= RE_TA_SSU
;
9472 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
9475 elsif U_Type
= RTE
(RE_Unsigned
) then
9478 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
9481 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
9482 Lib_RE
:= RE_TA_LLU
;
9484 elsif U_Type
= Standard_String
then
9485 Lib_RE
:= RE_TA_String
;
9487 elsif U_Type
= Underlying_Type
(RTE
(RE_TypeCode
)) then
9490 -- Other (non-primitive) types
9496 Build_To_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
9497 Append_To
(Decls
, Decl
);
9501 -- Call the function
9503 if Lib_RE
/= RE_Null
then
9504 pragma Assert
(No
(Fnam
));
9505 Fnam
:= RTE
(Lib_RE
);
9509 Make_Function_Call
(Loc
,
9510 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
9511 Parameter_Associations
=>
9512 New_List
(Unchecked_Convert_To
(U_Type
, N
)));
9513 end Build_To_Any_Call
;
9515 ---------------------------
9516 -- Build_To_Any_Function --
9517 ---------------------------
9519 procedure Build_To_Any_Function
9523 Fnam
: out Entity_Id
)
9526 Decls
: constant List_Id
:= New_List
;
9527 Stms
: constant List_Id
:= New_List
;
9529 Expr_Parameter
: constant Entity_Id
:=
9530 Make_Defining_Identifier
(Loc
, Name_E
);
9532 Any
: constant Entity_Id
:=
9533 Make_Defining_Identifier
(Loc
, Name_A
);
9536 Result_TC
: Node_Id
:= Build_TypeCode_Call
(Loc
, Typ
, Decls
);
9539 if Is_Itype
(Typ
) then
9540 Build_To_Any_Function
9548 Fnam
:= Make_Stream_Procedure_Function_Name
(Loc
,
9552 Make_Function_Specification
(Loc
,
9553 Defining_Unit_Name
=> Fnam
,
9554 Parameter_Specifications
=> New_List
(
9555 Make_Parameter_Specification
(Loc
,
9556 Defining_Identifier
=>
9559 New_Occurrence_Of
(Typ
, Loc
))),
9560 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9561 Set_Etype
(Expr_Parameter
, Typ
);
9564 Make_Object_Declaration
(Loc
,
9565 Defining_Identifier
=>
9567 Object_Definition
=>
9568 New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9570 if Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9572 Rt_Type
: constant Entity_Id
9574 Expr
: constant Node_Id
9577 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9579 Set_Expression
(Any_Decl
, Build_To_Any_Call
(Expr
, Decls
));
9582 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9583 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
9585 Rt_Type
: constant Entity_Id
9587 Expr
: constant Node_Id
9590 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9593 Set_Expression
(Any_Decl
,
9594 Build_To_Any_Call
(Expr
, Decls
));
9599 Disc
: Entity_Id
:= Empty
;
9600 Rdef
: constant Node_Id
:=
9601 Type_Definition
(Declaration_Node
(Typ
));
9603 Elements
: constant List_Id
:= New_List
;
9605 procedure TA_Rec_Add_Process_Element
9607 Container
: Node_Or_Entity_Id
;
9608 Counter
: in out Int
;
9612 procedure TA_Append_Record_Traversal
is
9613 new Append_Record_Traversal
9614 (Rec
=> Expr_Parameter
,
9615 Add_Process_Element
=> TA_Rec_Add_Process_Element
);
9617 --------------------------------
9618 -- TA_Rec_Add_Process_Element --
9619 --------------------------------
9621 procedure TA_Rec_Add_Process_Element
9623 Container
: Node_Or_Entity_Id
;
9624 Counter
: in out Int
;
9628 Field_Ref
: Node_Id
;
9631 if Nkind
(Field
) = N_Defining_Identifier
then
9633 -- A regular component
9635 Field_Ref
:= Make_Selected_Component
(Loc
,
9636 Prefix
=> New_Occurrence_Of
(Rec
, Loc
),
9637 Selector_Name
=> New_Occurrence_Of
(Field
, Loc
));
9638 Set_Etype
(Field_Ref
, Etype
(Field
));
9641 Make_Procedure_Call_Statement
(Loc
,
9644 RTE
(RE_Add_Aggregate_Element
), Loc
),
9645 Parameter_Associations
=> New_List
(
9646 New_Occurrence_Of
(Container
, Loc
),
9647 Build_To_Any_Call
(Field_Ref
, Decls
))));
9654 Struct_Counter
: Int
:= 0;
9656 Block_Decls
: constant List_Id
:= New_List
;
9657 Block_Stmts
: constant List_Id
:= New_List
;
9660 Alt_List
: constant List_Id
:= New_List
;
9661 Choice_List
: List_Id
;
9663 Union_Any
: constant Entity_Id
:=
9664 Make_Defining_Identifier
(Loc
,
9665 New_Internal_Name
('V'));
9667 Struct_Any
: constant Entity_Id
:=
9668 Make_Defining_Identifier
(Loc
,
9669 New_Internal_Name
('S'));
9671 function Make_Discriminant_Reference
9673 -- Build a selected component for the
9674 -- discriminant of this variant part.
9676 ---------------------------------
9677 -- Make_Discriminant_Reference --
9678 ---------------------------------
9680 function Make_Discriminant_Reference
9683 Nod
: constant Node_Id
:=
9684 Make_Selected_Component
(Loc
,
9687 Chars
(Name
(Field
)));
9689 Set_Etype
(Nod
, Etype
(Name
(Field
)));
9691 end Make_Discriminant_Reference
;
9695 Make_Block_Statement
(Loc
,
9698 Handled_Statement_Sequence
=>
9699 Make_Handled_Sequence_Of_Statements
(Loc
,
9700 Statements
=> Block_Stmts
)));
9702 -- Declare the Variant Part aggregate
9704 -- Knowing the position of this VP in
9705 -- the variant record, we can fetch the
9706 -- VP typecode from Container.
9708 Append_To
(Block_Decls
,
9709 Make_Object_Declaration
(Loc
,
9710 Defining_Identifier
=> Union_Any
,
9711 Object_Definition
=>
9712 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9714 Make_Function_Call
(Loc
,
9715 Name
=> New_Occurrence_Of
(
9716 RTE
(RE_Create_Any
), Loc
),
9717 Parameter_Associations
=> New_List
(
9718 Make_Function_Call
(Loc
,
9721 RTE
(RE_Any_Member_Type
), Loc
),
9722 Parameter_Associations
=> New_List
(
9723 New_Occurrence_Of
(Container
, Loc
),
9724 Make_Integer_Literal
(Loc
,
9727 -- Declare the inner struct aggregate
9728 -- (that will contain the components
9731 Append_To
(Block_Decls
,
9732 Make_Object_Declaration
(Loc
,
9733 Defining_Identifier
=> Struct_Any
,
9734 Object_Definition
=>
9735 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9737 Make_Function_Call
(Loc
,
9738 Name
=> New_Occurrence_Of
(
9739 RTE
(RE_Create_Any
), Loc
),
9740 Parameter_Associations
=> New_List
(
9741 Make_Function_Call
(Loc
,
9744 RTE
(RE_Any_Member_Type
), Loc
),
9745 Parameter_Associations
=> New_List
(
9746 New_Occurrence_Of
(Union_Any
, Loc
),
9747 Make_Integer_Literal
(Loc
,
9750 -- Construct a case statement that will choose
9751 -- the appropriate code at runtime depending on
9752 -- the discriminant.
9754 Append_To
(Block_Stmts
,
9755 Make_Case_Statement
(Loc
,
9757 Make_Discriminant_Reference
,
9761 Variant
:= First_Non_Pragma
(Variants
(Field
));
9762 while Present
(Variant
) loop
9763 Choice_List
:= New_Copy_List_Tree
9764 (Discrete_Choices
(Variant
));
9766 VP_Stmts
:= New_List
;
9768 -- Append discriminant value to union
9771 Append_To
(VP_Stmts
,
9772 Make_Procedure_Call_Statement
(Loc
,
9775 RTE
(RE_Add_Aggregate_Element
), Loc
),
9776 Parameter_Associations
=> New_List
(
9777 New_Occurrence_Of
(Union_Any
, Loc
),
9779 Make_Discriminant_Reference
,
9782 -- Populate inner struct aggregate
9784 -- Struct_Counter should be reset before
9785 -- handling a variant part. Indeed only one
9786 -- of the case statement alternatives will be
9787 -- executed at run-time, so the counter must
9788 -- start at 0 for every case statement.
9790 Struct_Counter
:= 0;
9792 TA_Append_Record_Traversal
(
9794 Clist
=> Component_List
(Variant
),
9795 Container
=> Struct_Any
,
9796 Counter
=> Struct_Counter
);
9798 -- Append inner struct to union aggregate
9800 Append_To
(VP_Stmts
,
9801 Make_Procedure_Call_Statement
(Loc
,
9804 RTE
(RE_Add_Aggregate_Element
), Loc
),
9805 Parameter_Associations
=> New_List
(
9806 New_Occurrence_Of
(Union_Any
, Loc
),
9807 New_Occurrence_Of
(Struct_Any
, Loc
))));
9809 -- Append union to outer aggregate
9811 Append_To
(VP_Stmts
,
9812 Make_Procedure_Call_Statement
(Loc
,
9815 RTE
(RE_Add_Aggregate_Element
), Loc
),
9816 Parameter_Associations
=> New_List
(
9817 New_Occurrence_Of
(Container
, Loc
),
9819 (Union_Any
, Loc
))));
9821 Append_To
(Alt_List
,
9822 Make_Case_Statement_Alternative
(Loc
,
9823 Discrete_Choices
=> Choice_List
,
9824 Statements
=> VP_Stmts
));
9826 Next_Non_Pragma
(Variant
);
9830 Counter
:= Counter
+ 1;
9831 end TA_Rec_Add_Process_Element
;
9834 -- Records are encoded in a TC_STRUCT aggregate:
9836 -- -- Outer aggregate (TC_STRUCT)
9837 -- | [discriminant1]
9838 -- | [discriminant2]
9845 -- A component can be a common component or variant part
9847 -- A variant part is encoded as a TC_UNION aggregate:
9849 -- -- Variant Part Aggregate (TC_UNION)
9850 -- | [discriminant choice for this Variant Part]
9852 -- | -- Inner struct (TC_STRUCT)
9857 -- Let's start by building the outer aggregate. First we
9858 -- construct Elements array containing all discriminants.
9860 if Has_Discriminants
(Typ
) then
9861 Disc
:= First_Discriminant
(Typ
);
9862 while Present
(Disc
) loop
9864 Discriminant
: constant Entity_Id
:=
9865 Make_Selected_Component
(Loc
,
9872 Set_Etype
(Discriminant
, Etype
(Disc
));
9874 Append_To
(Elements
,
9875 Make_Component_Association
(Loc
,
9876 Choices
=> New_List
(
9877 Make_Integer_Literal
(Loc
, Counter
)),
9879 Build_To_Any_Call
(Discriminant
, Decls
)));
9882 Counter
:= Counter
+ 1;
9883 Next_Discriminant
(Disc
);
9887 -- If there are no discriminants, we declare an empty
9891 Dummy_Any
: constant Entity_Id
:=
9892 Make_Defining_Identifier
(Loc
,
9893 Chars
=> New_Internal_Name
('A'));
9897 Make_Object_Declaration
(Loc
,
9898 Defining_Identifier
=> Dummy_Any
,
9899 Object_Definition
=>
9900 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
9902 Append_To
(Elements
,
9903 Make_Component_Association
(Loc
,
9904 Choices
=> New_List
(
9907 Make_Integer_Literal
(Loc
, 1),
9909 Make_Integer_Literal
(Loc
, 0))),
9911 New_Occurrence_Of
(Dummy_Any
, Loc
)));
9915 -- We build the result aggregate with discriminants
9916 -- as the first elements.
9918 Set_Expression
(Any_Decl
,
9919 Make_Function_Call
(Loc
,
9920 Name
=> New_Occurrence_Of
(
9921 RTE
(RE_Any_Aggregate_Build
), Loc
),
9922 Parameter_Associations
=> New_List
(
9924 Make_Aggregate
(Loc
,
9925 Component_Associations
=> Elements
))));
9928 -- Then we append all the components to the result
9931 TA_Append_Record_Traversal
(Stms
,
9932 Clist
=> Component_List
(Rdef
),
9934 Counter
=> Counter
);
9938 elsif Is_Array_Type
(Typ
) then
9940 Constrained
: constant Boolean := Is_Constrained
(Typ
);
9942 procedure TA_Ary_Add_Process_Element
9945 Counter
: Entity_Id
;
9948 --------------------------------
9949 -- TA_Ary_Add_Process_Element --
9950 --------------------------------
9952 procedure TA_Ary_Add_Process_Element
9955 Counter
: Entity_Id
;
9958 pragma Warnings
(Off
);
9959 pragma Unreferenced
(Counter
);
9960 pragma Warnings
(On
);
9962 Element_Any
: Node_Id
;
9965 if Etype
(Datum
) = RTE
(RE_Any
) then
9966 Element_Any
:= Datum
;
9968 Element_Any
:= Build_To_Any_Call
(Datum
, Decls
);
9972 Make_Procedure_Call_Statement
(Loc
,
9973 Name
=> New_Occurrence_Of
(
9974 RTE
(RE_Add_Aggregate_Element
), Loc
),
9975 Parameter_Associations
=> New_List
(
9976 New_Occurrence_Of
(Any
, Loc
),
9978 end TA_Ary_Add_Process_Element
;
9980 procedure Append_To_Any_Array_Iterator
is
9981 new Append_Array_Traversal
(
9983 Arry
=> Expr_Parameter
,
9984 Indices
=> New_List
,
9985 Add_Process_Element
=> TA_Ary_Add_Process_Element
);
9990 Set_Expression
(Any_Decl
,
9991 Make_Function_Call
(Loc
,
9993 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
9994 Parameter_Associations
=> New_List
(Result_TC
)));
9997 if not Constrained
then
9998 Index
:= First_Index
(Typ
);
9999 for J
in 1 .. Number_Dimensions
(Typ
) loop
10001 Make_Procedure_Call_Statement
(Loc
,
10003 New_Occurrence_Of
(
10004 RTE
(RE_Add_Aggregate_Element
), Loc
),
10005 Parameter_Associations
=> New_List
(
10006 New_Occurrence_Of
(Any
, Loc
),
10007 Build_To_Any_Call
(
10008 OK_Convert_To
(Etype
(Index
),
10009 Make_Attribute_Reference
(Loc
,
10011 New_Occurrence_Of
(Expr_Parameter
, Loc
),
10012 Attribute_Name
=> Name_First
,
10013 Expressions
=> New_List
(
10014 Make_Integer_Literal
(Loc
, J
)))),
10016 Next_Index
(Index
);
10020 Append_To_Any_Array_Iterator
(Stms
, Any
);
10023 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
10024 Set_Expression
(Any_Decl
,
10025 Build_To_Any_Call
(
10027 Find_Numeric_Representation
(Typ
),
10028 New_Occurrence_Of
(Expr_Parameter
, Loc
)),
10032 -- Default: type is represented as an opaque sequence of bytes
10035 Strm
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
10036 New_Internal_Name
('S'));
10039 -- Strm : aliased Buffer_Stream_Type;
10042 Make_Object_Declaration
(Loc
,
10043 Defining_Identifier
=>
10047 Object_Definition
=>
10048 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
10050 -- Allocate_Buffer (Strm);
10053 Make_Procedure_Call_Statement
(Loc
,
10055 New_Occurrence_Of
(RTE
(RE_Allocate_Buffer
), Loc
),
10056 Parameter_Associations
=> New_List
(
10057 New_Occurrence_Of
(Strm
, Loc
))));
10059 -- T'Output (Strm'Access, E);
10062 Make_Attribute_Reference
(Loc
,
10063 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
10064 Attribute_Name
=> Name_Output
,
10065 Expressions
=> New_List
(
10066 Make_Attribute_Reference
(Loc
,
10067 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
10068 Attribute_Name
=> Name_Access
),
10069 New_Occurrence_Of
(Expr_Parameter
, Loc
))));
10071 -- BS_To_Any (Strm, A);
10074 Make_Procedure_Call_Statement
(Loc
,
10076 New_Occurrence_Of
(RTE
(RE_BS_To_Any
), Loc
),
10077 Parameter_Associations
=> New_List
(
10078 New_Occurrence_Of
(Strm
, Loc
),
10079 New_Occurrence_Of
(Any
, Loc
))));
10081 -- Release_Buffer (Strm);
10084 Make_Procedure_Call_Statement
(Loc
,
10086 New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
10087 Parameter_Associations
=> New_List
(
10088 New_Occurrence_Of
(Strm
, Loc
))));
10092 Append_To
(Decls
, Any_Decl
);
10094 if Present
(Result_TC
) then
10096 Make_Procedure_Call_Statement
(Loc
,
10097 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
10098 Parameter_Associations
=> New_List
(
10099 New_Occurrence_Of
(Any
, Loc
),
10104 Make_Simple_Return_Statement
(Loc
,
10105 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
10108 Make_Subprogram_Body
(Loc
,
10109 Specification
=> Spec
,
10110 Declarations
=> Decls
,
10111 Handled_Statement_Sequence
=>
10112 Make_Handled_Sequence_Of_Statements
(Loc
,
10113 Statements
=> Stms
));
10114 end Build_To_Any_Function
;
10116 -------------------------
10117 -- Build_TypeCode_Call --
10118 -------------------------
10120 function Build_TypeCode_Call
10123 Decls
: List_Id
) return Node_Id
10125 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
10126 -- The full view, if Typ is private; the completion,
10127 -- if Typ is incomplete.
10129 Fnam
: Entity_Id
:= Empty
;
10130 Lib_RE
: RE_Id
:= RE_Null
;
10135 -- Special case System.PolyORB.Interface.Any: its primitives have
10136 -- not been set yet, so can't call Find_Inherited_TSS.
10138 if Typ
= RTE
(RE_Any
) then
10139 Fnam
:= RTE
(RE_TC_Any
);
10142 -- First simple case where the TypeCode is present
10143 -- in the type's TSS.
10145 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_TypeCode
);
10149 if Sloc
(U_Type
) <= Standard_Location
then
10151 -- Do not try to build alias typecodes for subtypes from
10154 U_Type
:= Base_Type
(U_Type
);
10157 if U_Type
= Standard_Boolean
then
10160 elsif U_Type
= Standard_Character
then
10163 elsif U_Type
= Standard_Wide_Character
then
10164 Lib_RE
:= RE_TC_WC
;
10166 elsif U_Type
= Standard_Wide_Wide_Character
then
10167 Lib_RE
:= RE_TC_WWC
;
10169 -- Floating point types
10171 elsif U_Type
= Standard_Short_Float
then
10172 Lib_RE
:= RE_TC_SF
;
10174 elsif U_Type
= Standard_Float
then
10177 elsif U_Type
= Standard_Long_Float
then
10178 Lib_RE
:= RE_TC_LF
;
10180 elsif U_Type
= Standard_Long_Long_Float
then
10181 Lib_RE
:= RE_TC_LLF
;
10183 -- Integer types (walk back to the base type)
10185 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
10186 Lib_RE
:= RE_TC_SSI
;
10188 elsif U_Type
= Etype
(Standard_Short_Integer
) then
10189 Lib_RE
:= RE_TC_SI
;
10191 elsif U_Type
= Etype
(Standard_Integer
) then
10194 elsif U_Type
= Etype
(Standard_Long_Integer
) then
10195 Lib_RE
:= RE_TC_LI
;
10197 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
10198 Lib_RE
:= RE_TC_LLI
;
10200 -- Unsigned integer types
10202 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
10203 Lib_RE
:= RE_TC_SSU
;
10205 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
10206 Lib_RE
:= RE_TC_SU
;
10208 elsif U_Type
= RTE
(RE_Unsigned
) then
10211 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
10212 Lib_RE
:= RE_TC_LU
;
10214 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
10215 Lib_RE
:= RE_TC_LLU
;
10217 elsif U_Type
= Standard_String
then
10218 Lib_RE
:= RE_TC_String
;
10220 -- Other (non-primitive) types
10226 Build_TypeCode_Function
(Loc
, U_Type
, Decl
, Fnam
);
10227 Append_To
(Decls
, Decl
);
10231 if Lib_RE
/= RE_Null
then
10232 Fnam
:= RTE
(Lib_RE
);
10236 -- Call the function
10239 Make_Function_Call
(Loc
, Name
=> New_Occurrence_Of
(Fnam
, Loc
));
10241 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10243 Set_Etype
(Expr
, RTE
(RE_TypeCode
));
10246 end Build_TypeCode_Call
;
10248 -----------------------------
10249 -- Build_TypeCode_Function --
10250 -----------------------------
10252 procedure Build_TypeCode_Function
10255 Decl
: out Node_Id
;
10256 Fnam
: out Entity_Id
)
10259 Decls
: constant List_Id
:= New_List
;
10260 Stms
: constant List_Id
:= New_List
;
10262 TCNam
: constant Entity_Id
:=
10263 Make_Stream_Procedure_Function_Name
(Loc
,
10264 Typ
, Name_uTypeCode
);
10266 Parameters
: List_Id
;
10268 procedure Add_String_Parameter
10270 Parameter_List
: List_Id
);
10271 -- Add a literal for S to Parameters
10273 procedure Add_TypeCode_Parameter
10274 (TC_Node
: Node_Id
;
10275 Parameter_List
: List_Id
);
10276 -- Add the typecode for Typ to Parameters
10278 procedure Add_Long_Parameter
10279 (Expr_Node
: Node_Id
;
10280 Parameter_List
: List_Id
);
10281 -- Add a signed long integer expression to Parameters
10283 procedure Initialize_Parameter_List
10284 (Name_String
: String_Id
;
10285 Repo_Id_String
: String_Id
;
10286 Parameter_List
: out List_Id
);
10287 -- Return a list that contains the first two parameters
10288 -- for a parameterized typecode: name and repository id.
10290 function Make_Constructed_TypeCode
10292 Parameters
: List_Id
) return Node_Id
;
10293 -- Call TC_Build with the given kind and parameters
10295 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
);
10296 -- Make a return statement that calls TC_Build with the given
10297 -- typecode kind, and the constructed parameters list.
10299 procedure Return_Alias_TypeCode
(Base_TypeCode
: Node_Id
);
10300 -- Return a typecode that is a TC_Alias for the given typecode
10302 --------------------------
10303 -- Add_String_Parameter --
10304 --------------------------
10306 procedure Add_String_Parameter
10308 Parameter_List
: List_Id
)
10311 Append_To
(Parameter_List
,
10312 Make_Function_Call
(Loc
,
10314 New_Occurrence_Of
(RTE
(RE_TA_String
), Loc
),
10315 Parameter_Associations
=> New_List
(
10316 Make_String_Literal
(Loc
, S
))));
10317 end Add_String_Parameter
;
10319 ----------------------------
10320 -- Add_TypeCode_Parameter --
10321 ----------------------------
10323 procedure Add_TypeCode_Parameter
10324 (TC_Node
: Node_Id
;
10325 Parameter_List
: List_Id
)
10328 Append_To
(Parameter_List
,
10329 Make_Function_Call
(Loc
,
10331 New_Occurrence_Of
(RTE
(RE_TA_TC
), Loc
),
10332 Parameter_Associations
=> New_List
(
10334 end Add_TypeCode_Parameter
;
10336 ------------------------
10337 -- Add_Long_Parameter --
10338 ------------------------
10340 procedure Add_Long_Parameter
10341 (Expr_Node
: Node_Id
;
10342 Parameter_List
: List_Id
)
10345 Append_To
(Parameter_List
,
10346 Make_Function_Call
(Loc
,
10348 New_Occurrence_Of
(RTE
(RE_TA_LI
), Loc
),
10349 Parameter_Associations
=> New_List
(Expr_Node
)));
10350 end Add_Long_Parameter
;
10352 -------------------------------
10353 -- Initialize_Parameter_List --
10354 -------------------------------
10356 procedure Initialize_Parameter_List
10357 (Name_String
: String_Id
;
10358 Repo_Id_String
: String_Id
;
10359 Parameter_List
: out List_Id
)
10362 Parameter_List
:= New_List
;
10363 Add_String_Parameter
(Name_String
, Parameter_List
);
10364 Add_String_Parameter
(Repo_Id_String
, Parameter_List
);
10365 end Initialize_Parameter_List
;
10367 ---------------------------
10368 -- Return_Alias_TypeCode --
10369 ---------------------------
10371 procedure Return_Alias_TypeCode
10372 (Base_TypeCode
: Node_Id
)
10375 Add_TypeCode_Parameter
(Base_TypeCode
, Parameters
);
10376 Return_Constructed_TypeCode
(RTE
(RE_TC_Alias
));
10377 end Return_Alias_TypeCode
;
10379 -------------------------------
10380 -- Make_Constructed_TypeCode --
10381 -------------------------------
10383 function Make_Constructed_TypeCode
10385 Parameters
: List_Id
) return Node_Id
10387 Constructed_TC
: constant Node_Id
:=
10388 Make_Function_Call
(Loc
,
10390 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
10391 Parameter_Associations
=> New_List
(
10392 New_Occurrence_Of
(Kind
, Loc
),
10393 Make_Aggregate
(Loc
,
10394 Expressions
=> Parameters
)));
10396 Set_Etype
(Constructed_TC
, RTE
(RE_TypeCode
));
10397 return Constructed_TC
;
10398 end Make_Constructed_TypeCode
;
10400 ---------------------------------
10401 -- Return_Constructed_TypeCode --
10402 ---------------------------------
10404 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
) is
10407 Make_Simple_Return_Statement
(Loc
,
10409 Make_Constructed_TypeCode
(Kind
, Parameters
)));
10410 end Return_Constructed_TypeCode
;
10416 procedure TC_Rec_Add_Process_Element
10419 Counter
: in out Int
;
10423 procedure TC_Append_Record_Traversal
is
10424 new Append_Record_Traversal
(
10426 Add_Process_Element
=> TC_Rec_Add_Process_Element
);
10428 --------------------------------
10429 -- TC_Rec_Add_Process_Element --
10430 --------------------------------
10432 procedure TC_Rec_Add_Process_Element
10435 Counter
: in out Int
;
10439 pragma Warnings
(Off
);
10440 pragma Unreferenced
(Any
, Counter
, Rec
);
10441 pragma Warnings
(On
);
10444 if Nkind
(Field
) = N_Defining_Identifier
then
10446 -- A regular component
10448 Add_TypeCode_Parameter
(
10449 Build_TypeCode_Call
(Loc
, Etype
(Field
), Decls
), Params
);
10450 Get_Name_String
(Chars
(Field
));
10451 Add_String_Parameter
(String_From_Name_Buffer
, Params
);
10458 Discriminant_Type
: constant Entity_Id
:=
10459 Etype
(Name
(Field
));
10461 Is_Enum
: constant Boolean :=
10462 Is_Enumeration_Type
(Discriminant_Type
);
10464 Union_TC_Params
: List_Id
;
10466 U_Name
: constant Name_Id
:=
10467 New_External_Name
(Chars
(Typ
), 'V', -1);
10469 Name_Str
: String_Id
;
10470 Struct_TC_Params
: List_Id
;
10474 Default
: constant Node_Id
:=
10475 Make_Integer_Literal
(Loc
, -1);
10477 Dummy_Counter
: Int
:= 0;
10479 Choice_Index
: Int
:= 0;
10481 procedure Add_Params_For_Variant_Components
;
10482 -- Add a struct TypeCode and a corresponding member name
10483 -- to the union parameter list.
10485 -- Ordering of declarations is a complete mess in this
10486 -- area, it is supposed to be types/varibles, then
10487 -- subprogram specs, then subprogram bodies ???
10489 ---------------------------------------
10490 -- Add_Params_For_Variant_Components --
10491 ---------------------------------------
10493 procedure Add_Params_For_Variant_Components
10495 S_Name
: constant Name_Id
:=
10496 New_External_Name
(U_Name
, 'S', -1);
10499 Get_Name_String
(S_Name
);
10500 Name_Str
:= String_From_Name_Buffer
;
10501 Initialize_Parameter_List
10502 (Name_Str
, Name_Str
, Struct_TC_Params
);
10504 -- Build struct parameters
10506 TC_Append_Record_Traversal
(Struct_TC_Params
,
10507 Component_List
(Variant
),
10511 Add_TypeCode_Parameter
10512 (Make_Constructed_TypeCode
10513 (RTE
(RE_TC_Struct
), Struct_TC_Params
),
10516 Add_String_Parameter
(Name_Str
, Union_TC_Params
);
10517 end Add_Params_For_Variant_Components
;
10520 Get_Name_String
(U_Name
);
10521 Name_Str
:= String_From_Name_Buffer
;
10523 Initialize_Parameter_List
10524 (Name_Str
, Name_Str
, Union_TC_Params
);
10526 -- Add union in enclosing parameter list
10528 Add_TypeCode_Parameter
10529 (Make_Constructed_TypeCode
10530 (RTE
(RE_TC_Union
), Union_TC_Params
),
10533 Add_String_Parameter
(Name_Str
, Params
);
10535 -- Build union parameters
10537 Add_TypeCode_Parameter
10538 (Build_TypeCode_Call
10539 (Loc
, Discriminant_Type
, Decls
),
10542 Add_Long_Parameter
(Default
, Union_TC_Params
);
10544 Variant
:= First_Non_Pragma
(Variants
(Field
));
10545 while Present
(Variant
) loop
10546 Choice
:= First
(Discrete_Choices
(Variant
));
10547 while Present
(Choice
) loop
10548 case Nkind
(Choice
) is
10551 L
: constant Uint
:=
10552 Expr_Value
(Low_Bound
(Choice
));
10553 H
: constant Uint
:=
10554 Expr_Value
(High_Bound
(Choice
));
10556 -- 3.8.1(8) guarantees that the bounds of
10557 -- this range are static.
10564 Expr
:= New_Occurrence_Of
(
10565 Get_Enum_Lit_From_Pos
(
10566 Discriminant_Type
, J
, Loc
), Loc
);
10569 Make_Integer_Literal
(Loc
, J
);
10571 Append_To
(Union_TC_Params
,
10572 Build_To_Any_Call
(Expr
, Decls
));
10574 Add_Params_For_Variant_Components
;
10579 when N_Others_Choice
=>
10581 -- This variant possess a default choice.
10582 -- We must therefore set the default
10583 -- parameter to the current choice index. The
10584 -- default parameter is by construction the
10585 -- fourth in the Union_TC_Params list.
10588 Default_Node
: constant Node_Id
:=
10589 Pick
(Union_TC_Params
, 4);
10591 New_Default_Node
: constant Node_Id
:=
10592 Make_Function_Call
(Loc
,
10595 (RTE
(RE_TA_LI
), Loc
),
10596 Parameter_Associations
=>
10598 Make_Integer_Literal
10599 (Loc
, Choice_Index
)));
10605 Remove
(Default_Node
);
10608 -- Add a placeholder member label
10609 -- for the default case.
10610 -- It must be of the discriminant type.
10613 Exp
: constant Node_Id
:=
10614 Make_Attribute_Reference
(Loc
,
10615 Prefix
=> New_Occurrence_Of
10616 (Discriminant_Type
, Loc
),
10617 Attribute_Name
=> Name_First
);
10619 Set_Etype
(Exp
, Discriminant_Type
);
10620 Append_To
(Union_TC_Params
,
10621 Build_To_Any_Call
(Exp
, Decls
));
10624 Add_Params_For_Variant_Components
;
10628 -- Case of an explicit choice
10631 Exp
: constant Node_Id
:=
10632 New_Copy_Tree
(Choice
);
10634 Append_To
(Union_TC_Params
,
10635 Build_To_Any_Call
(Exp
, Decls
));
10638 Add_Params_For_Variant_Components
;
10641 Choice_Index
:= Choice_Index
+ 1;
10645 Next_Non_Pragma
(Variant
);
10650 end TC_Rec_Add_Process_Element
;
10652 Type_Name_Str
: String_Id
;
10653 Type_Repo_Id_Str
: String_Id
;
10656 if Is_Itype
(Typ
) then
10657 Build_TypeCode_Function
10659 Typ
=> Etype
(Typ
),
10668 Make_Function_Specification
(Loc
,
10669 Defining_Unit_Name
=> Fnam
,
10670 Parameter_Specifications
=> Empty_List
,
10671 Result_Definition
=>
10672 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
10674 Build_Name_And_Repository_Id
(Typ
,
10675 Name_Str
=> Type_Name_Str
, Repo_Id_Str
=> Type_Repo_Id_Str
);
10676 Initialize_Parameter_List
10677 (Type_Name_Str
, Type_Repo_Id_Str
, Parameters
);
10679 if Is_Derived_Type
(Typ
)
10680 and then not Is_Tagged_Type
(Typ
)
10682 Return_Alias_TypeCode
(
10683 Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10685 elsif Is_Integer_Type
(Typ
)
10686 or else Is_Unsigned_Type
(Typ
)
10688 Return_Alias_TypeCode
(
10689 Build_TypeCode_Call
(Loc
,
10690 Find_Numeric_Representation
(Typ
), Decls
));
10692 elsif Is_Record_Type
(Typ
)
10693 and then not Is_Tagged_Type
(Typ
)
10696 -- Record typecodes are encoded as follows:
10700 -- | [Repository Id]
10702 -- Then for each discriminant:
10704 -- | [Discriminant Type Code]
10705 -- | [Discriminant Name]
10708 -- Then for each component:
10710 -- | [Component Type Code]
10711 -- | [Component Name]
10714 -- Variants components type codes are encoded as follows:
10718 -- | [Repository Id]
10719 -- | [Discriminant Type Code]
10720 -- | [Index of Default Variant Part or -1 for no default]
10722 -- Then for each Variant Part :
10727 -- | | [Variant Part Name]
10728 -- | | [Variant Part Repository Id]
10730 -- | Then for each VP component:
10731 -- | | [VP component Typecode]
10732 -- | | [VP component Name]
10738 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
10739 Return_Alias_TypeCode
(
10740 Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10743 Disc
: Entity_Id
:= Empty
;
10744 Rdef
: constant Node_Id
:=
10745 Type_Definition
(Declaration_Node
(Typ
));
10746 Dummy_Counter
: Int
:= 0;
10748 -- Construct the discriminants typecodes
10750 if Has_Discriminants
(Typ
) then
10751 Disc
:= First_Discriminant
(Typ
);
10753 while Present
(Disc
) loop
10754 Add_TypeCode_Parameter
(
10755 Build_TypeCode_Call
(Loc
, Etype
(Disc
), Decls
),
10757 Get_Name_String
(Chars
(Disc
));
10758 Add_String_Parameter
(
10759 String_From_Name_Buffer
,
10761 Next_Discriminant
(Disc
);
10764 -- then the components typecodes
10766 TC_Append_Record_Traversal
10767 (Parameters
, Component_List
(Rdef
),
10768 Empty
, Dummy_Counter
);
10769 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10773 elsif Is_Array_Type
(Typ
) then
10775 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10776 Inner_TypeCode
: Node_Id
;
10777 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10778 Indx
: Node_Id
:= First_Index
(Typ
);
10781 Inner_TypeCode
:= Build_TypeCode_Call
(Loc
,
10782 Component_Type
(Typ
),
10785 for J
in 1 .. Ndim
loop
10786 if Constrained
then
10787 Inner_TypeCode
:= Make_Constructed_TypeCode
10788 (RTE
(RE_TC_Array
), New_List
(
10789 Build_To_Any_Call
(
10790 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10791 Make_Attribute_Reference
(Loc
,
10793 New_Occurrence_Of
(Typ
, Loc
),
10796 Expressions
=> New_List
(
10797 Make_Integer_Literal
(Loc
,
10800 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10803 -- Unconstrained case: add low bound for each
10806 Add_TypeCode_Parameter
10807 (Build_TypeCode_Call
(Loc
, Etype
(Indx
), Decls
),
10809 Get_Name_String
(New_External_Name
('L', J
));
10810 Add_String_Parameter
(
10811 String_From_Name_Buffer
,
10815 Inner_TypeCode
:= Make_Constructed_TypeCode
10816 (RTE
(RE_TC_Sequence
), New_List
(
10817 Build_To_Any_Call
(
10818 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10819 Make_Integer_Literal
(Loc
, 0)),
10821 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10825 if Constrained
then
10826 Return_Alias_TypeCode
(Inner_TypeCode
);
10828 Add_TypeCode_Parameter
(Inner_TypeCode
, Parameters
);
10830 Store_String_Char
('V');
10831 Add_String_Parameter
(End_String
, Parameters
);
10832 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10837 -- Default: type is represented as an opaque sequence of bytes
10839 Return_Alias_TypeCode
10840 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10844 Make_Subprogram_Body
(Loc
,
10845 Specification
=> Spec
,
10846 Declarations
=> Decls
,
10847 Handled_Statement_Sequence
=>
10848 Make_Handled_Sequence_Of_Statements
(Loc
,
10849 Statements
=> Stms
));
10850 end Build_TypeCode_Function
;
10852 ---------------------------------
10853 -- Find_Numeric_Representation --
10854 ---------------------------------
10856 function Find_Numeric_Representation
10857 (Typ
: Entity_Id
) return Entity_Id
10859 FST
: constant Entity_Id
:= First_Subtype
(Typ
);
10860 P_Size
: constant Uint
:= Esize
(FST
);
10863 if Is_Unsigned_Type
(Typ
) then
10864 if P_Size
<= Standard_Short_Short_Integer_Size
then
10865 return RTE
(RE_Short_Short_Unsigned
);
10867 elsif P_Size
<= Standard_Short_Integer_Size
then
10868 return RTE
(RE_Short_Unsigned
);
10870 elsif P_Size
<= Standard_Integer_Size
then
10871 return RTE
(RE_Unsigned
);
10873 elsif P_Size
<= Standard_Long_Integer_Size
then
10874 return RTE
(RE_Long_Unsigned
);
10877 return RTE
(RE_Long_Long_Unsigned
);
10880 elsif Is_Integer_Type
(Typ
) then
10881 if P_Size
<= Standard_Short_Short_Integer_Size
then
10882 return Standard_Short_Short_Integer
;
10884 elsif P_Size
<= Standard_Short_Integer_Size
then
10885 return Standard_Short_Integer
;
10887 elsif P_Size
<= Standard_Integer_Size
then
10888 return Standard_Integer
;
10890 elsif P_Size
<= Standard_Long_Integer_Size
then
10891 return Standard_Long_Integer
;
10894 return Standard_Long_Long_Integer
;
10897 elsif Is_Floating_Point_Type
(Typ
) then
10898 if P_Size
<= Standard_Short_Float_Size
then
10899 return Standard_Short_Float
;
10901 elsif P_Size
<= Standard_Float_Size
then
10902 return Standard_Float
;
10904 elsif P_Size
<= Standard_Long_Float_Size
then
10905 return Standard_Long_Float
;
10908 return Standard_Long_Long_Float
;
10912 raise Program_Error
;
10915 -- TBD: fixed point types???
10916 -- TBverified numeric types with a biased representation???
10918 end Find_Numeric_Representation
;
10920 ---------------------------
10921 -- Append_Array_Traversal --
10922 ---------------------------
10924 procedure Append_Array_Traversal
10927 Counter
: Entity_Id
:= Empty
;
10930 Loc
: constant Source_Ptr
:= Sloc
(Subprogram
);
10931 Typ
: constant Entity_Id
:= Etype
(Arry
);
10932 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10933 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10935 Inner_Any
, Inner_Counter
: Entity_Id
;
10937 Loop_Stm
: Node_Id
;
10938 Inner_Stmts
: constant List_Id
:= New_List
;
10941 if Depth
> Ndim
then
10943 -- Processing for one element of an array
10946 Element_Expr
: constant Node_Id
:=
10947 Make_Indexed_Component
(Loc
,
10948 New_Occurrence_Of
(Arry
, Loc
),
10952 Set_Etype
(Element_Expr
, Component_Type
(Typ
));
10953 Add_Process_Element
(Stmts
,
10955 Counter
=> Counter
,
10956 Datum
=> Element_Expr
);
10962 Append_To
(Indices
,
10963 Make_Identifier
(Loc
, New_External_Name
('L', Depth
)));
10965 if not Constrained
or else Depth
> 1 then
10966 Inner_Any
:= Make_Defining_Identifier
(Loc
,
10967 New_External_Name
('A', Depth
));
10968 Set_Etype
(Inner_Any
, RTE
(RE_Any
));
10970 Inner_Any
:= Empty
;
10973 if Present
(Counter
) then
10974 Inner_Counter
:= Make_Defining_Identifier
(Loc
,
10975 New_External_Name
('J', Depth
));
10977 Inner_Counter
:= Empty
;
10981 Loop_Any
: Node_Id
:= Inner_Any
;
10984 -- For the first dimension of a constrained array, we add
10985 -- elements directly in the corresponding Any; there is no
10986 -- intervening inner Any.
10988 if No
(Loop_Any
) then
10992 Append_Array_Traversal
(Inner_Stmts
,
10994 Counter
=> Inner_Counter
,
10995 Depth
=> Depth
+ 1);
10999 Make_Implicit_Loop_Statement
(Subprogram
,
11000 Iteration_Scheme
=>
11001 Make_Iteration_Scheme
(Loc
,
11002 Loop_Parameter_Specification
=>
11003 Make_Loop_Parameter_Specification
(Loc
,
11004 Defining_Identifier
=>
11005 Make_Defining_Identifier
(Loc
,
11006 Chars
=> New_External_Name
('L', Depth
)),
11008 Discrete_Subtype_Definition
=>
11009 Make_Attribute_Reference
(Loc
,
11010 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
11011 Attribute_Name
=> Name_Range
,
11013 Expressions
=> New_List
(
11014 Make_Integer_Literal
(Loc
, Depth
))))),
11015 Statements
=> Inner_Stmts
);
11018 Decls
: constant List_Id
:= New_List
;
11019 Dimen_Stmts
: constant List_Id
:= New_List
;
11020 Length_Node
: Node_Id
;
11022 Inner_Any_TypeCode
: constant Entity_Id
:=
11023 Make_Defining_Identifier
(Loc
,
11024 New_External_Name
('T', Depth
));
11026 Inner_Any_TypeCode_Expr
: Node_Id
;
11030 if Constrained
then
11031 Inner_Any_TypeCode_Expr
:=
11032 Make_Function_Call
(Loc
,
11034 New_Occurrence_Of
(RTE
(RE_Get_TC
), Loc
),
11035 Parameter_Associations
=> New_List
(
11036 New_Occurrence_Of
(Any
, Loc
)));
11038 Inner_Any_TypeCode_Expr
:=
11039 Make_Function_Call
(Loc
,
11041 New_Occurrence_Of
(RTE
(RE_Any_Member_Type
), Loc
),
11042 Parameter_Associations
=> New_List
(
11043 New_Occurrence_Of
(Any
, Loc
),
11044 Make_Integer_Literal
(Loc
, Ndim
)));
11047 Inner_Any_TypeCode_Expr
:=
11048 Make_Function_Call
(Loc
,
11050 New_Occurrence_Of
(RTE
(RE_Content_Type
), Loc
),
11051 Parameter_Associations
=> New_List
(
11052 Make_Identifier
(Loc
,
11053 New_External_Name
('T', Depth
- 1))));
11057 Make_Object_Declaration
(Loc
,
11058 Defining_Identifier
=> Inner_Any_TypeCode
,
11059 Constant_Present
=> True,
11060 Object_Definition
=> New_Occurrence_Of
(
11061 RTE
(RE_TypeCode
), Loc
),
11062 Expression
=> Inner_Any_TypeCode_Expr
));
11064 if Present
(Inner_Any
) then
11066 Make_Object_Declaration
(Loc
,
11067 Defining_Identifier
=> Inner_Any
,
11068 Object_Definition
=>
11069 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
11071 Make_Function_Call
(Loc
,
11073 New_Occurrence_Of
(
11074 RTE
(RE_Create_Any
), Loc
),
11075 Parameter_Associations
=> New_List
(
11076 New_Occurrence_Of
(Inner_Any_TypeCode
, Loc
)))));
11079 if Present
(Inner_Counter
) then
11081 Make_Object_Declaration
(Loc
,
11082 Defining_Identifier
=> Inner_Counter
,
11083 Object_Definition
=>
11084 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
11086 Make_Integer_Literal
(Loc
, 0)));
11089 if not Constrained
then
11090 Length_Node
:= Make_Attribute_Reference
(Loc
,
11091 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
11092 Attribute_Name
=> Name_Length
,
11094 New_List
(Make_Integer_Literal
(Loc
, Depth
)));
11095 Set_Etype
(Length_Node
, RTE
(RE_Long_Unsigned
));
11097 Add_Process_Element
(Dimen_Stmts
,
11098 Datum
=> Length_Node
,
11100 Counter
=> Inner_Counter
);
11103 -- Loop_Stm does appropriate processing for each element
11106 Append_To
(Dimen_Stmts
, Loop_Stm
);
11108 -- Link outer and inner any
11110 if Present
(Inner_Any
) then
11111 Add_Process_Element
(Dimen_Stmts
,
11113 Counter
=> Counter
,
11114 Datum
=> New_Occurrence_Of
(Inner_Any
, Loc
));
11118 Make_Block_Statement
(Loc
,
11121 Handled_Statement_Sequence
=>
11122 Make_Handled_Sequence_Of_Statements
(Loc
,
11123 Statements
=> Dimen_Stmts
)));
11125 end Append_Array_Traversal
;
11127 -----------------------------------------
11128 -- Make_Stream_Procedure_Function_Name --
11129 -----------------------------------------
11131 function Make_Stream_Procedure_Function_Name
11134 Nam
: Name_Id
) return Entity_Id
11137 -- For tagged types, we use a canonical name so that it matches
11138 -- the primitive spec. For all other cases, we use a serialized
11139 -- name so that multiple generations of the same procedure do not
11142 if Is_Tagged_Type
(Typ
) then
11143 return Make_Defining_Identifier
(Loc
, Nam
);
11145 return Make_Defining_Identifier
(Loc
,
11147 New_External_Name
(Nam
, ' ', Increment_Serial_Number
));
11149 end Make_Stream_Procedure_Function_Name
;
11152 -----------------------------------
11153 -- Reserve_NamingContext_Methods --
11154 -----------------------------------
11156 procedure Reserve_NamingContext_Methods
is
11157 Str_Resolve
: constant String := "resolve";
11159 Name_Buffer
(1 .. Str_Resolve
'Length) := Str_Resolve
;
11160 Name_Len
:= Str_Resolve
'Length;
11161 Overload_Counter_Table
.Set
(Name_Find
, 1);
11162 end Reserve_NamingContext_Methods
;
11164 end PolyORB_Support
;
11166 -------------------------------
11167 -- RACW_Type_Is_Asynchronous --
11168 -------------------------------
11170 procedure RACW_Type_Is_Asynchronous
(RACW_Type
: Entity_Id
) is
11171 Asynchronous_Flag
: constant Entity_Id
:=
11172 Asynchronous_Flags_Table
.Get
(RACW_Type
);
11174 Replace
(Expression
(Parent
(Asynchronous_Flag
)),
11175 New_Occurrence_Of
(Standard_True
, Sloc
(Asynchronous_Flag
)));
11176 end RACW_Type_Is_Asynchronous
;
11178 -------------------------
11179 -- RCI_Package_Locator --
11180 -------------------------
11182 function RCI_Package_Locator
11184 Package_Spec
: Node_Id
) return Node_Id
11187 Pkg_Name
: String_Id
;
11190 Get_Library_Unit_Name_String
(Package_Spec
);
11191 Pkg_Name
:= String_From_Name_Buffer
;
11193 Make_Package_Instantiation
(Loc
,
11194 Defining_Unit_Name
=>
11195 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
11197 New_Occurrence_Of
(RTE
(RE_RCI_Locator
), Loc
),
11198 Generic_Associations
=> New_List
(
11199 Make_Generic_Association
(Loc
,
11201 Make_Identifier
(Loc
, Name_RCI_Name
),
11202 Explicit_Generic_Actual_Parameter
=>
11203 Make_String_Literal
(Loc
,
11204 Strval
=> Pkg_Name
)),
11205 Make_Generic_Association
(Loc
,
11207 Make_Identifier
(Loc
, Name_Version
),
11208 Explicit_Generic_Actual_Parameter
=>
11209 Make_Attribute_Reference
(Loc
,
11211 New_Occurrence_Of
(Defining_Entity
(Package_Spec
), Loc
),
11215 RCI_Locator_Table
.Set
(Defining_Unit_Name
(Package_Spec
),
11216 Defining_Unit_Name
(Inst
));
11218 end RCI_Package_Locator
;
11220 -----------------------------------------------
11221 -- Remote_Types_Tagged_Full_View_Encountered --
11222 -----------------------------------------------
11224 procedure Remote_Types_Tagged_Full_View_Encountered
11225 (Full_View
: Entity_Id
)
11227 Stub_Elements
: constant Stub_Structure
:=
11228 Stubs_Table
.Get
(Full_View
);
11230 if Stub_Elements
/= Empty_Stub_Structure
then
11231 Add_RACW_Primitive_Declarations_And_Bodies
11233 Stub_Elements
.RPC_Receiver_Decl
,
11234 Stub_Elements
.Body_Decls
);
11236 end Remote_Types_Tagged_Full_View_Encountered
;
11238 -------------------
11239 -- Scope_Of_Spec --
11240 -------------------
11242 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
is
11243 Unit_Name
: Node_Id
;
11246 Unit_Name
:= Defining_Unit_Name
(Spec
);
11247 while Nkind
(Unit_Name
) /= N_Defining_Identifier
loop
11248 Unit_Name
:= Defining_Identifier
(Unit_Name
);
11254 ----------------------
11255 -- Set_Renaming_TSS --
11256 ----------------------
11258 procedure Set_Renaming_TSS
11261 TSS_Nam
: TSS_Name_Type
)
11263 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
11264 Spec
: constant Node_Id
:= Parent
(Nam
);
11266 TSS_Node
: constant Node_Id
:=
11267 Make_Subprogram_Renaming_Declaration
(Loc
,
11269 Copy_Specification
(Loc
,
11271 New_Name
=> Make_TSS_Name
(Typ
, TSS_Nam
)),
11272 Name
=> New_Occurrence_Of
(Nam
, Loc
));
11274 Snam
: constant Entity_Id
:=
11275 Defining_Unit_Name
(Specification
(TSS_Node
));
11278 if Nkind
(Spec
) = N_Function_Specification
then
11279 Set_Ekind
(Snam
, E_Function
);
11280 Set_Etype
(Snam
, Entity
(Result_Definition
(Spec
)));
11282 Set_Ekind
(Snam
, E_Procedure
);
11283 Set_Etype
(Snam
, Standard_Void_Type
);
11286 Set_TSS
(Typ
, Snam
);
11287 end Set_Renaming_TSS
;
11289 ----------------------------------------------
11290 -- Specific_Add_Obj_RPC_Receiver_Completion --
11291 ----------------------------------------------
11293 procedure Specific_Add_Obj_RPC_Receiver_Completion
11296 RPC_Receiver
: Entity_Id
;
11297 Stub_Elements
: Stub_Structure
) is
11299 case Get_PCS_Name
is
11300 when Name_PolyORB_DSA
=>
11301 PolyORB_Support
.Add_Obj_RPC_Receiver_Completion
(Loc
,
11302 Decls
, RPC_Receiver
, Stub_Elements
);
11304 GARLIC_Support
.Add_Obj_RPC_Receiver_Completion
(Loc
,
11305 Decls
, RPC_Receiver
, Stub_Elements
);
11307 end Specific_Add_Obj_RPC_Receiver_Completion
;
11309 --------------------------------
11310 -- Specific_Add_RACW_Features --
11311 --------------------------------
11313 procedure Specific_Add_RACW_Features
11314 (RACW_Type
: Entity_Id
;
11316 Stub_Type
: Entity_Id
;
11317 Stub_Type_Access
: Entity_Id
;
11318 RPC_Receiver_Decl
: Node_Id
;
11319 Body_Decls
: List_Id
) is
11321 case Get_PCS_Name
is
11322 when Name_PolyORB_DSA
=>
11323 PolyORB_Support
.Add_RACW_Features
(
11332 GARLIC_Support
.Add_RACW_Features
(
11339 end Specific_Add_RACW_Features
;
11341 --------------------------------
11342 -- Specific_Add_RAST_Features --
11343 --------------------------------
11345 procedure Specific_Add_RAST_Features
11346 (Vis_Decl
: Node_Id
;
11347 RAS_Type
: Entity_Id
) is
11349 case Get_PCS_Name
is
11350 when Name_PolyORB_DSA
=>
11351 PolyORB_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
11353 GARLIC_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
11355 end Specific_Add_RAST_Features
;
11357 --------------------------------------------------
11358 -- Specific_Add_Receiving_Stubs_To_Declarations --
11359 --------------------------------------------------
11361 procedure Specific_Add_Receiving_Stubs_To_Declarations
11362 (Pkg_Spec
: Node_Id
;
11367 case Get_PCS_Name
is
11368 when Name_PolyORB_DSA
=>
11369 PolyORB_Support
.Add_Receiving_Stubs_To_Declarations
(
11370 Pkg_Spec
, Decls
, Stmts
);
11372 GARLIC_Support
.Add_Receiving_Stubs_To_Declarations
(
11373 Pkg_Spec
, Decls
, Stmts
);
11375 end Specific_Add_Receiving_Stubs_To_Declarations
;
11377 ------------------------------------------
11378 -- Specific_Build_General_Calling_Stubs --
11379 ------------------------------------------
11381 procedure Specific_Build_General_Calling_Stubs
11383 Statements
: List_Id
;
11384 Target
: RPC_Target
;
11385 Subprogram_Id
: Node_Id
;
11386 Asynchronous
: Node_Id
:= Empty
;
11387 Is_Known_Asynchronous
: Boolean := False;
11388 Is_Known_Non_Asynchronous
: Boolean := False;
11389 Is_Function
: Boolean;
11391 Stub_Type
: Entity_Id
:= Empty
;
11392 RACW_Type
: Entity_Id
:= Empty
;
11396 case Get_PCS_Name
is
11397 when Name_PolyORB_DSA
=>
11398 PolyORB_Support
.Build_General_Calling_Stubs
(
11404 Is_Known_Asynchronous
,
11405 Is_Known_Non_Asynchronous
,
11412 GARLIC_Support
.Build_General_Calling_Stubs
(
11416 Target
.RPC_Receiver
,
11419 Is_Known_Asynchronous
,
11420 Is_Known_Non_Asynchronous
,
11427 end Specific_Build_General_Calling_Stubs
;
11429 --------------------------------------
11430 -- Specific_Build_RPC_Receiver_Body --
11431 --------------------------------------
11433 procedure Specific_Build_RPC_Receiver_Body
11434 (RPC_Receiver
: Entity_Id
;
11435 Request
: out Entity_Id
;
11436 Subp_Id
: out Entity_Id
;
11437 Subp_Index
: out Entity_Id
;
11438 Stmts
: out List_Id
;
11439 Decl
: out Node_Id
)
11442 case Get_PCS_Name
is
11443 when Name_PolyORB_DSA
=>
11444 PolyORB_Support
.Build_RPC_Receiver_Body
11452 GARLIC_Support
.Build_RPC_Receiver_Body
11460 end Specific_Build_RPC_Receiver_Body
;
11462 --------------------------------
11463 -- Specific_Build_Stub_Target --
11464 --------------------------------
11466 function Specific_Build_Stub_Target
11469 RCI_Locator
: Entity_Id
;
11470 Controlling_Parameter
: Entity_Id
) return RPC_Target
11473 case Get_PCS_Name
is
11474 when Name_PolyORB_DSA
=>
11475 return PolyORB_Support
.Build_Stub_Target
(Loc
,
11476 Decls
, RCI_Locator
, Controlling_Parameter
);
11478 return GARLIC_Support
.Build_Stub_Target
(Loc
,
11479 Decls
, RCI_Locator
, Controlling_Parameter
);
11481 end Specific_Build_Stub_Target
;
11483 ------------------------------
11484 -- Specific_Build_Stub_Type --
11485 ------------------------------
11487 procedure Specific_Build_Stub_Type
11488 (RACW_Type
: Entity_Id
;
11489 Stub_Type
: Entity_Id
;
11490 Stub_Type_Decl
: out Node_Id
;
11491 RPC_Receiver_Decl
: out Node_Id
)
11494 case Get_PCS_Name
is
11495 when Name_PolyORB_DSA
=>
11496 PolyORB_Support
.Build_Stub_Type
(
11497 RACW_Type
, Stub_Type
,
11498 Stub_Type_Decl
, RPC_Receiver_Decl
);
11500 GARLIC_Support
.Build_Stub_Type
(
11501 RACW_Type
, Stub_Type
,
11502 Stub_Type_Decl
, RPC_Receiver_Decl
);
11504 end Specific_Build_Stub_Type
;
11506 function Specific_Build_Subprogram_Receiving_Stubs
11507 (Vis_Decl
: Node_Id
;
11508 Asynchronous
: Boolean;
11509 Dynamically_Asynchronous
: Boolean := False;
11510 Stub_Type
: Entity_Id
:= Empty
;
11511 RACW_Type
: Entity_Id
:= Empty
;
11512 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
11515 case Get_PCS_Name
is
11516 when Name_PolyORB_DSA
=>
11517 return PolyORB_Support
.Build_Subprogram_Receiving_Stubs
(
11520 Dynamically_Asynchronous
,
11525 return GARLIC_Support
.Build_Subprogram_Receiving_Stubs
(
11528 Dynamically_Asynchronous
,
11533 end Specific_Build_Subprogram_Receiving_Stubs
;
11535 --------------------------
11536 -- Underlying_RACW_Type --
11537 --------------------------
11539 function Underlying_RACW_Type
(RAS_Typ
: Entity_Id
) return Entity_Id
is
11540 Record_Type
: Entity_Id
;
11543 if Ekind
(RAS_Typ
) = E_Record_Type
then
11544 Record_Type
:= RAS_Typ
;
11546 pragma Assert
(Present
(Equivalent_Type
(RAS_Typ
)));
11547 Record_Type
:= Equivalent_Type
(RAS_Typ
);
11551 Etype
(Subtype_Indication
(
11552 Component_Definition
(
11553 First
(Component_Items
(Component_List
(
11554 Type_Definition
(Declaration_Node
(Record_Type
))))))));
11555 end Underlying_RACW_Type
;