1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Einfo
; use Einfo
;
29 with Elists
; use Elists
;
30 with Exp_Strm
; use Exp_Strm
;
31 with Exp_Tss
; use Exp_Tss
;
32 with Exp_Util
; use Exp_Util
;
33 with GNAT
.HTable
; use GNAT
.HTable
;
35 with Namet
; use Namet
;
36 with Nlists
; use Nlists
;
37 with Nmake
; use Nmake
;
39 with Rtsfind
; use Rtsfind
;
41 with Sem_Ch3
; use Sem_Ch3
;
42 with Sem_Ch8
; use Sem_Ch8
;
43 with Sem_Dist
; use Sem_Dist
;
44 with Sem_Eval
; use Sem_Eval
;
45 with Sem_Util
; use Sem_Util
;
46 with Sinfo
; use Sinfo
;
47 with Snames
; use Snames
;
48 with Stand
; use Stand
;
49 with Stringt
; use Stringt
;
50 with Tbuild
; use Tbuild
;
51 with Ttypes
; use Ttypes
;
52 with Uintp
; use Uintp
;
54 package body Exp_Dist
is
56 -- The following model has been used to implement distributed objects:
57 -- given a designated type D and a RACW type R, then a record of the
60 -- type Stub is tagged record
61 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
64 -- is built. This type has two properties:
66 -- 1) Since it has the same structure than RACW_Stub_Type, it can be
67 -- converted to and from this type to make it suitable for
68 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
69 -- to avoid memory leaks when the same remote object arrive on the
70 -- same partition through several paths;
72 -- 2) It also has the same dispatching table as the designated type D,
73 -- and thus can be used as an object designated by a value of type
74 -- R on any partition other than the one on which the object has
75 -- been created, since only dispatching calls will be performed and
76 -- the fields themselves will not be used. We call Derive_Subprograms
77 -- to fake half a derivation to ensure that the subprograms do have
78 -- the same dispatching table.
80 First_RCI_Subprogram_Id
: constant := 2;
81 -- RCI subprograms are numbered starting at 2. The RCI receiver for
82 -- an RCI package can thus identify calls received through remote
83 -- access-to-subprogram dereferences by the fact that they have a
84 -- (primitive) subprogram id of 0, and 1 is used for the internal
85 -- RAS information lookup operation. (This is for the Garlic code
86 -- generation, where subprograms are identified by numbers; in the
87 -- PolyORB version, they are identified by name, with a numeric suffix
90 type Hash_Index
is range 0 .. 50;
92 -----------------------
93 -- Local subprograms --
94 -----------------------
96 function Hash
(F
: Entity_Id
) return Hash_Index
;
97 -- DSA expansion associates stubs to distributed object types using
98 -- a hash table on entity ids.
100 function Hash
(F
: Name_Id
) return Hash_Index
;
101 -- The generation of subprogram identifiers requires an overload counter
102 -- to be associated with each remote subprogram names. These counters
103 -- are maintained in a hash table on name ids.
105 type Subprogram_Identifiers
is record
106 Str_Identifier
: String_Id
;
107 Int_Identifier
: Int
;
110 package Subprogram_Identifier_Table
is
111 new Simple_HTable
(Header_Num
=> Hash_Index
,
112 Element
=> Subprogram_Identifiers
,
113 No_Element
=> (No_String
, 0),
117 -- Mapping between a remote subprogram and the corresponding
118 -- subprogram identifiers.
120 package Overload_Counter_Table
is
121 new Simple_HTable
(Header_Num
=> Hash_Index
,
127 -- Mapping between a subprogram name and an integer that
128 -- counts the number of defining subprogram names with that
129 -- Name_Id encountered so far in a given context (an interface).
131 function Get_Subprogram_Ids
(Def
: Entity_Id
) return Subprogram_Identifiers
;
132 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
;
133 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
;
134 -- Given a subprogram defined in a RCI package, get its distribution
135 -- subprogram identifiers (the distribution identifiers are a unique
136 -- subprogram number, and the non-qualified subprogram name, in the
137 -- casing used for the subprogram declaration; if the name is overloaded,
138 -- a double underscore and a serial number are appended.
140 -- The integer identifier is used to perform remote calls with GARLIC;
141 -- the string identifier is used in the case of PolyORB.
143 -- Although the PolyORB DSA receiving stubs will make a caseless comparison
144 -- when receiving a call, the calling stubs will create requests with the
145 -- exact casing of the defining unit name of the called subprogram, so as
146 -- to allow calls to subprograms on distributed nodes that do distinguish
149 -- NOTE: Another design would be to allow a representation clause on
150 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
152 pragma Warnings
(Off
, Get_Subprogram_Id
);
153 -- One homonym only is unreferenced (specific to the GARLIC version)
155 procedure Add_RAS_Dereference_TSS
(N
: Node_Id
);
156 -- Add a subprogram body for RAS Dereference TSS
158 procedure Add_RAS_Proxy_And_Analyze
161 All_Calls_Remote_E
: Entity_Id
;
162 Proxy_Object_Addr
: out Entity_Id
);
163 -- Add the proxy type necessary to call the subprogram declared
164 -- by Vis_Decl through a remote access to subprogram type.
165 -- All_Calls_Remote_E must be Standard_True if a pragma All_Calls_Remote
166 -- applies, Standard_False otherwise. The new proxy type is appended
167 -- to Decls. Proxy_Object_Addr is a constant of type System.Address that
168 -- designates an instance of the proxy object.
170 function Build_Remote_Subprogram_Proxy_Type
172 ACR_Expression
: Node_Id
) return Node_Id
;
173 -- Build and return a tagged record type definition for an RCI
174 -- subprogram proxy type.
175 -- ACR_Expression is use as the initialization value for
176 -- the All_Calls_Remote component.
178 function Build_Get_Unique_RP_Call
181 Stub_Type
: Entity_Id
) return List_Id
;
182 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
183 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
184 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
186 function Build_Subprogram_Calling_Stubs
189 Asynchronous
: Boolean;
190 Dynamically_Asynchronous
: Boolean := False;
191 Stub_Type
: Entity_Id
:= Empty
;
192 RACW_Type
: Entity_Id
:= Empty
;
193 Locator
: Entity_Id
:= Empty
;
194 New_Name
: Name_Id
:= No_Name
) return Node_Id
;
195 -- Build the calling stub for a given subprogram with the subprogram ID
196 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
197 -- parameters of this type will be marshalled instead of the object
198 -- itself. It will then be converted into Stub_Type before performing
199 -- the real call. If Dynamically_Asynchronous is True, then it will be
200 -- computed at run time whether the call is asynchronous or not.
201 -- Otherwise, the value of the formal Asynchronous will be used.
202 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
203 -- New_Name is given, then it will be used instead of the original name.
205 function Build_RPC_Receiver_Specification
206 (RPC_Receiver
: Entity_Id
;
207 Request_Parameter
: Entity_Id
) return Node_Id
;
208 -- Make a subprogram specification for an RPC receiver, with the given
209 -- defining unit name and formal parameter.
211 function Build_Ordered_Parameters_List
(Spec
: Node_Id
) return List_Id
;
212 -- Return an ordered parameter list: unconstrained parameters are put
213 -- at the beginning of the list and constrained ones are put after. If
214 -- there are no parameters, an empty list is returned. Special case:
215 -- the controlling formal of the equivalent RACW operation for a RAS
216 -- type is always left in first position.
218 procedure Add_Calling_Stubs_To_Declarations
221 -- Add calling stubs to the declarative part
223 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean;
224 -- Return True if nothing prevents the program whose specification is
225 -- given to be asynchronous (i.e. no out parameter).
227 function Pack_Entity_Into_Stream_Access
231 Etyp
: Entity_Id
:= Empty
) return Node_Id
;
232 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
233 -- then Etype (Object) will be used if present. If the type is
234 -- constrained, then 'Write will be used to output the object,
235 -- If the type is unconstrained, 'Output will be used.
237 function Pack_Node_Into_Stream
241 Etyp
: Entity_Id
) return Node_Id
;
242 -- Similar to above, with an arbitrary node instead of an entity
244 function Pack_Node_Into_Stream_Access
248 Etyp
: Entity_Id
) return Node_Id
;
249 -- Similar to above, with Stream instead of Stream'Access
251 function Make_Selected_Component
254 Selector_Name
: Name_Id
) return Node_Id
;
255 -- Return a selected_component whose prefix denotes the given entity,
256 -- and with the given Selector_Name.
258 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
;
259 -- Return the scope represented by a given spec
261 procedure Set_Renaming_TSS
264 TSS_Nam
: TSS_Name_Type
);
265 -- Create a renaming declaration of subprogram Nam,
266 -- and register it as a TSS for Typ with name TSS_Nam.
268 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean;
269 -- Return True if the current parameter needs an extra formal to reflect
270 -- its constrained status.
272 function Is_RACW_Controlling_Formal
273 (Parameter
: Node_Id
; Stub_Type
: Entity_Id
) return Boolean;
274 -- Return True if the current parameter is a controlling formal argument
275 -- of type Stub_Type or access to Stub_Type.
277 procedure Declare_Create_NVList
282 -- Append the declaration of NVList to Decls, and its
283 -- initialization to Stmts.
285 function Add_Parameter_To_NVList
288 Parameter
: Entity_Id
;
289 Constrained
: Boolean;
290 RACW_Ctrl
: Boolean := False;
291 Any
: Entity_Id
) return Node_Id
;
292 -- Return a call to Add_Item to add the Any corresponding
293 -- to the designated formal Parameter (with the indicated
294 -- Constrained status) to NVList. RACW_Ctrl must be set to
295 -- True for controlling formals of distributed object primitive
298 type Stub_Structure
is record
299 Stub_Type
: Entity_Id
;
300 Stub_Type_Access
: Entity_Id
;
301 RPC_Receiver_Decl
: Node_Id
;
302 RACW_Type
: Entity_Id
;
304 -- This structure is necessary because of the two phases analysis of
305 -- a RACW declaration occurring in the same Remote_Types package as the
306 -- designated type. RACW_Type is any of the RACW types pointing on this
307 -- designated type, it is used here to save an anonymous type creation
308 -- for each primitive operation.
310 -- For a RACW that implements a RAS, no object RPC receiver is generated.
311 -- Instead, RPC_Receiver_Decl is the declaration after which the
312 -- RPC receiver would have been inserted.
314 Empty_Stub_Structure
: constant Stub_Structure
:=
315 (Empty
, Empty
, Empty
, Empty
);
317 package Stubs_Table
is
318 new Simple_HTable
(Header_Num
=> Hash_Index
,
319 Element
=> Stub_Structure
,
320 No_Element
=> Empty_Stub_Structure
,
324 -- Mapping between a RACW designated type and its stub type
326 package Asynchronous_Flags_Table
is
327 new Simple_HTable
(Header_Num
=> Hash_Index
,
328 Element
=> Entity_Id
,
333 -- Mapping between a RACW type and a constant having the value True
334 -- if the RACW is asynchronous and False otherwise.
336 package RCI_Locator_Table
is
337 new Simple_HTable
(Header_Num
=> Hash_Index
,
338 Element
=> Entity_Id
,
343 -- Mapping between a RCI package on which All_Calls_Remote applies and
344 -- the generic instantiation of RCI_Locator for this package.
346 package RCI_Calling_Stubs_Table
is
347 new Simple_HTable
(Header_Num
=> Hash_Index
,
348 Element
=> Entity_Id
,
353 -- Mapping between a RCI subprogram and the corresponding calling stubs
355 procedure Add_Stub_Type
356 (Designated_Type
: Entity_Id
;
357 RACW_Type
: Entity_Id
;
359 Stub_Type
: out Entity_Id
;
360 Stub_Type_Access
: out Entity_Id
;
361 RPC_Receiver_Decl
: out Node_Id
;
362 Existing
: out Boolean);
363 -- Add the declaration of the stub type, the access to stub type and the
364 -- object RPC receiver at the end of Decls. If these already exist,
365 -- then nothing is added in the tree but the right values are returned
366 -- anyhow and Existing is set to True.
368 procedure Add_RACW_Asynchronous_Flag
369 (Declarations
: List_Id
;
370 RACW_Type
: Entity_Id
);
371 -- Declare a boolean constant associated with RACW_Type whose value
372 -- indicates at run time whether a pragma Asynchronous applies to it.
374 procedure Assign_Subprogram_Identifier
378 -- Determine the distribution subprogram identifier to
379 -- be used for remote subprogram Def, return it in Id and
380 -- store it in a hash table for later retrieval by
381 -- Get_Subprogram_Id. Spn is the subprogram number.
383 function RCI_Package_Locator
385 Package_Spec
: Node_Id
) return Node_Id
;
386 -- Instantiate the generic package RCI_Locator in order to locate the
387 -- RCI package whose spec is given as argument.
389 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
;
390 -- Surround a node N by a tag check, as in:
394 -- when E : Ada.Tags.Tag_Error =>
395 -- Raise_Exception (Program_Error'Identity,
396 -- Exception_Message (E));
399 function Input_With_Tag_Check
401 Var_Type
: Entity_Id
;
402 Stream
: Node_Id
) return Node_Id
;
403 -- Return a function with the following form:
404 -- function R return Var_Type is
406 -- return Var_Type'Input (S);
408 -- when E : Ada.Tags.Tag_Error =>
409 -- Raise_Exception (Program_Error'Identity,
410 -- Exception_Message (E));
413 --------------------------------------------
414 -- Hooks for PCS-specific code generation --
415 --------------------------------------------
417 -- Part of the code generation circuitry for distribution needs to be
418 -- tailored for each implementation of the PCS. For each routine that
419 -- needs to be specialized, a Specific_<routine> wrapper is created,
420 -- which calls the corresponding <routine> in package
421 -- <pcs_implementation>_Support.
423 procedure Specific_Add_RACW_Features
424 (RACW_Type
: Entity_Id
;
426 Stub_Type
: Entity_Id
;
427 Stub_Type_Access
: Entity_Id
;
428 RPC_Receiver_Decl
: Node_Id
;
429 Declarations
: List_Id
);
430 -- Add declaration for TSSs for a given RACW type. The declarations are
431 -- added just after the declaration of the RACW type itself, while the
432 -- bodies are inserted at the end of Decls. Runtime-specific ancillary
433 -- subprogram for Add_RACW_Features.
435 procedure Specific_Add_RAST_Features
437 RAS_Type
: Entity_Id
);
438 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
439 -- subprogram for Add_RAST_Features.
441 -- An RPC_Target record is used during construction of calling stubs
442 -- to pass PCS-specific tree fragments corresponding to the information
443 -- necessary to locate the target of a remote subprogram call.
445 type RPC_Target
(PCS_Kind
: PCS_Names
) is record
447 when Name_PolyORB_DSA
=>
449 -- An expression whose value is a PolyORB reference to the target
452 Partition
: Entity_Id
;
453 -- A variable containing the Partition_ID of the target parition
455 RPC_Receiver
: Node_Id
;
456 -- An expression whose value is the address of the target RPC
461 procedure Specific_Build_General_Calling_Stubs
463 Statements
: List_Id
;
465 Subprogram_Id
: Node_Id
;
466 Asynchronous
: Node_Id
:= Empty
;
467 Is_Known_Asynchronous
: Boolean := False;
468 Is_Known_Non_Asynchronous
: Boolean := False;
469 Is_Function
: Boolean;
471 Stub_Type
: Entity_Id
:= Empty
;
472 RACW_Type
: Entity_Id
:= Empty
;
474 -- Build calling stubs for general purpose. The parameters are:
475 -- Decls : a place to put declarations
476 -- Statements : a place to put statements
477 -- Target : PCS-specific target information (see details
478 -- in RPC_Target declaration).
479 -- Subprogram_Id : a node containing the subprogram ID
480 -- Asynchronous : True if an APC must be made instead of an RPC.
481 -- The value needs not be supplied if one of the
482 -- Is_Known_... is True.
483 -- Is_Known_Async... : True if we know that this is asynchronous
484 -- Is_Known_Non_A... : True if we know that this is not asynchronous
485 -- Spec : a node with a Parameter_Specifications and
486 -- a Result_Definition if applicable
487 -- Stub_Type : in case of RACW stubs, parameters of type access
488 -- to Stub_Type will be marshalled using the
489 -- address of the object (the addr field) rather
490 -- than using the 'Write on the stub itself
491 -- Nod : used to provide sloc for generated code
493 function Specific_Build_Stub_Target
496 RCI_Locator
: Entity_Id
;
497 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
498 -- Build call target information nodes for use within calling stubs. In the
499 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
500 -- for an RACW, Controlling_Parameter is the entity for the controlling
501 -- formal parameter used to determine the location of the target of the
502 -- call. Decls provides a location where variable declarations can be
503 -- appended to construct the necessary values.
505 procedure Specific_Build_Stub_Type
506 (RACW_Type
: Entity_Id
;
507 Stub_Type
: Entity_Id
;
508 Stub_Type_Decl
: out Node_Id
;
509 RPC_Receiver_Decl
: out Node_Id
);
510 -- Build a type declaration for the stub type associated with an RACW
511 -- type, and the necessary RPC receiver, if applicable. PCS-specific
512 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
513 -- is generated, then RPC_Receiver_Decl is set to Empty.
515 procedure Specific_Build_RPC_Receiver_Body
516 (RPC_Receiver
: Entity_Id
;
517 Request
: out Entity_Id
;
518 Subp_Id
: out Entity_Id
;
519 Subp_Index
: out Entity_Id
;
522 -- Make a subprogram body for an RPC receiver, with the given
523 -- defining unit name. On return:
524 -- - Subp_Id is the subprogram identifier from the PCS.
525 -- - Subp_Index is the index in the list of subprograms
526 -- used for dispatching (a variable of type Subprogram_Id).
527 -- - Stmts is the place where the request dispatching
528 -- statements can occur,
529 -- - Decl is the subprogram body declaration.
531 function Specific_Build_Subprogram_Receiving_Stubs
533 Asynchronous
: Boolean;
534 Dynamically_Asynchronous
: Boolean := False;
535 Stub_Type
: Entity_Id
:= Empty
;
536 RACW_Type
: Entity_Id
:= Empty
;
537 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
538 -- Build the receiving stub for a given subprogram. The subprogram
539 -- declaration is also built by this procedure, and the value returned
540 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
541 -- found in the specification, then its address is read from the stream
542 -- instead of the object itself and converted into an access to
543 -- class-wide type before doing the real call using any of the RACW type
544 -- pointing on the designated type.
546 procedure Specific_Add_Obj_RPC_Receiver_Completion
549 RPC_Receiver
: Entity_Id
;
550 Stub_Elements
: Stub_Structure
);
551 -- Add the necessary code to Decls after the completion of generation
552 -- of the RACW RPC receiver described by Stub_Elements.
554 procedure Specific_Add_Receiving_Stubs_To_Declarations
557 -- Add receiving stubs to the declarative part of an RCI unit
559 package GARLIC_Support
is
561 -- Support for generating DSA code that uses the GARLIC PCS
563 -- The subprograms below provide the GARLIC versions of
564 -- the corresponding Specific_<subprogram> routine declared
567 procedure Add_RACW_Features
568 (RACW_Type
: Entity_Id
;
569 Stub_Type
: Entity_Id
;
570 Stub_Type_Access
: Entity_Id
;
571 RPC_Receiver_Decl
: Node_Id
;
572 Declarations
: List_Id
);
574 procedure Add_RAST_Features
576 RAS_Type
: Entity_Id
);
578 procedure Build_General_Calling_Stubs
580 Statements
: List_Id
;
581 Target_Partition
: Entity_Id
; -- From RPC_Target
582 Target_RPC_Receiver
: Node_Id
; -- From RPC_Target
583 Subprogram_Id
: Node_Id
;
584 Asynchronous
: Node_Id
:= Empty
;
585 Is_Known_Asynchronous
: Boolean := False;
586 Is_Known_Non_Asynchronous
: Boolean := False;
587 Is_Function
: Boolean;
589 Stub_Type
: Entity_Id
:= Empty
;
590 RACW_Type
: Entity_Id
:= Empty
;
593 function Build_Stub_Target
596 RCI_Locator
: Entity_Id
;
597 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
599 procedure Build_Stub_Type
600 (RACW_Type
: Entity_Id
;
601 Stub_Type
: Entity_Id
;
602 Stub_Type_Decl
: out Node_Id
;
603 RPC_Receiver_Decl
: out Node_Id
);
605 function Build_Subprogram_Receiving_Stubs
607 Asynchronous
: Boolean;
608 Dynamically_Asynchronous
: Boolean := False;
609 Stub_Type
: Entity_Id
:= Empty
;
610 RACW_Type
: Entity_Id
:= Empty
;
611 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
613 procedure Add_Obj_RPC_Receiver_Completion
616 RPC_Receiver
: Entity_Id
;
617 Stub_Elements
: Stub_Structure
);
619 procedure Add_Receiving_Stubs_To_Declarations
623 procedure Build_RPC_Receiver_Body
624 (RPC_Receiver
: Entity_Id
;
625 Request
: out Entity_Id
;
626 Subp_Id
: out Entity_Id
;
627 Subp_Index
: out Entity_Id
;
633 package PolyORB_Support
is
635 -- Support for generating DSA code that uses the PolyORB PCS
637 -- The subprograms below provide the PolyORB versions of
638 -- the corresponding Specific_<subprogram> routine declared
641 procedure Add_RACW_Features
642 (RACW_Type
: Entity_Id
;
644 Stub_Type
: Entity_Id
;
645 Stub_Type_Access
: Entity_Id
;
646 RPC_Receiver_Decl
: Node_Id
;
647 Declarations
: List_Id
);
649 procedure Add_RAST_Features
651 RAS_Type
: Entity_Id
);
653 procedure Build_General_Calling_Stubs
655 Statements
: List_Id
;
656 Target_Object
: Node_Id
; -- From RPC_Target
657 Subprogram_Id
: Node_Id
;
658 Asynchronous
: Node_Id
:= Empty
;
659 Is_Known_Asynchronous
: Boolean := False;
660 Is_Known_Non_Asynchronous
: Boolean := False;
661 Is_Function
: Boolean;
663 Stub_Type
: Entity_Id
:= Empty
;
664 RACW_Type
: Entity_Id
:= Empty
;
667 function Build_Stub_Target
670 RCI_Locator
: Entity_Id
;
671 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
673 procedure Build_Stub_Type
674 (RACW_Type
: Entity_Id
;
675 Stub_Type
: Entity_Id
;
676 Stub_Type_Decl
: out Node_Id
;
677 RPC_Receiver_Decl
: out Node_Id
);
679 function Build_Subprogram_Receiving_Stubs
681 Asynchronous
: Boolean;
682 Dynamically_Asynchronous
: Boolean := False;
683 Stub_Type
: Entity_Id
:= Empty
;
684 RACW_Type
: Entity_Id
:= Empty
;
685 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
687 procedure Add_Obj_RPC_Receiver_Completion
690 RPC_Receiver
: Entity_Id
;
691 Stub_Elements
: Stub_Structure
);
693 procedure Add_Receiving_Stubs_To_Declarations
697 procedure Build_RPC_Receiver_Body
698 (RPC_Receiver
: Entity_Id
;
699 Request
: out Entity_Id
;
700 Subp_Id
: out Entity_Id
;
701 Subp_Index
: out Entity_Id
;
705 procedure Reserve_NamingContext_Methods
;
706 -- Mark the method names for interface NamingContext as already used in
707 -- the overload table, so no clashes occur with user code (with the
708 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
709 -- their methods to be accessed as objects, for the implementation of
710 -- remote access-to-subprogram types).
714 -- Routines to build distribtion helper subprograms for user-defined
715 -- types. For implementation of the Distributed systems annex (DSA)
716 -- over the PolyORB generic middleware components, it is necessary to
717 -- generate several supporting subprograms for each application data
718 -- type used in inter-partition communication. These subprograms are:
719 -- * a Typecode function returning a high-level description of the
721 -- * two conversion functions allowing conversion of values of the
722 -- type from and to the generic data containers used by PolyORB.
723 -- These generic containers are called 'Any' type values after
724 -- the CORBA terminology, and hence the conversion subprograms
725 -- are named To_Any and From_Any.
727 function Build_From_Any_Call
730 Decls
: List_Id
) return Node_Id
;
731 -- Build call to From_Any attribute function of type Typ with
732 -- expression N as actual parameter. Decls is the declarations list
733 -- for an appropriate enclosing scope of the point where the call
734 -- will be inserted; if the From_Any attribute for Typ needs to be
735 -- generated at this point, its declaration is appended to Decls.
737 procedure Build_From_Any_Function
741 Fnam
: out Entity_Id
);
742 -- Build From_Any attribute function for Typ. Loc is the reference
743 -- location for generated nodes, Typ is the type for which the
744 -- conversion function is generated. On return, Decl and Fnam contain
745 -- the declaration and entity for the newly-created function.
747 function Build_To_Any_Call
749 Decls
: List_Id
) return Node_Id
;
750 -- Build call to To_Any attribute function with expression as actual
751 -- parameter. Decls is the declarations list for an appropriate
752 -- enclosing scope of the point where the call will be inserted; if
753 -- the To_Any attribute for Typ needs to be generated at this point,
754 -- its declaration is appended to Decls.
756 procedure Build_To_Any_Function
760 Fnam
: out Entity_Id
);
761 -- Build To_Any attribute function for Typ. Loc is the reference
762 -- location for generated nodes, Typ is the type for which the
763 -- conversion function is generated. On return, Decl and Fnam contain
764 -- the declaration and entity for the newly-created function.
766 function Build_TypeCode_Call
769 Decls
: List_Id
) return Node_Id
;
770 -- Build call to TypeCode attribute function for Typ. Decls is the
771 -- declarations list for an appropriate enclosing scope of the point
772 -- where the call will be inserted; if the To_Any attribute for Typ
773 -- needs to be generated at this point, its declaration is appended
776 procedure Build_TypeCode_Function
780 Fnam
: out Entity_Id
);
781 -- Build TypeCode attribute function for Typ. Loc is the reference
782 -- location for generated nodes, Typ is the type for which the
783 -- conversion function is generated. On return, Decl and Fnam contain
784 -- the declaration and entity for the newly-created function.
786 procedure Build_Name_And_Repository_Id
788 Name_Str
: out String_Id
;
789 Repo_Id_Str
: out String_Id
);
790 -- In the PolyORB distribution model, each distributed object type
791 -- and each distributed operation has a globally unique identifier,
792 -- its Repository Id. This subprogram builds and returns two strings
793 -- for entity E (a distributed object type or operation): one
794 -- containing the name of E, the second containing its repository id.
800 ------------------------------------
801 -- Local variables and structures --
802 ------------------------------------
805 -- Needs comments ???
807 Output_From_Constrained
: constant array (Boolean) of Name_Id
:=
808 (False => Name_Output
,
810 -- The attribute to choose depending on the fact that the parameter
811 -- is constrained or not. There is no such thing as Input_From_Constrained
812 -- since this require separate mechanisms ('Input is a function while
813 -- 'Read is a procedure).
815 ---------------------------------------
816 -- Add_Calling_Stubs_To_Declarations --
817 ---------------------------------------
819 procedure Add_Calling_Stubs_To_Declarations
823 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
824 -- Subprogram id 0 is reserved for calls received from
825 -- remote access-to-subprogram dereferences.
827 Current_Declaration
: Node_Id
;
828 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
829 RCI_Instantiation
: Node_Id
;
830 Subp_Stubs
: Node_Id
;
831 Subp_Str
: String_Id
;
834 -- The first thing added is an instantiation of the generic package
835 -- System.Partition_Interface.RCI_Locator with the name of this
836 -- remote package. This will act as an interface with the name server
837 -- to determine the Partition_ID and the RPC_Receiver for the
838 -- receiver of this package.
840 RCI_Instantiation
:= RCI_Package_Locator
(Loc
, Pkg_Spec
);
841 RCI_Cache
:= Defining_Unit_Name
(RCI_Instantiation
);
843 Append_To
(Decls
, RCI_Instantiation
);
844 Analyze
(RCI_Instantiation
);
846 -- For each subprogram declaration visible in the spec, we do
847 -- build a body. We also increment a counter to assign a different
848 -- Subprogram_Id to each subprograms. The receiving stubs processing
849 -- do use the same mechanism and will thus assign the same Id and
850 -- do the correct dispatching.
852 Overload_Counter_Table
.Reset
;
853 PolyORB_Support
.Reserve_NamingContext_Methods
;
855 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
857 while Present
(Current_Declaration
) loop
858 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
859 and then Comes_From_Source
(Current_Declaration
)
861 Assign_Subprogram_Identifier
(
862 Defining_Unit_Name
(Specification
(Current_Declaration
)),
863 Current_Subprogram_Number
,
867 Build_Subprogram_Calling_Stubs
(
868 Vis_Decl
=> Current_Declaration
,
870 Build_Subprogram_Id
(Loc
,
871 Defining_Unit_Name
(Specification
(Current_Declaration
))),
873 Nkind
(Specification
(Current_Declaration
)) =
874 N_Procedure_Specification
876 Is_Asynchronous
(Defining_Unit_Name
(Specification
877 (Current_Declaration
))));
879 Append_To
(Decls
, Subp_Stubs
);
880 Analyze
(Subp_Stubs
);
882 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
885 Next
(Current_Declaration
);
887 end Add_Calling_Stubs_To_Declarations
;
889 -----------------------------
890 -- Add_Parameter_To_NVList --
891 -----------------------------
893 function Add_Parameter_To_NVList
896 Parameter
: Entity_Id
;
897 Constrained
: Boolean;
898 RACW_Ctrl
: Boolean := False;
899 Any
: Entity_Id
) return Node_Id
901 Parameter_Name_String
: String_Id
;
902 Parameter_Mode
: Node_Id
;
904 function Parameter_Passing_Mode
906 Parameter
: Entity_Id
;
907 Constrained
: Boolean) return Node_Id
;
908 -- Return an expression that denotes the parameter passing
909 -- mode to be used for Parameter in distribution stubs,
910 -- where Constrained is Parameter's constrained status.
912 ----------------------------
913 -- Parameter_Passing_Mode --
914 ----------------------------
916 function Parameter_Passing_Mode
918 Parameter
: Entity_Id
;
919 Constrained
: Boolean) return Node_Id
924 if Out_Present
(Parameter
) then
925 if In_Present
(Parameter
)
926 or else not Constrained
928 -- Unconstrained formals must be translated
929 -- to 'in' or 'inout', not 'out', because
930 -- they need to be constrained by the actual.
932 Lib_RE
:= RE_Mode_Inout
;
934 Lib_RE
:= RE_Mode_Out
;
938 Lib_RE
:= RE_Mode_In
;
941 return New_Occurrence_Of
(RTE
(Lib_RE
), Loc
);
942 end Parameter_Passing_Mode
;
944 -- Start of processing for Add_Parameter_To_NVList
947 if Nkind
(Parameter
) = N_Defining_Identifier
then
948 Get_Name_String
(Chars
(Parameter
));
950 Get_Name_String
(Chars
(Defining_Identifier
954 Parameter_Name_String
:= String_From_Name_Buffer
;
957 Parameter_Mode
:= New_Occurrence_Of
958 (RTE
(RE_Mode_In
), Loc
);
960 Parameter_Mode
:= Parameter_Passing_Mode
(Loc
,
961 Parameter
, Constrained
);
965 Make_Procedure_Call_Statement
(Loc
,
968 (RTE
(RE_NVList_Add_Item
), Loc
),
969 Parameter_Associations
=> New_List
(
970 New_Occurrence_Of
(NVList
, Loc
),
971 Make_Function_Call
(Loc
,
974 (RTE
(RE_To_PolyORB_String
), Loc
),
975 Parameter_Associations
=> New_List
(
976 Make_String_Literal
(Loc
,
977 Strval
=> Parameter_Name_String
))),
978 New_Occurrence_Of
(Any
, Loc
),
980 end Add_Parameter_To_NVList
;
982 --------------------------------
983 -- Add_RACW_Asynchronous_Flag --
984 --------------------------------
986 procedure Add_RACW_Asynchronous_Flag
987 (Declarations
: List_Id
;
988 RACW_Type
: Entity_Id
)
990 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
992 Asynchronous_Flag
: constant Entity_Id
:=
993 Make_Defining_Identifier
(Loc
,
994 New_External_Name
(Chars
(RACW_Type
), 'A'));
997 -- Declare the asynchronous flag. This flag will be changed to True
998 -- whenever it is known that the RACW type is asynchronous.
1000 Append_To
(Declarations
,
1001 Make_Object_Declaration
(Loc
,
1002 Defining_Identifier
=> Asynchronous_Flag
,
1003 Constant_Present
=> True,
1004 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
1005 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
1007 Asynchronous_Flags_Table
.Set
(RACW_Type
, Asynchronous_Flag
);
1008 end Add_RACW_Asynchronous_Flag
;
1010 -----------------------
1011 -- Add_RACW_Features --
1012 -----------------------
1014 procedure Add_RACW_Features
(RACW_Type
: Entity_Id
)
1016 Desig
: constant Entity_Id
:=
1017 Etype
(Designated_Type
(RACW_Type
));
1019 List_Containing
(Declaration_Node
(RACW_Type
));
1021 Same_Scope
: constant Boolean :=
1022 Scope
(Desig
) = Scope
(RACW_Type
);
1024 Stub_Type
: Entity_Id
;
1025 Stub_Type_Access
: Entity_Id
;
1026 RPC_Receiver_Decl
: Node_Id
;
1030 if not Expander_Active
then
1036 -- We are declaring a RACW in the same package than its designated
1037 -- type, so the list to use for late declarations must be the
1038 -- private part of the package. We do know that this private part
1039 -- exists since the designated type has to be a private one.
1041 Decls
:= Private_Declarations
1042 (Package_Specification_Of_Scope
(Current_Scope
));
1044 elsif Nkind
(Parent
(Decls
)) = N_Package_Specification
1045 and then Present
(Private_Declarations
(Parent
(Decls
)))
1047 Decls
:= Private_Declarations
(Parent
(Decls
));
1050 -- If we were unable to find the declarations, that means that the
1051 -- completion of the type was missing. We can safely return and let
1052 -- the error be caught by the semantic analysis.
1059 (Designated_Type
=> Desig
,
1060 RACW_Type
=> RACW_Type
,
1062 Stub_Type
=> Stub_Type
,
1063 Stub_Type_Access
=> Stub_Type_Access
,
1064 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1065 Existing
=> Existing
);
1067 Add_RACW_Asynchronous_Flag
1068 (Declarations
=> Decls
,
1069 RACW_Type
=> RACW_Type
);
1071 Specific_Add_RACW_Features
1072 (RACW_Type
=> RACW_Type
,
1074 Stub_Type
=> Stub_Type
,
1075 Stub_Type_Access
=> Stub_Type_Access
,
1076 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1077 Declarations
=> Decls
);
1079 if not Same_Scope
and then not Existing
then
1081 -- The RACW has been declared in another scope than the designated
1082 -- type and has not been handled by another RACW in the same package
1083 -- as the first one, so add primitive for the stub type here.
1085 Add_RACW_Primitive_Declarations_And_Bodies
1086 (Designated_Type
=> Desig
,
1087 Insertion_Node
=> RPC_Receiver_Decl
,
1091 Add_Access_Type_To_Process
(E
=> Desig
, A
=> RACW_Type
);
1093 end Add_RACW_Features
;
1095 ------------------------------------------------
1096 -- Add_RACW_Primitive_Declarations_And_Bodies --
1097 ------------------------------------------------
1099 procedure Add_RACW_Primitive_Declarations_And_Bodies
1100 (Designated_Type
: Entity_Id
;
1101 Insertion_Node
: Node_Id
;
1104 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1105 -- the declarations are recognized as belonging to the current package.
1107 Loc
: constant Source_Ptr
:= Sloc
(Insertion_Node
);
1109 Stub_Elements
: constant Stub_Structure
:=
1110 Stubs_Table
.Get
(Designated_Type
);
1112 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
1113 Is_RAS
: constant Boolean :=
1114 not Comes_From_Source
(Stub_Elements
.RACW_Type
);
1116 Current_Insertion_Node
: Node_Id
:= Insertion_Node
;
1118 RPC_Receiver
: Entity_Id
;
1119 RPC_Receiver_Statements
: List_Id
;
1120 RPC_Receiver_Case_Alternatives
: constant List_Id
:= New_List
;
1121 RPC_Receiver_Elsif_Parts
: List_Id
;
1122 RPC_Receiver_Request
: Entity_Id
;
1123 RPC_Receiver_Subp_Id
: Entity_Id
;
1124 RPC_Receiver_Subp_Index
: Entity_Id
;
1126 Subp_Str
: String_Id
;
1128 Current_Primitive_Elmt
: Elmt_Id
;
1129 Current_Primitive
: Entity_Id
;
1130 Current_Primitive_Body
: Node_Id
;
1131 Current_Primitive_Spec
: Node_Id
;
1132 Current_Primitive_Decl
: Node_Id
;
1133 Current_Primitive_Number
: Int
:= 0;
1135 Current_Primitive_Alias
: Node_Id
;
1137 Current_Receiver
: Entity_Id
;
1138 Current_Receiver_Body
: Node_Id
;
1140 RPC_Receiver_Decl
: Node_Id
;
1142 Possibly_Asynchronous
: Boolean;
1145 if not Expander_Active
then
1150 RPC_Receiver
:= Make_Defining_Identifier
(Loc
,
1151 New_Internal_Name
('P'));
1152 Specific_Build_RPC_Receiver_Body
(
1153 RPC_Receiver
=> RPC_Receiver
,
1154 Request
=> RPC_Receiver_Request
,
1155 Subp_Id
=> RPC_Receiver_Subp_Id
,
1156 Subp_Index
=> RPC_Receiver_Subp_Index
,
1157 Stmts
=> RPC_Receiver_Statements
,
1158 Decl
=> RPC_Receiver_Decl
);
1160 if Get_PCS_Name
= Name_PolyORB_DSA
then
1162 -- For the case of PolyORB, we need to map a textual operation
1163 -- name into a primitive index. Currently we do so using a
1164 -- simple sequence of string comparisons.
1166 RPC_Receiver_Elsif_Parts
:= New_List
;
1170 -- Build callers, receivers for every primitive operations and a RPC
1171 -- receiver for this type.
1173 if Present
(Primitive_Operations
(Designated_Type
)) then
1174 Overload_Counter_Table
.Reset
;
1176 Current_Primitive_Elmt
:=
1177 First_Elmt
(Primitive_Operations
(Designated_Type
));
1178 while Current_Primitive_Elmt
/= No_Elmt
loop
1179 Current_Primitive
:= Node
(Current_Primitive_Elmt
);
1181 -- Copy the primitive of all the parents, except predefined
1182 -- ones that are not remotely dispatching.
1184 if Chars
(Current_Primitive
) /= Name_uSize
1185 and then Chars
(Current_Primitive
) /= Name_uAlignment
1186 and then not Is_TSS
(Current_Primitive
, TSS_Deep_Finalize
)
1188 -- The first thing to do is build an up-to-date copy of
1189 -- the spec with all the formals referencing Designated_Type
1190 -- transformed into formals referencing Stub_Type. Since this
1191 -- primitive may have been inherited, go back the alias chain
1192 -- until the real primitive has been found.
1194 Current_Primitive_Alias
:= Current_Primitive
;
1195 while Present
(Alias
(Current_Primitive_Alias
)) loop
1197 (Current_Primitive_Alias
1198 /= Alias
(Current_Primitive_Alias
));
1199 Current_Primitive_Alias
:= Alias
(Current_Primitive_Alias
);
1202 Current_Primitive_Spec
:=
1203 Copy_Specification
(Loc
,
1204 Spec
=> Parent
(Current_Primitive_Alias
),
1205 Object_Type
=> Designated_Type
,
1206 Stub_Type
=> Stub_Elements
.Stub_Type
);
1208 Current_Primitive_Decl
:=
1209 Make_Subprogram_Declaration
(Loc
,
1210 Specification
=> Current_Primitive_Spec
);
1212 Insert_After
(Current_Insertion_Node
, Current_Primitive_Decl
);
1213 Analyze
(Current_Primitive_Decl
);
1214 Current_Insertion_Node
:= Current_Primitive_Decl
;
1216 Possibly_Asynchronous
:=
1217 Nkind
(Current_Primitive_Spec
) = N_Procedure_Specification
1218 and then Could_Be_Asynchronous
(Current_Primitive_Spec
);
1220 Assign_Subprogram_Identifier
(
1221 Defining_Unit_Name
(Current_Primitive_Spec
),
1222 Current_Primitive_Number
,
1225 Current_Primitive_Body
:=
1226 Build_Subprogram_Calling_Stubs
1227 (Vis_Decl
=> Current_Primitive_Decl
,
1229 Build_Subprogram_Id
(Loc
,
1230 Defining_Unit_Name
(Current_Primitive_Spec
)),
1231 Asynchronous
=> Possibly_Asynchronous
,
1232 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1233 Stub_Type
=> Stub_Elements
.Stub_Type
,
1234 RACW_Type
=> Stub_Elements
.RACW_Type
);
1235 Append_To
(Decls
, Current_Primitive_Body
);
1237 -- Analyzing the body here would cause the Stub type to be
1238 -- frozen, thus preventing subsequent primitive declarations.
1239 -- For this reason, it will be analyzed later in the
1242 -- Build the receiver stubs
1245 Current_Receiver_Body
:=
1246 Specific_Build_Subprogram_Receiving_Stubs
1247 (Vis_Decl
=> Current_Primitive_Decl
,
1248 Asynchronous
=> Possibly_Asynchronous
,
1249 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1250 Stub_Type
=> Stub_Elements
.Stub_Type
,
1251 RACW_Type
=> Stub_Elements
.RACW_Type
,
1252 Parent_Primitive
=> Current_Primitive
);
1254 Current_Receiver
:= Defining_Unit_Name
(
1255 Specification
(Current_Receiver_Body
));
1257 Append_To
(Decls
, Current_Receiver_Body
);
1259 -- Add a case alternative to the receiver
1261 if Get_PCS_Name
= Name_PolyORB_DSA
then
1262 Append_To
(RPC_Receiver_Elsif_Parts
,
1263 Make_Elsif_Part
(Loc
,
1265 Make_Function_Call
(Loc
,
1268 RTE
(RE_Caseless_String_Eq
), Loc
),
1269 Parameter_Associations
=> New_List
(
1270 New_Occurrence_Of
(RPC_Receiver_Subp_Id
, Loc
),
1271 Make_String_Literal
(Loc
, Subp_Str
))),
1272 Then_Statements
=> New_List
(
1273 Make_Assignment_Statement
(Loc
,
1274 Name
=> New_Occurrence_Of
(
1275 RPC_Receiver_Subp_Index
, Loc
),
1277 Make_Integer_Literal
(Loc
,
1278 Current_Primitive_Number
)))));
1281 Append_To
(RPC_Receiver_Case_Alternatives
,
1282 Make_Case_Statement_Alternative
(Loc
,
1283 Discrete_Choices
=> New_List
(
1284 Make_Integer_Literal
(Loc
, Current_Primitive_Number
)),
1286 Statements
=> New_List
(
1287 Make_Procedure_Call_Statement
(Loc
,
1289 New_Occurrence_Of
(Current_Receiver
, Loc
),
1290 Parameter_Associations
=> New_List
(
1291 New_Occurrence_Of
(RPC_Receiver_Request
, Loc
))))));
1294 -- Increment the index of current primitive
1296 Current_Primitive_Number
:= Current_Primitive_Number
+ 1;
1299 Next_Elmt
(Current_Primitive_Elmt
);
1303 -- Build the case statement and the heart of the subprogram
1306 if Get_PCS_Name
= Name_PolyORB_DSA
1307 and then Present
(First
(RPC_Receiver_Elsif_Parts
))
1309 Append_To
(RPC_Receiver_Statements
,
1310 Make_Implicit_If_Statement
(Designated_Type
,
1311 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
1312 Then_Statements
=> New_List
,
1313 Elsif_Parts
=> RPC_Receiver_Elsif_Parts
));
1316 Append_To
(RPC_Receiver_Case_Alternatives
,
1317 Make_Case_Statement_Alternative
(Loc
,
1318 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1319 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
1321 Append_To
(RPC_Receiver_Statements
,
1322 Make_Case_Statement
(Loc
,
1324 New_Occurrence_Of
(RPC_Receiver_Subp_Index
, Loc
),
1325 Alternatives
=> RPC_Receiver_Case_Alternatives
));
1327 Append_To
(Decls
, RPC_Receiver_Decl
);
1328 Specific_Add_Obj_RPC_Receiver_Completion
(Loc
,
1329 Decls
, RPC_Receiver
, Stub_Elements
);
1332 -- Do not analyze RPC receiver at this stage since it will otherwise
1333 -- reference subprograms that have not been analyzed yet. It will
1334 -- be analyzed in the regular flow.
1336 end Add_RACW_Primitive_Declarations_And_Bodies
;
1338 -----------------------------
1339 -- Add_RAS_Dereference_TSS --
1340 -----------------------------
1342 procedure Add_RAS_Dereference_TSS
(N
: Node_Id
) is
1343 Loc
: constant Source_Ptr
:= Sloc
(N
);
1345 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
1347 RAS_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
1348 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(RAS_Type
);
1349 RACW_Type
: constant Entity_Id
:= Underlying_RACW_Type
(RAS_Type
);
1350 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
1352 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
1353 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
1355 RACW_Primitive_Name
: Node_Id
;
1357 Proc
: constant Entity_Id
:=
1358 Make_Defining_Identifier
(Loc
,
1359 Chars
=> Make_TSS_Name
(RAS_Type
, TSS_RAS_Dereference
));
1361 Proc_Spec
: Node_Id
;
1362 Param_Specs
: List_Id
;
1363 Param_Assoc
: constant List_Id
:= New_List
;
1364 Stmts
: constant List_Id
:= New_List
;
1366 RAS_Parameter
: constant Entity_Id
:=
1367 Make_Defining_Identifier
(Loc
,
1368 Chars
=> New_Internal_Name
('P'));
1370 Is_Function
: constant Boolean :=
1371 Nkind
(Type_Def
) = N_Access_Function_Definition
;
1373 Is_Degenerate
: Boolean;
1374 -- Set to True if the subprogram_specification for this RAS has
1375 -- an anonymous access parameter (see Process_Remote_AST_Declaration).
1377 Spec
: constant Node_Id
:= Type_Def
;
1379 Current_Parameter
: Node_Id
;
1381 -- Start of processing for Add_RAS_Dereference_TSS
1384 -- The Dereference TSS for a remote access-to-subprogram type
1387 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1390 -- This is called whenever a value of a RAS type is dereferenced
1392 -- First construct a list of parameter specifications:
1394 -- The first formal is the RAS values
1396 Param_Specs
:= New_List
(
1397 Make_Parameter_Specification
(Loc
,
1398 Defining_Identifier
=> RAS_Parameter
,
1401 New_Occurrence_Of
(Fat_Type
, Loc
)));
1403 -- The following formals are copied from the type declaration
1405 Is_Degenerate
:= False;
1406 Current_Parameter
:= First
(Parameter_Specifications
(Type_Def
));
1407 Parameters
: while Present
(Current_Parameter
) loop
1408 if Nkind
(Parameter_Type
(Current_Parameter
))
1409 = N_Access_Definition
1411 Is_Degenerate
:= True;
1413 Append_To
(Param_Specs
,
1414 Make_Parameter_Specification
(Loc
,
1415 Defining_Identifier
=>
1416 Make_Defining_Identifier
(Loc
,
1417 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))),
1418 In_Present
=> In_Present
(Current_Parameter
),
1419 Out_Present
=> Out_Present
(Current_Parameter
),
1421 New_Copy_Tree
(Parameter_Type
(Current_Parameter
)),
1423 New_Copy_Tree
(Expression
(Current_Parameter
))));
1425 Append_To
(Param_Assoc
,
1426 Make_Identifier
(Loc
,
1427 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))));
1429 Next
(Current_Parameter
);
1430 end loop Parameters
;
1432 if Is_Degenerate
then
1433 Prepend_To
(Param_Assoc
, New_Occurrence_Of
(RAS_Parameter
, Loc
));
1435 -- Generate a dummy body. This code will never actually be executed,
1436 -- because null is the only legal value for a degenerate RAS type.
1437 -- For legality's sake (in order to avoid generating a function
1438 -- that does not contain a return statement), we include a dummy
1439 -- recursive call on the TSS itself.
1442 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Explicit_Raise
));
1443 RACW_Primitive_Name
:= New_Occurrence_Of
(Proc
, Loc
);
1446 -- For a normal RAS type, we cast the RAS formal to the corresponding
1447 -- tagged type, and perform a dispatching call to its Call
1448 -- primitive operation.
1450 Prepend_To
(Param_Assoc
,
1451 Unchecked_Convert_To
(RACW_Type
,
1452 New_Occurrence_Of
(RAS_Parameter
, Loc
)));
1454 RACW_Primitive_Name
:= Make_Selected_Component
(Loc
,
1455 Prefix
=> Scope
(RACW_Type
),
1456 Selector_Name
=> Name_Call
);
1461 Make_Return_Statement
(Loc
,
1463 Make_Function_Call
(Loc
,
1465 RACW_Primitive_Name
,
1466 Parameter_Associations
=> Param_Assoc
)));
1470 Make_Procedure_Call_Statement
(Loc
,
1472 RACW_Primitive_Name
,
1473 Parameter_Associations
=> Param_Assoc
));
1476 -- Build the complete subprogram
1480 Make_Function_Specification
(Loc
,
1481 Defining_Unit_Name
=> Proc
,
1482 Parameter_Specifications
=> Param_Specs
,
1483 Result_Definition
=>
1485 Entity
(Result_Definition
(Spec
)), Loc
));
1487 Set_Ekind
(Proc
, E_Function
);
1489 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
1493 Make_Procedure_Specification
(Loc
,
1494 Defining_Unit_Name
=> Proc
,
1495 Parameter_Specifications
=> Param_Specs
);
1497 Set_Ekind
(Proc
, E_Procedure
);
1498 Set_Etype
(Proc
, Standard_Void_Type
);
1502 Make_Subprogram_Body
(Loc
,
1503 Specification
=> Proc_Spec
,
1504 Declarations
=> New_List
,
1505 Handled_Statement_Sequence
=>
1506 Make_Handled_Sequence_Of_Statements
(Loc
,
1507 Statements
=> Stmts
)));
1509 Set_TSS
(Fat_Type
, Proc
);
1510 end Add_RAS_Dereference_TSS
;
1512 -------------------------------
1513 -- Add_RAS_Proxy_And_Analyze --
1514 -------------------------------
1516 procedure Add_RAS_Proxy_And_Analyze
1519 All_Calls_Remote_E
: Entity_Id
;
1520 Proxy_Object_Addr
: out Entity_Id
)
1522 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
1524 Subp_Name
: constant Entity_Id
:=
1525 Defining_Unit_Name
(Specification
(Vis_Decl
));
1527 Pkg_Name
: constant Entity_Id
:=
1528 Make_Defining_Identifier
(Loc
,
1530 New_External_Name
(Chars
(Subp_Name
), 'P', -1));
1532 Proxy_Type
: constant Entity_Id
:=
1533 Make_Defining_Identifier
(Loc
,
1536 Related_Id
=> Chars
(Subp_Name
),
1539 Proxy_Type_Full_View
: constant Entity_Id
:=
1540 Make_Defining_Identifier
(Loc
,
1541 Chars
(Proxy_Type
));
1543 Subp_Decl_Spec
: constant Node_Id
:=
1544 Build_RAS_Primitive_Specification
1545 (Subp_Spec
=> Specification
(Vis_Decl
),
1546 Remote_Object_Type
=> Proxy_Type
);
1548 Subp_Body_Spec
: constant Node_Id
:=
1549 Build_RAS_Primitive_Specification
1550 (Subp_Spec
=> Specification
(Vis_Decl
),
1551 Remote_Object_Type
=> Proxy_Type
);
1553 Vis_Decls
: constant List_Id
:= New_List
;
1554 Pvt_Decls
: constant List_Id
:= New_List
;
1555 Actuals
: constant List_Id
:= New_List
;
1557 Perform_Call
: Node_Id
;
1560 -- type subpP is tagged limited private;
1562 Append_To
(Vis_Decls
,
1563 Make_Private_Type_Declaration
(Loc
,
1564 Defining_Identifier
=> Proxy_Type
,
1565 Tagged_Present
=> True,
1566 Limited_Present
=> True));
1568 -- [subprogram] Call
1569 -- (Self : access subpP;
1570 -- ...other-formals...)
1573 Append_To
(Vis_Decls
,
1574 Make_Subprogram_Declaration
(Loc
,
1575 Specification
=> Subp_Decl_Spec
));
1577 -- A : constant System.Address;
1579 Proxy_Object_Addr
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1581 Append_To
(Vis_Decls
,
1582 Make_Object_Declaration
(Loc
,
1583 Defining_Identifier
=>
1587 Object_Definition
=>
1588 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
1592 -- type subpP is tagged limited record
1593 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1597 Append_To
(Pvt_Decls
,
1598 Make_Full_Type_Declaration
(Loc
,
1599 Defining_Identifier
=>
1600 Proxy_Type_Full_View
,
1602 Build_Remote_Subprogram_Proxy_Type
(Loc
,
1603 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
))));
1605 -- Trick semantic analysis into swapping the public and
1606 -- full view when freezing the public view.
1608 Set_Comes_From_Source
(Proxy_Type_Full_View
, True);
1611 -- (Self : access O;
1612 -- ...other-formals...) is
1614 -- P (...other-formals...);
1618 -- (Self : access O;
1619 -- ...other-formals...)
1622 -- return F (...other-formals...);
1625 if Nkind
(Subp_Decl_Spec
) = N_Procedure_Specification
then
1627 Make_Procedure_Call_Statement
(Loc
,
1629 New_Occurrence_Of
(Subp_Name
, Loc
),
1630 Parameter_Associations
=>
1634 Make_Return_Statement
(Loc
,
1636 Make_Function_Call
(Loc
,
1638 New_Occurrence_Of
(Subp_Name
, Loc
),
1639 Parameter_Associations
=>
1643 Formal
:= First
(Parameter_Specifications
(Subp_Decl_Spec
));
1644 pragma Assert
(Present
(Formal
));
1647 exit when No
(Formal
);
1649 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1652 -- O : aliased subpP;
1654 Append_To
(Pvt_Decls
,
1655 Make_Object_Declaration
(Loc
,
1656 Defining_Identifier
=>
1657 Make_Defining_Identifier
(Loc
,
1661 Object_Definition
=>
1662 New_Occurrence_Of
(Proxy_Type
, Loc
)));
1664 -- A : constant System.Address := O'Address;
1666 Append_To
(Pvt_Decls
,
1667 Make_Object_Declaration
(Loc
,
1668 Defining_Identifier
=>
1669 Make_Defining_Identifier
(Loc
,
1670 Chars
(Proxy_Object_Addr
)),
1673 Object_Definition
=>
1674 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
1676 Make_Attribute_Reference
(Loc
,
1677 Prefix
=> New_Occurrence_Of
(
1678 Defining_Identifier
(Last
(Pvt_Decls
)), Loc
),
1683 Make_Package_Declaration
(Loc
,
1684 Specification
=> Make_Package_Specification
(Loc
,
1685 Defining_Unit_Name
=> Pkg_Name
,
1686 Visible_Declarations
=> Vis_Decls
,
1687 Private_Declarations
=> Pvt_Decls
,
1688 End_Label
=> Empty
)));
1689 Analyze
(Last
(Decls
));
1692 Make_Package_Body
(Loc
,
1693 Defining_Unit_Name
=>
1694 Make_Defining_Identifier
(Loc
,
1696 Declarations
=> New_List
(
1697 Make_Subprogram_Body
(Loc
,
1700 Declarations
=> New_List
,
1701 Handled_Statement_Sequence
=>
1702 Make_Handled_Sequence_Of_Statements
(Loc
,
1703 Statements
=> New_List
(Perform_Call
))))));
1704 Analyze
(Last
(Decls
));
1705 end Add_RAS_Proxy_And_Analyze
;
1707 -----------------------
1708 -- Add_RAST_Features --
1709 -----------------------
1711 procedure Add_RAST_Features
(Vis_Decl
: Node_Id
) is
1712 RAS_Type
: constant Entity_Id
:=
1713 Equivalent_Type
(Defining_Identifier
(Vis_Decl
));
1715 pragma Assert
(No
(TSS
(RAS_Type
, TSS_RAS_Access
)));
1716 Add_RAS_Dereference_TSS
(Vis_Decl
);
1717 Specific_Add_RAST_Features
(Vis_Decl
, RAS_Type
);
1718 end Add_RAST_Features
;
1724 procedure Add_Stub_Type
1725 (Designated_Type
: Entity_Id
;
1726 RACW_Type
: Entity_Id
;
1728 Stub_Type
: out Entity_Id
;
1729 Stub_Type_Access
: out Entity_Id
;
1730 RPC_Receiver_Decl
: out Node_Id
;
1731 Existing
: out Boolean)
1733 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1735 Stub_Elements
: constant Stub_Structure
:=
1736 Stubs_Table
.Get
(Designated_Type
);
1737 Stub_Type_Decl
: Node_Id
;
1738 Stub_Type_Access_Decl
: Node_Id
;
1741 if Stub_Elements
/= Empty_Stub_Structure
then
1742 Stub_Type
:= Stub_Elements
.Stub_Type
;
1743 Stub_Type_Access
:= Stub_Elements
.Stub_Type_Access
;
1744 RPC_Receiver_Decl
:= Stub_Elements
.RPC_Receiver_Decl
;
1751 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
1753 Make_Defining_Identifier
(Loc
,
1755 Related_Id
=> Chars
(Stub_Type
),
1758 Specific_Build_Stub_Type
(
1759 RACW_Type
, Stub_Type
,
1760 Stub_Type_Decl
, RPC_Receiver_Decl
);
1762 Stub_Type_Access_Decl
:=
1763 Make_Full_Type_Declaration
(Loc
,
1764 Defining_Identifier
=> Stub_Type_Access
,
1766 Make_Access_To_Object_Definition
(Loc
,
1767 All_Present
=> True,
1768 Subtype_Indication
=> New_Occurrence_Of
(Stub_Type
, Loc
)));
1770 Append_To
(Decls
, Stub_Type_Decl
);
1771 Analyze
(Last
(Decls
));
1772 Append_To
(Decls
, Stub_Type_Access_Decl
);
1773 Analyze
(Last
(Decls
));
1775 -- This is in no way a type derivation, but we fake it to make
1776 -- sure that the dispatching table gets built with the corresponding
1777 -- primitive operations at the right place.
1779 Derive_Subprograms
(Parent_Type
=> Designated_Type
,
1780 Derived_Type
=> Stub_Type
);
1782 if Present
(RPC_Receiver_Decl
) then
1783 Append_To
(Decls
, RPC_Receiver_Decl
);
1785 RPC_Receiver_Decl
:= Last
(Decls
);
1788 Stubs_Table
.Set
(Designated_Type
,
1789 (Stub_Type
=> Stub_Type
,
1790 Stub_Type_Access
=> Stub_Type_Access
,
1791 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1792 RACW_Type
=> RACW_Type
));
1795 ----------------------------------
1796 -- Assign_Subprogram_Identifier --
1797 ----------------------------------
1799 procedure Assign_Subprogram_Identifier
1804 N
: constant Name_Id
:= Chars
(Def
);
1806 Overload_Order
: constant Int
:=
1807 Overload_Counter_Table
.Get
(N
) + 1;
1810 Overload_Counter_Table
.Set
(N
, Overload_Order
);
1812 Get_Name_String
(N
);
1814 -- Homonym handling: as in Exp_Dbug, but much simpler,
1815 -- because the only entities for which we have to generate
1816 -- names here need only to be disambiguated within their
1819 if Overload_Order
> 1 then
1820 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 2) := "__";
1821 Name_Len
:= Name_Len
+ 2;
1822 Add_Nat_To_Name_Buffer
(Overload_Order
);
1825 Id
:= String_From_Name_Buffer
;
1826 Subprogram_Identifier_Table
.Set
(Def
,
1827 Subprogram_Identifiers
'(Str_Identifier => Id, Int_Identifier => Spn));
1828 end Assign_Subprogram_Identifier;
1830 ------------------------------
1831 -- Build_Get_Unique_RP_Call --
1832 ------------------------------
1834 function Build_Get_Unique_RP_Call
1836 Pointer : Entity_Id;
1837 Stub_Type : Entity_Id) return List_Id
1841 Make_Procedure_Call_Statement (Loc,
1843 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
1844 Parameter_Associations => New_List (
1845 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
1846 New_Occurrence_Of (Pointer, Loc)))),
1848 Make_Assignment_Statement (Loc,
1850 Make_Selected_Component (Loc,
1852 New_Occurrence_Of (Pointer, Loc),
1854 New_Occurrence_Of (First_Tag_Component
1855 (Designated_Type (Etype (Pointer))), Loc)),
1857 Make_Attribute_Reference (Loc,
1859 New_Occurrence_Of (Stub_Type, Loc),
1863 -- Note: The assignment to Pointer._Tag is safe here because
1864 -- we carefully ensured that Stub_Type has exactly the same layout
1865 -- as System.Partition_Interface.RACW_Stub_Type.
1867 end Build_Get_Unique_RP_Call;
1869 -----------------------------------
1870 -- Build_Ordered_Parameters_List --
1871 -----------------------------------
1873 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
1874 Constrained_List : List_Id;
1875 Unconstrained_List : List_Id;
1876 Current_Parameter : Node_Id;
1878 First_Parameter : Node_Id;
1879 For_RAS : Boolean := False;
1882 if not Present (Parameter_Specifications (Spec)) then
1886 Constrained_List := New_List;
1887 Unconstrained_List := New_List;
1888 First_Parameter := First (Parameter_Specifications (Spec));
1890 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
1891 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
1896 -- Loop through the parameters and add them to the right list
1898 Current_Parameter := First_Parameter;
1899 while Present (Current_Parameter) loop
1900 if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
1902 Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
1904 Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
1905 and then not (For_RAS and then Current_Parameter = First_Parameter)
1907 Append_To (Constrained_List, New_Copy (Current_Parameter));
1909 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
1912 Next (Current_Parameter);
1915 -- Unconstrained parameters are returned first
1917 Append_List_To (Unconstrained_List, Constrained_List);
1919 return Unconstrained_List;
1920 end Build_Ordered_Parameters_List;
1922 ----------------------------------
1923 -- Build_Passive_Partition_Stub --
1924 ----------------------------------
1926 procedure Build_Passive_Partition_Stub (U : Node_Id) is
1928 Pkg_Name : String_Id;
1931 Loc : constant Source_Ptr := Sloc (U);
1934 -- Verify that the implementation supports distribution, by accessing
1935 -- a type defined in the proper version of system.rpc
1938 Dist_OK : Entity_Id;
1939 pragma Warnings (Off, Dist_OK);
1941 Dist_OK := RTE (RE_Params_Stream_Type);
1944 -- Use body if present, spec otherwise
1946 if Nkind (U) = N_Package_Declaration then
1947 Pkg_Spec := Specification (U);
1948 L := Visible_Declarations (Pkg_Spec);
1950 Pkg_Spec := Parent (Corresponding_Spec (U));
1951 L := Declarations (U);
1954 Get_Library_Unit_Name_String (Pkg_Spec);
1955 Pkg_Name := String_From_Name_Buffer;
1957 Make_Procedure_Call_Statement (Loc,
1959 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
1960 Parameter_Associations => New_List (
1961 Make_String_Literal (Loc, Pkg_Name),
1962 Make_Attribute_Reference (Loc,
1964 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
1969 end Build_Passive_Partition_Stub;
1971 --------------------------------------
1972 -- Build_RPC_Receiver_Specification --
1973 --------------------------------------
1975 function Build_RPC_Receiver_Specification
1976 (RPC_Receiver : Entity_Id;
1977 Request_Parameter : Entity_Id) return Node_Id
1979 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
1982 Make_Procedure_Specification (Loc,
1983 Defining_Unit_Name => RPC_Receiver,
1984 Parameter_Specifications => New_List (
1985 Make_Parameter_Specification (Loc,
1986 Defining_Identifier => Request_Parameter,
1988 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
1989 end Build_RPC_Receiver_Specification;
1991 ----------------------------------------
1992 -- Build_Remote_Subprogram_Proxy_Type --
1993 ----------------------------------------
1995 function Build_Remote_Subprogram_Proxy_Type
1997 ACR_Expression : Node_Id) return Node_Id
2001 Make_Record_Definition (Loc,
2002 Tagged_Present => True,
2003 Limited_Present => True,
2005 Make_Component_List (Loc,
2007 Component_Items => New_List (
2008 Make_Component_Declaration (Loc,
2009 Defining_Identifier =>
2010 Make_Defining_Identifier (Loc,
2011 Name_All_Calls_Remote),
2012 Component_Definition =>
2013 Make_Component_Definition (Loc,
2014 Subtype_Indication =>
2015 New_Occurrence_Of (Standard_Boolean, Loc)),
2019 Make_Component_Declaration (Loc,
2020 Defining_Identifier =>
2021 Make_Defining_Identifier (Loc,
2023 Component_Definition =>
2024 Make_Component_Definition (Loc,
2025 Subtype_Indication =>
2026 New_Occurrence_Of (RTE (RE_Address), Loc)),
2028 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2030 Make_Component_Declaration (Loc,
2031 Defining_Identifier =>
2032 Make_Defining_Identifier (Loc,
2034 Component_Definition =>
2035 Make_Component_Definition (Loc,
2036 Subtype_Indication =>
2037 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2038 end Build_Remote_Subprogram_Proxy_Type;
2040 ------------------------------------
2041 -- Build_Subprogram_Calling_Stubs --
2042 ------------------------------------
2044 function Build_Subprogram_Calling_Stubs
2045 (Vis_Decl : Node_Id;
2047 Asynchronous : Boolean;
2048 Dynamically_Asynchronous : Boolean := False;
2049 Stub_Type : Entity_Id := Empty;
2050 RACW_Type : Entity_Id := Empty;
2051 Locator : Entity_Id := Empty;
2052 New_Name : Name_Id := No_Name) return Node_Id
2054 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2056 Decls : constant List_Id := New_List;
2057 Statements : constant List_Id := New_List;
2059 Subp_Spec : Node_Id;
2060 -- The specification of the body
2062 Controlling_Parameter : Entity_Id := Empty;
2064 Asynchronous_Expr : Node_Id := Empty;
2066 RCI_Locator : Entity_Id;
2068 Spec_To_Use : Node_Id;
2070 procedure Insert_Partition_Check (Parameter : Node_Id);
2071 -- Check that the parameter has been elaborated on the same partition
2072 -- than the controlling parameter (E.4(19)).
2074 ----------------------------
2075 -- Insert_Partition_Check --
2076 ----------------------------
2078 procedure Insert_Partition_Check (Parameter : Node_Id) is
2079 Parameter_Entity : constant Entity_Id :=
2080 Defining_Identifier (Parameter);
2082 -- The expression that will be built is of the form:
2084 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2085 -- raise Constraint_Error;
2088 -- We do not check that Parameter is in Stub_Type since such a check
2089 -- has been inserted at the point of call already (a tag check since
2090 -- we have multiple controlling operands).
2093 Make_Raise_Constraint_Error (Loc,
2097 Make_Function_Call (Loc,
2099 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2100 Parameter_Associations =>
2102 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2103 New_Occurrence_Of (Parameter_Entity, Loc)),
2104 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2105 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2106 Reason => CE_Partition_Check_Failed));
2107 end Insert_Partition_Check;
2109 -- Start of processing for Build_Subprogram_Calling_Stubs
2112 Subp_Spec := Copy_Specification (Loc,
2113 Spec => Specification (Vis_Decl),
2114 New_Name => New_Name);
2116 if Locator = Empty then
2117 RCI_Locator := RCI_Cache;
2118 Spec_To_Use := Specification (Vis_Decl);
2120 RCI_Locator := Locator;
2121 Spec_To_Use := Subp_Spec;
2124 -- Find a controlling argument if we have a stub type. Also check
2125 -- if this subprogram can be made asynchronous.
2127 if Present (Stub_Type)
2128 and then Present (Parameter_Specifications (Spec_To_Use))
2131 Current_Parameter : Node_Id :=
2132 First (Parameter_Specifications
2135 while Present (Current_Parameter) loop
2137 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2139 if Controlling_Parameter = Empty then
2140 Controlling_Parameter :=
2141 Defining_Identifier (Current_Parameter);
2143 Insert_Partition_Check (Current_Parameter);
2147 Next (Current_Parameter);
2152 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2154 if Dynamically_Asynchronous then
2155 Asynchronous_Expr := Make_Selected_Component (Loc,
2156 Prefix => Controlling_Parameter,
2157 Selector_Name => Name_Asynchronous);
2160 Specific_Build_General_Calling_Stubs
2162 Statements => Statements,
2163 Target => Specific_Build_Stub_Target (Loc,
2164 Decls, RCI_Locator, Controlling_Parameter),
2165 Subprogram_Id => Subp_Id,
2166 Asynchronous => Asynchronous_Expr,
2167 Is_Known_Asynchronous => Asynchronous
2168 and then not Dynamically_Asynchronous,
2169 Is_Known_Non_Asynchronous
2171 and then not Dynamically_Asynchronous,
2172 Is_Function => Nkind (Spec_To_Use) =
2173 N_Function_Specification,
2174 Spec => Spec_To_Use,
2175 Stub_Type => Stub_Type,
2176 RACW_Type => RACW_Type,
2179 RCI_Calling_Stubs_Table.Set
2180 (Defining_Unit_Name (Specification (Vis_Decl)),
2181 Defining_Unit_Name (Spec_To_Use));
2184 Make_Subprogram_Body (Loc,
2185 Specification => Subp_Spec,
2186 Declarations => Decls,
2187 Handled_Statement_Sequence =>
2188 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2189 end Build_Subprogram_Calling_Stubs;
2191 -------------------------
2192 -- Build_Subprogram_Id --
2193 -------------------------
2195 function Build_Subprogram_Id
2197 E : Entity_Id) return Node_Id
2200 case Get_PCS_Name is
2201 when Name_PolyORB_DSA =>
2202 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2204 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2206 end Build_Subprogram_Id;
2208 ------------------------
2209 -- Copy_Specification --
2210 ------------------------
2212 function Copy_Specification
2215 Object_Type : Entity_Id := Empty;
2216 Stub_Type : Entity_Id := Empty;
2217 New_Name : Name_Id := No_Name) return Node_Id
2219 Parameters : List_Id := No_List;
2221 Current_Parameter : Node_Id;
2222 Current_Identifier : Entity_Id;
2223 Current_Type : Node_Id;
2224 Current_Etype : Entity_Id;
2226 Name_For_New_Spec : Name_Id;
2228 New_Identifier : Entity_Id;
2230 -- Comments needed in body below ???
2233 if New_Name = No_Name then
2234 pragma Assert (Nkind (Spec) = N_Function_Specification
2235 or else Nkind (Spec) = N_Procedure_Specification);
2237 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2239 Name_For_New_Spec := New_Name;
2242 if Present (Parameter_Specifications (Spec)) then
2243 Parameters := New_List;
2244 Current_Parameter := First (Parameter_Specifications (Spec));
2245 while Present (Current_Parameter) loop
2246 Current_Identifier := Defining_Identifier (Current_Parameter);
2247 Current_Type := Parameter_Type (Current_Parameter);
2249 if Nkind (Current_Type) = N_Access_Definition then
2250 Current_Etype := Entity (Subtype_Mark (Current_Type));
2252 if Present (Object_Type) then
2254 Root_Type (Current_Etype) = Root_Type (Object_Type));
2256 Make_Access_Definition (Loc,
2257 Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
2260 Make_Access_Definition (Loc,
2262 New_Occurrence_Of (Current_Etype, Loc));
2266 Current_Etype := Entity (Current_Type);
2268 if Present (Object_Type)
2269 and then Current_Etype = Object_Type
2271 Current_Type := New_Occurrence_Of (Stub_Type, Loc);
2273 Current_Type := New_Occurrence_Of (Current_Etype, Loc);
2277 New_Identifier := Make_Defining_Identifier (Loc,
2278 Chars (Current_Identifier));
2280 Append_To (Parameters,
2281 Make_Parameter_Specification (Loc,
2282 Defining_Identifier => New_Identifier,
2283 Parameter_Type => Current_Type,
2284 In_Present => In_Present (Current_Parameter),
2285 Out_Present => Out_Present (Current_Parameter),
2287 New_Copy_Tree (Expression (Current_Parameter))));
2289 -- For a regular formal parameter (that needs to be marshalled
2290 -- in the context of remote calls), set the Etype now, because
2291 -- marshalling processing might need it.
2293 if Is_Entity_Name (Current_Type) then
2294 Set_Etype (New_Identifier, Entity (Current_Type));
2296 -- Current_Type is an access definition, special processing
2297 -- (not requiring etype) will occur for marshalling.
2303 Next (Current_Parameter);
2307 case Nkind (Spec) is
2309 when N_Function_Specification | N_Access_Function_Definition =>
2311 Make_Function_Specification (Loc,
2312 Defining_Unit_Name =>
2313 Make_Defining_Identifier (Loc,
2314 Chars => Name_For_New_Spec),
2315 Parameter_Specifications => Parameters,
2316 Result_Definition =>
2317 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2319 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2321 Make_Procedure_Specification (Loc,
2322 Defining_Unit_Name =>
2323 Make_Defining_Identifier (Loc,
2324 Chars => Name_For_New_Spec),
2325 Parameter_Specifications => Parameters);
2328 raise Program_Error;
2330 end Copy_Specification;
2332 ---------------------------
2333 -- Could_Be_Asynchronous --
2334 ---------------------------
2336 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2337 Current_Parameter : Node_Id;
2340 if Present (Parameter_Specifications (Spec)) then
2341 Current_Parameter := First (Parameter_Specifications (Spec));
2342 while Present (Current_Parameter) loop
2343 if Out_Present (Current_Parameter) then
2347 Next (Current_Parameter);
2352 end Could_Be_Asynchronous;
2354 ---------------------------
2355 -- Declare_Create_NVList --
2356 ---------------------------
2358 procedure Declare_Create_NVList
2366 Make_Object_Declaration (Loc,
2367 Defining_Identifier => NVList,
2368 Aliased_Present => False,
2369 Object_Definition =>
2370 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2373 Make_Procedure_Call_Statement (Loc,
2375 New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2376 Parameter_Associations => New_List (
2377 New_Occurrence_Of (NVList, Loc))));
2378 end Declare_Create_NVList;
2380 ---------------------------------------------
2381 -- Expand_All_Calls_Remote_Subprogram_Call --
2382 ---------------------------------------------
2384 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2385 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2386 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2387 Loc : constant Source_Ptr := Sloc (N);
2388 RCI_Locator : Node_Id;
2389 RCI_Cache : Entity_Id;
2390 Calling_Stubs : Node_Id;
2391 E_Calling_Stubs : Entity_Id;
2394 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2396 if E_Calling_Stubs = Empty then
2397 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
2399 if RCI_Cache = Empty then
2402 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2403 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
2405 -- The RCI_Locator package is inserted at the top level in the
2406 -- current unit, and must appear in the proper scope, so that it
2407 -- is not prematurely removed by the GCC back-end.
2410 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2413 if Ekind (Scop) = E_Package_Body then
2414 New_Scope (Spec_Entity (Scop));
2416 elsif Ekind (Scop) = E_Subprogram_Body then
2418 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2424 Analyze (RCI_Locator);
2428 RCI_Cache := Defining_Unit_Name (RCI_Locator);
2431 RCI_Locator := Parent (RCI_Cache);
2434 Calling_Stubs := Build_Subprogram_Calling_Stubs
2435 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2437 Build_Subprogram_Id (Loc, Called_Subprogram),
2438 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2440 Is_Asynchronous (Called_Subprogram),
2441 Locator => RCI_Cache,
2442 New_Name => New_Internal_Name ('S
'));
2443 Insert_After (RCI_Locator, Calling_Stubs);
2444 Analyze (Calling_Stubs);
2445 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2448 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2449 end Expand_All_Calls_Remote_Subprogram_Call;
2451 ---------------------------------
2452 -- Expand_Calling_Stubs_Bodies --
2453 ---------------------------------
2455 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2456 Spec : constant Node_Id := Specification (Unit_Node);
2457 Decls : constant List_Id := Visible_Declarations (Spec);
2459 New_Scope (Scope_Of_Spec (Spec));
2460 Add_Calling_Stubs_To_Declarations
2461 (Specification (Unit_Node), Decls);
2463 end Expand_Calling_Stubs_Bodies;
2465 -----------------------------------
2466 -- Expand_Receiving_Stubs_Bodies --
2467 -----------------------------------
2469 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2475 if Nkind (Unit_Node) = N_Package_Declaration then
2476 Spec := Specification (Unit_Node);
2477 Decls := Private_Declarations (Spec);
2480 Decls := Visible_Declarations (Spec);
2483 New_Scope (Scope_Of_Spec (Spec));
2484 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls);
2488 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2489 Decls := Declarations (Unit_Node);
2490 New_Scope (Scope_Of_Spec (Unit_Node));
2492 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Temp);
2493 Insert_List_Before (First (Decls), Temp);
2497 end Expand_Receiving_Stubs_Bodies;
2499 --------------------
2500 -- GARLIC_Support --
2501 --------------------
2503 package body GARLIC_Support is
2505 -- Local subprograms
2507 procedure Add_RACW_Read_Attribute
2508 (RACW_Type : Entity_Id;
2509 Stub_Type : Entity_Id;
2510 Stub_Type_Access : Entity_Id;
2511 Declarations : List_Id);
2512 -- Add Read attribute in Decls for the RACW type. The Read attribute
2513 -- is added right after the RACW_Type declaration while the body is
2514 -- inserted after Declarations.
2516 procedure Add_RACW_Write_Attribute
2517 (RACW_Type : Entity_Id;
2518 Stub_Type : Entity_Id;
2519 Stub_Type_Access : Entity_Id;
2520 RPC_Receiver : Node_Id;
2521 Declarations : List_Id);
2522 -- Same thing for the Write attribute
2524 function Stream_Parameter return Node_Id;
2525 function Result return Node_Id;
2526 function Object return Node_Id renames Result;
2527 -- Functions to create occurrences of the formal parameter names of
2528 -- the 'Read
and 'Write attributes.
2531 -- Shared source location used by Add_{Read,Write}_Read_Attribute
2532 -- and their ancillary subroutines (set on entry by Add_RACW_Features).
2534 procedure Add_RAS_Access_TSS (N : Node_Id);
2535 -- Add a subprogram body for RAS Access TSS
2537 -------------------------------------
2538 -- Add_Obj_RPC_Receiver_Completion --
2539 -------------------------------------
2541 procedure Add_Obj_RPC_Receiver_Completion
2544 RPC_Receiver : Entity_Id;
2545 Stub_Elements : Stub_Structure) is
2547 -- The RPC receiver body should not be the completion of the
2548 -- declaration recorded in the stub structure, because then the
2549 -- occurrences of the formal parameters within the body should
2550 -- refer to the entities from the declaration, not from the
2551 -- completion, to which we do not have easy access. Instead, the
2552 -- RPC receiver body acts as its own declaration, and the RPC
2553 -- receiver declaration is completed by a renaming-as-body.
2556 Make_Subprogram_Renaming_Declaration (Loc,
2558 Copy_Specification (Loc,
2559 Specification (Stub_Elements.RPC_Receiver_Decl)),
2560 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2561 end Add_Obj_RPC_Receiver_Completion;
2563 -----------------------
2564 -- Add_RACW_Features --
2565 -----------------------
2567 procedure Add_RACW_Features
2568 (RACW_Type : Entity_Id;
2569 Stub_Type : Entity_Id;
2570 Stub_Type_Access : Entity_Id;
2571 RPC_Receiver_Decl : Node_Id;
2572 Declarations : List_Id)
2574 RPC_Receiver : Node_Id;
2575 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2578 Loc := Sloc (RACW_Type);
2582 -- For a RAS, the RPC receiver is that of the RCI unit,
2583 -- not that of the corresponding distributed object type.
2584 -- We retrieve its address from the local proxy object.
2586 RPC_Receiver := Make_Selected_Component (Loc,
2588 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2589 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2592 RPC_Receiver := Make_Attribute_Reference (Loc,
2593 Prefix => New_Occurrence_Of (
2594 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2595 Attribute_Name => Name_Address);
2598 Add_RACW_Write_Attribute (
2605 Add_RACW_Read_Attribute (
2610 end Add_RACW_Features;
2612 -----------------------------
2613 -- Add_RACW_Read_Attribute --
2614 -----------------------------
2616 procedure Add_RACW_Read_Attribute
2617 (RACW_Type : Entity_Id;
2618 Stub_Type : Entity_Id;
2619 Stub_Type_Access : Entity_Id;
2620 Declarations : List_Id)
2622 Proc_Decl : Node_Id;
2623 Attr_Decl : Node_Id;
2625 Body_Node : Node_Id;
2628 Statements : List_Id;
2629 Local_Statements : List_Id;
2630 Remote_Statements : List_Id;
2631 -- Various parts of the procedure
2633 Procedure_Name : constant Name_Id :=
2634 New_Internal_Name ('R
');
2635 Source_Partition : constant Entity_Id :=
2636 Make_Defining_Identifier
2637 (Loc, New_Internal_Name ('P
'));
2638 Source_Receiver : constant Entity_Id :=
2639 Make_Defining_Identifier
2640 (Loc, New_Internal_Name ('S
'));
2641 Source_Address : constant Entity_Id :=
2642 Make_Defining_Identifier
2643 (Loc, New_Internal_Name ('P
'));
2644 Local_Stub : constant Entity_Id :=
2645 Make_Defining_Identifier
2646 (Loc, New_Internal_Name ('L
'));
2647 Stubbed_Result : constant Entity_Id :=
2648 Make_Defining_Identifier
2649 (Loc, New_Internal_Name ('S
'));
2650 Asynchronous_Flag : constant Entity_Id :=
2651 Asynchronous_Flags_Table.Get (RACW_Type);
2652 pragma Assert (Present (Asynchronous_Flag));
2654 -- Start of processing for Add_RACW_Read_Attribute
2657 -- Generate object declarations
2660 Make_Object_Declaration (Loc,
2661 Defining_Identifier => Source_Partition,
2662 Object_Definition =>
2663 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
2665 Make_Object_Declaration (Loc,
2666 Defining_Identifier => Source_Receiver,
2667 Object_Definition =>
2668 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2670 Make_Object_Declaration (Loc,
2671 Defining_Identifier => Source_Address,
2672 Object_Definition =>
2673 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2675 Make_Object_Declaration (Loc,
2676 Defining_Identifier => Local_Stub,
2677 Aliased_Present => True,
2678 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
2680 Make_Object_Declaration (Loc,
2681 Defining_Identifier => Stubbed_Result,
2682 Object_Definition =>
2683 New_Occurrence_Of (Stub_Type_Access, Loc),
2685 Make_Attribute_Reference (Loc,
2687 New_Occurrence_Of (Local_Stub, Loc),
2689 Name_Unchecked_Access)));
2691 -- Read the source Partition_ID and RPC_Receiver from incoming stream
2693 Statements := New_List (
2694 Make_Attribute_Reference (Loc,
2696 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
2697 Attribute_Name => Name_Read,
2698 Expressions => New_List (
2700 New_Occurrence_Of (Source_Partition, Loc))),
2702 Make_Attribute_Reference (Loc,
2704 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2707 Expressions => New_List (
2709 New_Occurrence_Of (Source_Receiver, Loc))),
2711 Make_Attribute_Reference (Loc,
2713 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2716 Expressions => New_List (
2718 New_Occurrence_Of (Source_Address, Loc))));
2720 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
2722 Set_Etype (Stubbed_Result, Stub_Type_Access);
2724 -- If the Address is Null_Address, then return a null object
2726 Append_To (Statements,
2727 Make_Implicit_If_Statement (RACW_Type,
2730 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
2731 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
2732 Then_Statements => New_List (
2733 Make_Assignment_Statement (Loc,
2735 Expression => Make_Null (Loc)),
2736 Make_Return_Statement (Loc))));
2738 -- If the RACW denotes an object created on the current partition,
2739 -- Local_Statements will be executed. The real object will be used.
2741 Local_Statements := New_List (
2742 Make_Assignment_Statement (Loc,
2745 Unchecked_Convert_To (RACW_Type,
2746 OK_Convert_To (RTE (RE_Address),
2747 New_Occurrence_Of (Source_Address, Loc)))));
2749 -- If the object is located on another partition, then a stub object
2750 -- will be created with all the information needed to rebuild the
2751 -- real object at the other end.
2753 Remote_Statements := New_List (
2755 Make_Assignment_Statement (Loc,
2756 Name => Make_Selected_Component (Loc,
2757 Prefix => Stubbed_Result,
2758 Selector_Name => Name_Origin),
2760 New_Occurrence_Of (Source_Partition, Loc)),
2762 Make_Assignment_Statement (Loc,
2763 Name => Make_Selected_Component (Loc,
2764 Prefix => Stubbed_Result,
2765 Selector_Name => Name_Receiver),
2767 New_Occurrence_Of (Source_Receiver, Loc)),
2769 Make_Assignment_Statement (Loc,
2770 Name => Make_Selected_Component (Loc,
2771 Prefix => Stubbed_Result,
2772 Selector_Name => Name_Addr),
2774 New_Occurrence_Of (Source_Address, Loc)));
2776 Append_To (Remote_Statements,
2777 Make_Assignment_Statement (Loc,
2778 Name => Make_Selected_Component (Loc,
2779 Prefix => Stubbed_Result,
2780 Selector_Name => Name_Asynchronous),
2782 New_Occurrence_Of (Asynchronous_Flag, Loc)));
2784 Append_List_To (Remote_Statements,
2785 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
2786 -- ??? Issue with asynchronous calls here: the Asynchronous
2787 -- flag is set on the stub type if, and only if, the RACW type
2788 -- has a pragma Asynchronous. This is incorrect for RACWs that
2789 -- implement RAS types, because in that case the /designated
2790 -- subprogram/ (not the type) might be asynchronous, and
2791 -- that causes the stub to need to be asynchronous too.
2792 -- A solution is to transport a RAS as a struct containing
2793 -- a RACW and an asynchronous flag, and to properly alter
2794 -- the Asynchronous component in the stub type in the RAS's
2797 Append_To (Remote_Statements,
2798 Make_Assignment_Statement (Loc,
2800 Expression => Unchecked_Convert_To (RACW_Type,
2801 New_Occurrence_Of (Stubbed_Result, Loc))));
2803 -- Distinguish between the local and remote cases, and execute the
2804 -- appropriate piece of code.
2806 Append_To (Statements,
2807 Make_Implicit_If_Statement (RACW_Type,
2811 Make_Function_Call (Loc,
2812 Name => New_Occurrence_Of (
2813 RTE (RE_Get_Local_Partition_Id), Loc)),
2814 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
2815 Then_Statements => Local_Statements,
2816 Else_Statements => Remote_Statements));
2818 Build_Stream_Procedure
2819 (Loc, RACW_Type, Body_Node,
2820 Make_Defining_Identifier (Loc, Procedure_Name),
2821 Statements, Outp => True);
2822 Set_Declarations (Body_Node, Decls);
2824 Proc_Decl := Make_Subprogram_Declaration (Loc,
2825 Copy_Specification (Loc, Specification (Body_Node)));
2828 Make_Attribute_Definition_Clause (Loc,
2829 Name => New_Occurrence_Of (RACW_Type, Loc),
2833 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
2835 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
2836 Insert_After (Proc_Decl, Attr_Decl);
2837 Append_To (Declarations, Body_Node);
2838 end Add_RACW_Read_Attribute;
2840 ------------------------------
2841 -- Add_RACW_Write_Attribute --
2842 ------------------------------
2844 procedure Add_RACW_Write_Attribute
2845 (RACW_Type : Entity_Id;
2846 Stub_Type : Entity_Id;
2847 Stub_Type_Access : Entity_Id;
2848 RPC_Receiver : Node_Id;
2849 Declarations : List_Id)
2851 Body_Node : Node_Id;
2852 Proc_Decl : Node_Id;
2853 Attr_Decl : Node_Id;
2855 Statements : List_Id;
2856 Local_Statements : List_Id;
2857 Remote_Statements : List_Id;
2858 Null_Statements : List_Id;
2860 Procedure_Name : constant Name_Id := New_Internal_Name ('R
');
2863 -- Build the code fragment corresponding to the marshalling of a
2866 Local_Statements := New_List (
2868 Pack_Entity_Into_Stream_Access (Loc,
2869 Stream => Stream_Parameter,
2870 Object => RTE (RE_Get_Local_Partition_Id)),
2872 Pack_Node_Into_Stream_Access (Loc,
2873 Stream => Stream_Parameter,
2874 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
2875 Etyp => RTE (RE_Unsigned_64)),
2877 Pack_Node_Into_Stream_Access (Loc,
2878 Stream => Stream_Parameter,
2879 Object => OK_Convert_To (RTE (RE_Unsigned_64),
2880 Make_Attribute_Reference (Loc,
2882 Make_Explicit_Dereference (Loc,
2884 Attribute_Name => Name_Address)),
2885 Etyp => RTE (RE_Unsigned_64)));
2887 -- Build the code fragment corresponding to the marshalling of
2890 Remote_Statements := New_List (
2892 Pack_Node_Into_Stream_Access (Loc,
2893 Stream => Stream_Parameter,
2895 Make_Selected_Component (Loc,
2896 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2899 Make_Identifier (Loc, Name_Origin)),
2900 Etyp => RTE (RE_Partition_ID)),
2902 Pack_Node_Into_Stream_Access (Loc,
2903 Stream => Stream_Parameter,
2905 Make_Selected_Component (Loc,
2906 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2909 Make_Identifier (Loc, Name_Receiver)),
2910 Etyp => RTE (RE_Unsigned_64)),
2912 Pack_Node_Into_Stream_Access (Loc,
2913 Stream => Stream_Parameter,
2915 Make_Selected_Component (Loc,
2916 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2919 Make_Identifier (Loc, Name_Addr)),
2920 Etyp => RTE (RE_Unsigned_64)));
2922 -- Build code fragment corresponding to marshalling of a null object
2924 Null_Statements := New_List (
2926 Pack_Entity_Into_Stream_Access (Loc,
2927 Stream => Stream_Parameter,
2928 Object => RTE (RE_Get_Local_Partition_Id)),
2930 Pack_Node_Into_Stream_Access (Loc,
2931 Stream => Stream_Parameter,
2932 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
2933 Etyp => RTE (RE_Unsigned_64)),
2935 Pack_Node_Into_Stream_Access (Loc,
2936 Stream => Stream_Parameter,
2937 Object => Make_Integer_Literal (Loc, Uint_0),
2938 Etyp => RTE (RE_Unsigned_64)));
2940 Statements := New_List (
2941 Make_Implicit_If_Statement (RACW_Type,
2944 Left_Opnd => Object,
2945 Right_Opnd => Make_Null (Loc)),
2946 Then_Statements => Null_Statements,
2947 Elsif_Parts => New_List (
2948 Make_Elsif_Part (Loc,
2952 Make_Attribute_Reference (Loc,
2954 Attribute_Name => Name_Tag),
2956 Make_Attribute_Reference (Loc,
2957 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2958 Attribute_Name => Name_Tag)),
2959 Then_Statements => Remote_Statements)),
2960 Else_Statements => Local_Statements));
2962 Build_Stream_Procedure
2963 (Loc, RACW_Type, Body_Node,
2964 Make_Defining_Identifier (Loc, Procedure_Name),
2965 Statements, Outp => False);
2967 Proc_Decl := Make_Subprogram_Declaration (Loc,
2968 Copy_Specification (Loc, Specification (Body_Node)));
2971 Make_Attribute_Definition_Clause (Loc,
2972 Name => New_Occurrence_Of (RACW_Type, Loc),
2973 Chars => Name_Write,
2976 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
2978 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
2979 Insert_After (Proc_Decl, Attr_Decl);
2980 Append_To (Declarations, Body_Node);
2981 end Add_RACW_Write_Attribute;
2983 ------------------------
2984 -- Add_RAS_Access_TSS --
2985 ------------------------
2987 procedure Add_RAS_Access_TSS (N : Node_Id) is
2988 Loc : constant Source_Ptr := Sloc (N);
2990 Ras_Type : constant Entity_Id := Defining_Identifier (N);
2991 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
2992 -- Ras_Type is the access to subprogram type while Fat_Type is the
2993 -- corresponding record type.
2995 RACW_Type : constant Entity_Id :=
2996 Underlying_RACW_Type (Ras_Type);
2997 Desig : constant Entity_Id :=
2998 Etype (Designated_Type (RACW_Type));
3000 Stub_Elements : constant Stub_Structure :=
3001 Stubs_Table.Get (Desig);
3002 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3004 Proc : constant Entity_Id :=
3005 Make_Defining_Identifier (Loc,
3006 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3008 Proc_Spec : Node_Id;
3010 -- Formal parameters
3012 Package_Name : constant Entity_Id :=
3013 Make_Defining_Identifier (Loc,
3017 Subp_Id : constant Entity_Id :=
3018 Make_Defining_Identifier (Loc,
3020 -- Target subprogram
3022 Asynch_P : constant Entity_Id :=
3023 Make_Defining_Identifier (Loc,
3024 Chars => Name_Asynchronous);
3025 -- Is the procedure to which the 'Access applies asynchronous?
3027 All_Calls_Remote
: constant Entity_Id
:=
3028 Make_Defining_Identifier
(Loc
,
3029 Chars
=> Name_All_Calls_Remote
);
3030 -- True if an All_Calls_Remote pragma applies to the RCI unit
3031 -- that contains the subprogram.
3033 -- Common local variables
3035 Proc_Decls
: List_Id
;
3036 Proc_Statements
: List_Id
;
3038 Origin
: constant Entity_Id
:=
3039 Make_Defining_Identifier
(Loc
,
3040 Chars
=> New_Internal_Name
('P'));
3042 -- Additional local variables for the local case
3044 Proxy_Addr
: constant Entity_Id
:=
3045 Make_Defining_Identifier
(Loc
,
3046 Chars
=> New_Internal_Name
('P'));
3048 -- Additional local variables for the remote case
3050 Local_Stub
: constant Entity_Id
:=
3051 Make_Defining_Identifier
(Loc
,
3052 Chars
=> New_Internal_Name
('L'));
3054 Stub_Ptr
: constant Entity_Id
:=
3055 Make_Defining_Identifier
(Loc
,
3056 Chars
=> New_Internal_Name
('S'));
3059 (Field_Name
: Name_Id
;
3060 Value
: Node_Id
) return Node_Id
;
3061 -- Construct an assignment that sets the named component in the
3069 (Field_Name
: Name_Id
;
3070 Value
: Node_Id
) return Node_Id
3074 Make_Assignment_Statement
(Loc
,
3076 Make_Selected_Component
(Loc
,
3078 Selector_Name
=> Field_Name
),
3079 Expression
=> Value
);
3082 -- Start of processing for Add_RAS_Access_TSS
3085 Proc_Decls
:= New_List
(
3087 -- Common declarations
3089 Make_Object_Declaration
(Loc
,
3090 Defining_Identifier
=> Origin
,
3091 Constant_Present
=> True,
3092 Object_Definition
=>
3093 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3095 Make_Function_Call
(Loc
,
3097 New_Occurrence_Of
(RTE
(RE_Get_Active_Partition_Id
), Loc
),
3098 Parameter_Associations
=> New_List
(
3099 New_Occurrence_Of
(Package_Name
, Loc
)))),
3101 -- Declaration use only in the local case: proxy address
3103 Make_Object_Declaration
(Loc
,
3104 Defining_Identifier
=> Proxy_Addr
,
3105 Object_Definition
=>
3106 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3108 -- Declarations used only in the remote case: stub object and
3111 Make_Object_Declaration
(Loc
,
3112 Defining_Identifier
=> Local_Stub
,
3113 Aliased_Present
=> True,
3114 Object_Definition
=>
3115 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
3117 Make_Object_Declaration
(Loc
,
3118 Defining_Identifier
=>
3120 Object_Definition
=>
3121 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
3123 Make_Attribute_Reference
(Loc
,
3124 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
3125 Attribute_Name
=> Name_Unchecked_Access
)));
3127 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
3128 -- Build_Get_Unique_RP_Call needs this information
3130 -- Note: Here we assume that the Fat_Type is a record
3131 -- containing just a pointer to a proxy or stub object.
3133 Proc_Statements
:= New_List
(
3137 -- Get_RAS_Info (Pkg, Subp, PA);
3138 -- if Origin = Local_Partition_Id
3139 -- and then not All_Calls_Remote
3141 -- return Fat_Type!(PA);
3144 Make_Procedure_Call_Statement
(Loc
,
3146 New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
3147 Parameter_Associations
=> New_List
(
3148 New_Occurrence_Of
(Package_Name
, Loc
),
3149 New_Occurrence_Of
(Subp_Id
, Loc
),
3150 New_Occurrence_Of
(Proxy_Addr
, Loc
))),
3152 Make_Implicit_If_Statement
(N
,
3158 New_Occurrence_Of
(Origin
, Loc
),
3160 Make_Function_Call
(Loc
,
3162 RTE
(RE_Get_Local_Partition_Id
), Loc
))),
3165 New_Occurrence_Of
(All_Calls_Remote
, Loc
))),
3166 Then_Statements
=> New_List
(
3167 Make_Return_Statement
(Loc
,
3168 Unchecked_Convert_To
(Fat_Type
,
3169 OK_Convert_To
(RTE
(RE_Address
),
3170 New_Occurrence_Of
(Proxy_Addr
, Loc
)))))),
3172 Set_Field
(Name_Origin
,
3173 New_Occurrence_Of
(Origin
, Loc
)),
3175 Set_Field
(Name_Receiver
,
3176 Make_Function_Call
(Loc
,
3178 New_Occurrence_Of
(RTE
(RE_Get_RCI_Package_Receiver
), Loc
),
3179 Parameter_Associations
=> New_List
(
3180 New_Occurrence_Of
(Package_Name
, Loc
)))),
3182 Set_Field
(Name_Addr
, New_Occurrence_Of
(Proxy_Addr
, Loc
)),
3184 -- E.4.1(9) A remote call is asynchronous if it is a call to
3185 -- a procedure, or a call through a value of an access-to-procedure
3186 -- type, to which a pragma Asynchronous applies.
3188 -- Parameter Asynch_P is true when the procedure is asynchronous;
3189 -- Expression Asynch_T is true when the type is asynchronous.
3191 Set_Field
(Name_Asynchronous
,
3193 New_Occurrence_Of
(Asynch_P
, Loc
),
3194 New_Occurrence_Of
(Boolean_Literals
(
3195 Is_Asynchronous
(Ras_Type
)), Loc
))));
3197 Append_List_To
(Proc_Statements
,
3198 Build_Get_Unique_RP_Call
3199 (Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
3201 -- Return the newly created value
3203 Append_To
(Proc_Statements
,
3204 Make_Return_Statement
(Loc
,
3206 Unchecked_Convert_To
(Fat_Type
,
3207 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
3210 Make_Function_Specification
(Loc
,
3211 Defining_Unit_Name
=> Proc
,
3212 Parameter_Specifications
=> New_List
(
3213 Make_Parameter_Specification
(Loc
,
3214 Defining_Identifier
=> Package_Name
,
3216 New_Occurrence_Of
(Standard_String
, Loc
)),
3218 Make_Parameter_Specification
(Loc
,
3219 Defining_Identifier
=> Subp_Id
,
3221 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
)),
3223 Make_Parameter_Specification
(Loc
,
3224 Defining_Identifier
=> Asynch_P
,
3226 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3228 Make_Parameter_Specification
(Loc
,
3229 Defining_Identifier
=> All_Calls_Remote
,
3231 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
3233 Result_Definition
=>
3234 New_Occurrence_Of
(Fat_Type
, Loc
));
3236 -- Set the kind and return type of the function to prevent
3237 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3239 Set_Ekind
(Proc
, E_Function
);
3240 Set_Etype
(Proc
, Fat_Type
);
3243 Make_Subprogram_Body
(Loc
,
3244 Specification
=> Proc_Spec
,
3245 Declarations
=> Proc_Decls
,
3246 Handled_Statement_Sequence
=>
3247 Make_Handled_Sequence_Of_Statements
(Loc
,
3248 Statements
=> Proc_Statements
)));
3250 Set_TSS
(Fat_Type
, Proc
);
3251 end Add_RAS_Access_TSS
;
3253 -----------------------
3254 -- Add_RAST_Features --
3255 -----------------------
3257 procedure Add_RAST_Features
3258 (Vis_Decl
: Node_Id
;
3259 RAS_Type
: Entity_Id
)
3261 pragma Warnings
(Off
);
3262 pragma Unreferenced
(RAS_Type
);
3263 pragma Warnings
(On
);
3265 Add_RAS_Access_TSS
(Vis_Decl
);
3266 end Add_RAST_Features
;
3268 -----------------------------------------
3269 -- Add_Receiving_Stubs_To_Declarations --
3270 -----------------------------------------
3272 procedure Add_Receiving_Stubs_To_Declarations
3273 (Pkg_Spec
: Node_Id
;
3276 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
3278 Request_Parameter
: Node_Id
;
3280 Pkg_RPC_Receiver
: constant Entity_Id
:=
3281 Make_Defining_Identifier
(Loc
,
3282 New_Internal_Name
('H'));
3283 Pkg_RPC_Receiver_Statements
: List_Id
;
3284 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
3285 Pkg_RPC_Receiver_Body
: Node_Id
;
3286 -- A Pkg_RPC_Receiver is built to decode the request
3288 Lookup_RAS_Info
: constant Entity_Id
:=
3289 Make_Defining_Identifier
(Loc
,
3290 Chars
=> New_Internal_Name
('R'));
3291 -- A remote subprogram is created to allow peers to look up
3292 -- RAS information using subprogram ids.
3294 Subp_Id
: Entity_Id
;
3295 Subp_Index
: Entity_Id
;
3296 -- Subprogram_Id as read from the incoming stream
3298 Current_Declaration
: Node_Id
;
3299 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
3300 Current_Stubs
: Node_Id
;
3302 Subp_Info_Array
: constant Entity_Id
:=
3303 Make_Defining_Identifier
(Loc
,
3304 Chars
=> New_Internal_Name
('I'));
3306 Subp_Info_List
: constant List_Id
:= New_List
;
3308 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
3310 All_Calls_Remote_E
: Entity_Id
;
3311 Proxy_Object_Addr
: Entity_Id
;
3313 procedure Append_Stubs_To
3314 (RPC_Receiver_Cases
: List_Id
;
3316 Subprogram_Number
: Int
);
3317 -- Add one case to the specified RPC receiver case list
3318 -- associating Subprogram_Number with the subprogram declared
3319 -- by Declaration, for which we have receiving stubs in Stubs.
3321 ---------------------
3322 -- Append_Stubs_To --
3323 ---------------------
3325 procedure Append_Stubs_To
3326 (RPC_Receiver_Cases
: List_Id
;
3328 Subprogram_Number
: Int
)
3331 Append_To
(RPC_Receiver_Cases
,
3332 Make_Case_Statement_Alternative
(Loc
,
3334 New_List
(Make_Integer_Literal
(Loc
, Subprogram_Number
)),
3337 Make_Procedure_Call_Statement
(Loc
,
3340 Defining_Entity
(Stubs
), Loc
),
3341 Parameter_Associations
=> New_List
(
3342 New_Occurrence_Of
(Request_Parameter
, Loc
))))));
3343 end Append_Stubs_To
;
3345 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3348 -- Building receiving stubs consist in several operations:
3350 -- - a package RPC receiver must be built. This subprogram
3351 -- will get a Subprogram_Id from the incoming stream
3352 -- and will dispatch the call to the right subprogram
3354 -- - a receiving stub for any subprogram visible in the package
3355 -- spec. This stub will read all the parameters from the stream,
3356 -- and put the result as well as the exception occurrence in the
3359 -- - a dummy package with an empty spec and a body made of an
3360 -- elaboration part, whose job is to register the receiving
3361 -- part of this RCI package on the name server. This is done
3362 -- by calling System.Partition_Interface.Register_Receiving_Stub
3364 Build_RPC_Receiver_Body
(
3365 RPC_Receiver
=> Pkg_RPC_Receiver
,
3366 Request
=> Request_Parameter
,
3368 Subp_Index
=> Subp_Index
,
3369 Stmts
=> Pkg_RPC_Receiver_Statements
,
3370 Decl
=> Pkg_RPC_Receiver_Body
);
3371 pragma Assert
(Subp_Id
= Subp_Index
);
3373 -- A null subp_id denotes a call through a RAS, in which case the
3374 -- next Uint_64 element in the stream is the address of the local
3375 -- proxy object, from which we can retrieve the actual subprogram id.
3377 Append_To
(Pkg_RPC_Receiver_Statements
,
3378 Make_Implicit_If_Statement
(Pkg_Spec
,
3381 New_Occurrence_Of
(Subp_Id
, Loc
),
3382 Make_Integer_Literal
(Loc
, 0)),
3383 Then_Statements
=> New_List
(
3384 Make_Assignment_Statement
(Loc
,
3386 New_Occurrence_Of
(Subp_Id
, Loc
),
3388 Make_Selected_Component
(Loc
,
3390 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
3391 OK_Convert_To
(RTE
(RE_Address
),
3392 Make_Attribute_Reference
(Loc
,
3394 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3397 Expressions
=> New_List
(
3398 Make_Selected_Component
(Loc
,
3399 Prefix
=> Request_Parameter
,
3400 Selector_Name
=> Name_Params
))))),
3402 Make_Identifier
(Loc
, Name_Subp_Id
))))));
3404 -- Build a subprogram for RAS information lookups
3406 Current_Declaration
:=
3407 Make_Subprogram_Declaration
(Loc
,
3409 Make_Function_Specification
(Loc
,
3410 Defining_Unit_Name
=>
3412 Parameter_Specifications
=> New_List
(
3413 Make_Parameter_Specification
(Loc
,
3414 Defining_Identifier
=>
3415 Make_Defining_Identifier
(Loc
, Name_Subp_Id
),
3419 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))),
3420 Result_Definition
=>
3421 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)));
3422 Append_To
(Decls
, Current_Declaration
);
3423 Analyze
(Current_Declaration
);
3425 Current_Stubs
:= Build_Subprogram_Receiving_Stubs
3426 (Vis_Decl
=> Current_Declaration
,
3427 Asynchronous
=> False);
3428 Append_To
(Decls
, Current_Stubs
);
3429 Analyze
(Current_Stubs
);
3431 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3434 Subprogram_Number
=> 1);
3436 -- For each subprogram, the receiving stub will be built and a
3437 -- case statement will be made on the Subprogram_Id to dispatch
3438 -- to the right subprogram.
3440 All_Calls_Remote_E
:= Boolean_Literals
(
3441 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
3443 Overload_Counter_Table
.Reset
;
3445 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
3446 while Present
(Current_Declaration
) loop
3447 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
3448 and then Comes_From_Source
(Current_Declaration
)
3451 Loc
: constant Source_Ptr
:=
3452 Sloc
(Current_Declaration
);
3453 -- While specifically processing Current_Declaration, use
3454 -- its Sloc as the location of all generated nodes.
3456 Subp_Def
: constant Entity_Id
:=
3458 (Specification
(Current_Declaration
));
3460 Subp_Val
: String_Id
;
3463 pragma Assert
(Current_Subprogram_Number
=
3464 Get_Subprogram_Id
(Subp_Def
));
3466 -- Build receiving stub
3469 Build_Subprogram_Receiving_Stubs
3470 (Vis_Decl
=> Current_Declaration
,
3472 Nkind
(Specification
(Current_Declaration
)) =
3473 N_Procedure_Specification
3474 and then Is_Asynchronous
(Subp_Def
));
3476 Append_To
(Decls
, Current_Stubs
);
3477 Analyze
(Current_Stubs
);
3481 Add_RAS_Proxy_And_Analyze
(Decls
,
3483 Current_Declaration
,
3484 All_Calls_Remote_E
=>
3486 Proxy_Object_Addr
=>
3489 -- Compute distribution identifier
3491 Assign_Subprogram_Identifier
(
3493 Current_Subprogram_Number
,
3496 -- Add subprogram descriptor (RCI_Subp_Info) to the
3497 -- subprograms table for this receiver. The aggregate
3498 -- below must be kept consistent with the declaration
3499 -- of type RCI_Subp_Info in System.Partition_Interface.
3501 Append_To
(Subp_Info_List
,
3502 Make_Component_Association
(Loc
,
3503 Choices
=> New_List
(
3504 Make_Integer_Literal
(Loc
,
3505 Current_Subprogram_Number
)),
3507 Make_Aggregate
(Loc
,
3508 Component_Associations
=> New_List
(
3509 Make_Component_Association
(Loc
,
3510 Choices
=> New_List
(
3511 Make_Identifier
(Loc
, Name_Addr
)),
3514 Proxy_Object_Addr
, Loc
))))));
3516 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3519 Subprogram_Number
=>
3520 Current_Subprogram_Number
);
3523 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
3526 Next
(Current_Declaration
);
3529 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3530 -- rather than raising an exception since we do not want someone
3531 -- to crash a remote partition by sending invalid subprogram ids.
3532 -- This is consistent with the other parts of the case statement
3533 -- since even in presence of incorrect parameters in the stream,
3534 -- every exception will be caught and (if the subprogram is not an
3535 -- APC) put into the result stream and sent away.
3537 Append_To
(Pkg_RPC_Receiver_Cases
,
3538 Make_Case_Statement_Alternative
(Loc
,
3540 New_List
(Make_Others_Choice
(Loc
)),
3542 New_List
(Make_Null_Statement
(Loc
))));
3544 Append_To
(Pkg_RPC_Receiver_Statements
,
3545 Make_Case_Statement
(Loc
,
3547 New_Occurrence_Of
(Subp_Id
, Loc
),
3548 Alternatives
=> Pkg_RPC_Receiver_Cases
));
3551 Make_Object_Declaration
(Loc
,
3552 Defining_Identifier
=> Subp_Info_Array
,
3553 Constant_Present
=> True,
3554 Aliased_Present
=> True,
3555 Object_Definition
=>
3556 Make_Subtype_Indication
(Loc
,
3558 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
3560 Make_Index_Or_Discriminant_Constraint
(Loc
,
3563 Low_Bound
=> Make_Integer_Literal
(Loc
,
3564 First_RCI_Subprogram_Id
),
3566 Make_Integer_Literal
(Loc
,
3567 First_RCI_Subprogram_Id
3568 + List_Length
(Subp_Info_List
) - 1))))),
3570 Make_Aggregate
(Loc
,
3571 Component_Associations
=> Subp_Info_List
)));
3572 Analyze
(Last
(Decls
));
3575 Make_Subprogram_Body
(Loc
,
3577 Copy_Specification
(Loc
, Parent
(Lookup_RAS_Info
)),
3580 Handled_Statement_Sequence
=>
3581 Make_Handled_Sequence_Of_Statements
(Loc
,
3582 Statements
=> New_List
(
3583 Make_Return_Statement
(Loc
,
3584 Expression
=> OK_Convert_To
(RTE
(RE_Unsigned_64
),
3585 Make_Selected_Component
(Loc
,
3587 Make_Indexed_Component
(Loc
,
3589 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3590 Expressions
=> New_List
(
3591 Convert_To
(Standard_Integer
,
3592 Make_Identifier
(Loc
, Name_Subp_Id
)))),
3594 Make_Identifier
(Loc
, Name_Addr
))))))));
3595 Analyze
(Last
(Decls
));
3597 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
3598 Analyze
(Last
(Decls
));
3600 Get_Library_Unit_Name_String
(Pkg_Spec
);
3601 Append_To
(Register_Pkg_Actuals
,
3603 Make_String_Literal
(Loc
,
3604 Strval
=> String_From_Name_Buffer
));
3606 Append_To
(Register_Pkg_Actuals
,
3608 Make_Attribute_Reference
(Loc
,
3610 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
3612 Name_Unrestricted_Access
));
3614 Append_To
(Register_Pkg_Actuals
,
3616 Make_Attribute_Reference
(Loc
,
3618 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
3622 Append_To
(Register_Pkg_Actuals
,
3624 Make_Attribute_Reference
(Loc
,
3626 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3630 Append_To
(Register_Pkg_Actuals
,
3632 Make_Attribute_Reference
(Loc
,
3634 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3639 Make_Procedure_Call_Statement
(Loc
,
3641 New_Occurrence_Of
(RTE
(RE_Register_Receiving_Stub
), Loc
),
3642 Parameter_Associations
=> Register_Pkg_Actuals
));
3643 Analyze
(Last
(Decls
));
3644 end Add_Receiving_Stubs_To_Declarations
;
3646 ---------------------------------
3647 -- Build_General_Calling_Stubs --
3648 ---------------------------------
3650 procedure Build_General_Calling_Stubs
3652 Statements
: List_Id
;
3653 Target_Partition
: Entity_Id
;
3654 Target_RPC_Receiver
: Node_Id
;
3655 Subprogram_Id
: Node_Id
;
3656 Asynchronous
: Node_Id
:= Empty
;
3657 Is_Known_Asynchronous
: Boolean := False;
3658 Is_Known_Non_Asynchronous
: Boolean := False;
3659 Is_Function
: Boolean;
3661 Stub_Type
: Entity_Id
:= Empty
;
3662 RACW_Type
: Entity_Id
:= Empty
;
3665 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
3667 Stream_Parameter
: Node_Id
;
3668 -- Name of the stream used to transmit parameters to the
3671 Result_Parameter
: Node_Id
;
3672 -- Name of the result parameter (in non-APC cases) which get the
3673 -- result of the remote subprogram.
3675 Exception_Return_Parameter
: Node_Id
;
3676 -- Name of the parameter which will hold the exception sent by the
3677 -- remote subprogram.
3679 Current_Parameter
: Node_Id
;
3680 -- Current parameter being handled
3682 Ordered_Parameters_List
: constant List_Id
:=
3683 Build_Ordered_Parameters_List
(Spec
);
3685 Asynchronous_Statements
: List_Id
:= No_List
;
3686 Non_Asynchronous_Statements
: List_Id
:= No_List
;
3687 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
3689 Extra_Formal_Statements
: constant List_Id
:= New_List
;
3690 -- List of statements for extra formal parameters. It will appear
3691 -- after the regular statements for writing out parameters.
3693 pragma Warnings
(Off
);
3694 pragma Unreferenced
(RACW_Type
);
3695 -- Used only for the PolyORB case
3696 pragma Warnings
(On
);
3699 -- The general form of a calling stub for a given subprogram is:
3701 -- procedure X (...) is P : constant Partition_ID :=
3702 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
3703 -- System.RPC.Params_Stream_Type (0); begin
3704 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
3705 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
3706 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
3707 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
3709 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
3711 -- There are some variations: Do_APC is called for an asynchronous
3712 -- procedure and the part after the call is completely ommitted as
3713 -- well as the declaration of Result. For a function call, 'Input is
3714 -- always used to read the result even if it is constrained.
3717 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
3720 Make_Object_Declaration
(Loc
,
3721 Defining_Identifier
=> Stream_Parameter
,
3722 Aliased_Present
=> True,
3723 Object_Definition
=>
3724 Make_Subtype_Indication
(Loc
,
3726 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
3728 Make_Index_Or_Discriminant_Constraint
(Loc
,
3730 New_List
(Make_Integer_Literal
(Loc
, 0))))));
3732 if not Is_Known_Asynchronous
then
3734 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
3737 Make_Object_Declaration
(Loc
,
3738 Defining_Identifier
=> Result_Parameter
,
3739 Aliased_Present
=> True,
3740 Object_Definition
=>
3741 Make_Subtype_Indication
(Loc
,
3743 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
3745 Make_Index_Or_Discriminant_Constraint
(Loc
,
3747 New_List
(Make_Integer_Literal
(Loc
, 0))))));
3749 Exception_Return_Parameter
:=
3750 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
3753 Make_Object_Declaration
(Loc
,
3754 Defining_Identifier
=> Exception_Return_Parameter
,
3755 Object_Definition
=>
3756 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
3759 Result_Parameter
:= Empty
;
3760 Exception_Return_Parameter
:= Empty
;
3763 -- Put first the RPC receiver corresponding to the remote package
3765 Append_To
(Statements
,
3766 Make_Attribute_Reference
(Loc
,
3768 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3769 Attribute_Name
=> Name_Write
,
3770 Expressions
=> New_List
(
3771 Make_Attribute_Reference
(Loc
,
3773 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3776 Target_RPC_Receiver
)));
3778 -- Then put the Subprogram_Id of the subprogram we want to call in
3781 Append_To
(Statements
,
3782 Make_Attribute_Reference
(Loc
,
3784 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
3787 Expressions
=> New_List
(
3788 Make_Attribute_Reference
(Loc
,
3790 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3791 Attribute_Name
=> Name_Access
),
3794 Current_Parameter
:= First
(Ordered_Parameters_List
);
3795 while Present
(Current_Parameter
) loop
3797 Typ
: constant Node_Id
:=
3798 Parameter_Type
(Current_Parameter
);
3800 Constrained
: Boolean;
3802 Extra_Parameter
: Entity_Id
;
3805 if Is_RACW_Controlling_Formal
3806 (Current_Parameter
, Stub_Type
)
3808 -- In the case of a controlling formal argument, we marshall
3809 -- its addr field rather than the local stub.
3811 Append_To
(Statements
,
3812 Pack_Node_Into_Stream
(Loc
,
3813 Stream
=> Stream_Parameter
,
3815 Make_Selected_Component
(Loc
,
3817 Defining_Identifier
(Current_Parameter
),
3818 Selector_Name
=> Name_Addr
),
3819 Etyp
=> RTE
(RE_Unsigned_64
)));
3822 Value
:= New_Occurrence_Of
3823 (Defining_Identifier
(Current_Parameter
), Loc
);
3825 -- Access type parameters are transmitted as in out
3826 -- parameters. However, a dereference is needed so that
3827 -- we marshall the designated object.
3829 if Nkind
(Typ
) = N_Access_Definition
then
3830 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
3831 Etyp
:= Etype
(Subtype_Mark
(Typ
));
3833 Etyp
:= Etype
(Typ
);
3837 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
3839 -- Any parameter but unconstrained out parameters are
3840 -- transmitted to the peer.
3842 if In_Present
(Current_Parameter
)
3843 or else not Out_Present
(Current_Parameter
)
3844 or else not Constrained
3846 Append_To
(Statements
,
3847 Make_Attribute_Reference
(Loc
,
3849 New_Occurrence_Of
(Etyp
, Loc
),
3851 Output_From_Constrained
(Constrained
),
3852 Expressions
=> New_List
(
3853 Make_Attribute_Reference
(Loc
,
3855 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3856 Attribute_Name
=> Name_Access
),
3861 -- If the current parameter has a dynamic constrained status,
3862 -- then this status is transmitted as well.
3863 -- This should be done for accessibility as well ???
3865 if Nkind
(Typ
) /= N_Access_Definition
3866 and then Need_Extra_Constrained
(Current_Parameter
)
3868 -- In this block, we do not use the extra formal that has
3869 -- been created because it does not exist at the time of
3870 -- expansion when building calling stubs for remote access
3871 -- to subprogram types. We create an extra variable of this
3872 -- type and push it in the stream after the regular
3875 Extra_Parameter
:= Make_Defining_Identifier
3876 (Loc
, New_Internal_Name
('P'));
3879 Make_Object_Declaration
(Loc
,
3880 Defining_Identifier
=> Extra_Parameter
,
3881 Constant_Present
=> True,
3882 Object_Definition
=>
3883 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3885 Make_Attribute_Reference
(Loc
,
3888 Defining_Identifier
(Current_Parameter
), Loc
),
3889 Attribute_Name
=> Name_Constrained
)));
3891 Append_To
(Extra_Formal_Statements
,
3892 Make_Attribute_Reference
(Loc
,
3894 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3897 Expressions
=> New_List
(
3898 Make_Attribute_Reference
(Loc
,
3900 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3903 New_Occurrence_Of
(Extra_Parameter
, Loc
))));
3906 Next
(Current_Parameter
);
3910 -- Append the formal statements list to the statements
3912 Append_List_To
(Statements
, Extra_Formal_Statements
);
3914 if not Is_Known_Non_Asynchronous
then
3916 -- Build the call to System.RPC.Do_APC
3918 Asynchronous_Statements
:= New_List
(
3919 Make_Procedure_Call_Statement
(Loc
,
3921 New_Occurrence_Of
(RTE
(RE_Do_Apc
), Loc
),
3922 Parameter_Associations
=> New_List
(
3923 New_Occurrence_Of
(Target_Partition
, Loc
),
3924 Make_Attribute_Reference
(Loc
,
3926 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3930 Asynchronous_Statements
:= No_List
;
3933 if not Is_Known_Asynchronous
then
3935 -- Build the call to System.RPC.Do_RPC
3937 Non_Asynchronous_Statements
:= New_List
(
3938 Make_Procedure_Call_Statement
(Loc
,
3940 New_Occurrence_Of
(RTE
(RE_Do_Rpc
), Loc
),
3941 Parameter_Associations
=> New_List
(
3942 New_Occurrence_Of
(Target_Partition
, Loc
),
3944 Make_Attribute_Reference
(Loc
,
3946 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3950 Make_Attribute_Reference
(Loc
,
3952 New_Occurrence_Of
(Result_Parameter
, Loc
),
3956 -- Read the exception occurrence from the result stream and
3957 -- reraise it. It does no harm if this is a Null_Occurrence since
3958 -- this does nothing.
3960 Append_To
(Non_Asynchronous_Statements
,
3961 Make_Attribute_Reference
(Loc
,
3963 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
3968 Expressions
=> New_List
(
3969 Make_Attribute_Reference
(Loc
,
3971 New_Occurrence_Of
(Result_Parameter
, Loc
),
3974 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
3976 Append_To
(Non_Asynchronous_Statements
,
3977 Make_Procedure_Call_Statement
(Loc
,
3979 New_Occurrence_Of
(RTE
(RE_Reraise_Occurrence
), Loc
),
3980 Parameter_Associations
=> New_List
(
3981 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
3985 -- If this is a function call, then read the value and return
3986 -- it. The return value is written/read using 'Output/'Input.
3988 Append_To
(Non_Asynchronous_Statements
,
3989 Make_Tag_Check
(Loc
,
3990 Make_Return_Statement
(Loc
,
3992 Make_Attribute_Reference
(Loc
,
3995 Etype
(Result_Definition
(Spec
)), Loc
),
3997 Attribute_Name
=> Name_Input
,
3999 Expressions
=> New_List
(
4000 Make_Attribute_Reference
(Loc
,
4002 New_Occurrence_Of
(Result_Parameter
, Loc
),
4003 Attribute_Name
=> Name_Access
))))));
4006 -- Loop around parameters and assign out (or in out)
4007 -- parameters. In the case of RACW, controlling arguments
4008 -- cannot possibly have changed since they are remote, so we do
4009 -- not read them from the stream.
4011 Current_Parameter
:= First
(Ordered_Parameters_List
);
4012 while Present
(Current_Parameter
) loop
4014 Typ
: constant Node_Id
:=
4015 Parameter_Type
(Current_Parameter
);
4022 (Defining_Identifier
(Current_Parameter
), Loc
);
4024 if Nkind
(Typ
) = N_Access_Definition
then
4025 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4026 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4028 Etyp
:= Etype
(Typ
);
4031 if (Out_Present
(Current_Parameter
)
4032 or else Nkind
(Typ
) = N_Access_Definition
)
4033 and then Etyp
/= Stub_Type
4035 Append_To
(Non_Asynchronous_Statements
,
4036 Make_Attribute_Reference
(Loc
,
4038 New_Occurrence_Of
(Etyp
, Loc
),
4040 Attribute_Name
=> Name_Read
,
4042 Expressions
=> New_List
(
4043 Make_Attribute_Reference
(Loc
,
4045 New_Occurrence_Of
(Result_Parameter
, Loc
),
4052 Next
(Current_Parameter
);
4057 if Is_Known_Asynchronous
then
4058 Append_List_To
(Statements
, Asynchronous_Statements
);
4060 elsif Is_Known_Non_Asynchronous
then
4061 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
4064 pragma Assert
(Present
(Asynchronous
));
4065 Prepend_To
(Asynchronous_Statements
,
4066 Make_Attribute_Reference
(Loc
,
4067 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4068 Attribute_Name
=> Name_Write
,
4069 Expressions
=> New_List
(
4070 Make_Attribute_Reference
(Loc
,
4072 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4073 Attribute_Name
=> Name_Access
),
4074 New_Occurrence_Of
(Standard_True
, Loc
))));
4076 Prepend_To
(Non_Asynchronous_Statements
,
4077 Make_Attribute_Reference
(Loc
,
4078 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4079 Attribute_Name
=> Name_Write
,
4080 Expressions
=> New_List
(
4081 Make_Attribute_Reference
(Loc
,
4083 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4084 Attribute_Name
=> Name_Access
),
4085 New_Occurrence_Of
(Standard_False
, Loc
))));
4087 Append_To
(Statements
,
4088 Make_Implicit_If_Statement
(Nod
,
4089 Condition
=> Asynchronous
,
4090 Then_Statements
=> Asynchronous_Statements
,
4091 Else_Statements
=> Non_Asynchronous_Statements
));
4093 end Build_General_Calling_Stubs
;
4095 -----------------------------
4096 -- Build_RPC_Receiver_Body --
4097 -----------------------------
4099 procedure Build_RPC_Receiver_Body
4100 (RPC_Receiver
: Entity_Id
;
4101 Request
: out Entity_Id
;
4102 Subp_Id
: out Entity_Id
;
4103 Subp_Index
: out Entity_Id
;
4104 Stmts
: out List_Id
;
4107 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
4109 RPC_Receiver_Spec
: Node_Id
;
4110 RPC_Receiver_Decls
: List_Id
;
4113 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
4115 RPC_Receiver_Spec
:=
4116 Build_RPC_Receiver_Specification
4117 (RPC_Receiver
=> RPC_Receiver
,
4118 Request_Parameter
=> Request
);
4120 Subp_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4121 Subp_Index
:= Subp_Id
;
4123 -- Subp_Id may not be a constant, because in the case of the RPC
4124 -- receiver for an RCI package, when a call is received from a RAS
4125 -- dereference, it will be assigned during subsequent processing.
4127 RPC_Receiver_Decls
:= New_List
(
4128 Make_Object_Declaration
(Loc
,
4129 Defining_Identifier
=> Subp_Id
,
4130 Object_Definition
=>
4131 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4133 Make_Attribute_Reference
(Loc
,
4135 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4136 Attribute_Name
=> Name_Input
,
4137 Expressions
=> New_List
(
4138 Make_Selected_Component
(Loc
,
4140 Selector_Name
=> Name_Params
)))));
4145 Make_Subprogram_Body
(Loc
,
4146 Specification
=> RPC_Receiver_Spec
,
4147 Declarations
=> RPC_Receiver_Decls
,
4148 Handled_Statement_Sequence
=>
4149 Make_Handled_Sequence_Of_Statements
(Loc
,
4150 Statements
=> Stmts
));
4151 end Build_RPC_Receiver_Body
;
4153 -----------------------
4154 -- Build_Stub_Target --
4155 -----------------------
4157 function Build_Stub_Target
4160 RCI_Locator
: Entity_Id
;
4161 Controlling_Parameter
: Entity_Id
) return RPC_Target
4163 Target_Info
: RPC_Target
(PCS_Kind
=> Name_GARLIC_DSA
);
4165 Target_Info
.Partition
:=
4166 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4167 if Present
(Controlling_Parameter
) then
4169 Make_Object_Declaration
(Loc
,
4170 Defining_Identifier
=> Target_Info
.Partition
,
4171 Constant_Present
=> True,
4172 Object_Definition
=>
4173 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4176 Make_Selected_Component
(Loc
,
4177 Prefix
=> Controlling_Parameter
,
4178 Selector_Name
=> Name_Origin
)));
4180 Target_Info
.RPC_Receiver
:=
4181 Make_Selected_Component
(Loc
,
4182 Prefix
=> Controlling_Parameter
,
4183 Selector_Name
=> Name_Receiver
);
4187 Make_Object_Declaration
(Loc
,
4188 Defining_Identifier
=> Target_Info
.Partition
,
4189 Constant_Present
=> True,
4190 Object_Definition
=>
4191 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4194 Make_Function_Call
(Loc
,
4195 Name
=> Make_Selected_Component
(Loc
,
4197 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4199 Make_Identifier
(Loc
,
4200 Name_Get_Active_Partition_ID
)))));
4202 Target_Info
.RPC_Receiver
:=
4203 Make_Selected_Component
(Loc
,
4205 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4207 Make_Identifier
(Loc
, Name_Get_RCI_Package_Receiver
));
4210 end Build_Stub_Target
;
4212 ---------------------
4213 -- Build_Stub_Type --
4214 ---------------------
4216 procedure Build_Stub_Type
4217 (RACW_Type
: Entity_Id
;
4218 Stub_Type
: Entity_Id
;
4219 Stub_Type_Decl
: out Node_Id
;
4220 RPC_Receiver_Decl
: out Node_Id
)
4222 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
4223 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
4227 Make_Full_Type_Declaration
(Loc
,
4228 Defining_Identifier
=> Stub_Type
,
4230 Make_Record_Definition
(Loc
,
4231 Tagged_Present
=> True,
4232 Limited_Present
=> True,
4234 Make_Component_List
(Loc
,
4235 Component_Items
=> New_List
(
4237 Make_Component_Declaration
(Loc
,
4238 Defining_Identifier
=>
4239 Make_Defining_Identifier
(Loc
, Name_Origin
),
4240 Component_Definition
=>
4241 Make_Component_Definition
(Loc
,
4242 Aliased_Present
=> False,
4243 Subtype_Indication
=>
4245 RTE
(RE_Partition_ID
), Loc
))),
4247 Make_Component_Declaration
(Loc
,
4248 Defining_Identifier
=>
4249 Make_Defining_Identifier
(Loc
, Name_Receiver
),
4250 Component_Definition
=>
4251 Make_Component_Definition
(Loc
,
4252 Aliased_Present
=> False,
4253 Subtype_Indication
=>
4254 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4256 Make_Component_Declaration
(Loc
,
4257 Defining_Identifier
=>
4258 Make_Defining_Identifier
(Loc
, Name_Addr
),
4259 Component_Definition
=>
4260 Make_Component_Definition
(Loc
,
4261 Aliased_Present
=> False,
4262 Subtype_Indication
=>
4263 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4265 Make_Component_Declaration
(Loc
,
4266 Defining_Identifier
=>
4267 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
4268 Component_Definition
=>
4269 Make_Component_Definition
(Loc
,
4270 Aliased_Present
=> False,
4271 Subtype_Indication
=>
4273 Standard_Boolean
, Loc
)))))));
4276 RPC_Receiver_Decl
:= Empty
;
4279 RPC_Receiver_Request
: constant Entity_Id
:=
4280 Make_Defining_Identifier
(Loc
, Name_R
);
4282 RPC_Receiver_Decl
:=
4283 Make_Subprogram_Declaration
(Loc
,
4284 Build_RPC_Receiver_Specification
(
4285 RPC_Receiver
=> Make_Defining_Identifier
(Loc
,
4286 New_Internal_Name
('R')),
4287 Request_Parameter
=> RPC_Receiver_Request
));
4290 end Build_Stub_Type
;
4292 --------------------------------------
4293 -- Build_Subprogram_Receiving_Stubs --
4294 --------------------------------------
4296 function Build_Subprogram_Receiving_Stubs
4297 (Vis_Decl
: Node_Id
;
4298 Asynchronous
: Boolean;
4299 Dynamically_Asynchronous
: Boolean := False;
4300 Stub_Type
: Entity_Id
:= Empty
;
4301 RACW_Type
: Entity_Id
:= Empty
;
4302 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
4304 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
4306 Request_Parameter
: Node_Id
;
4309 Decls
: constant List_Id
:= New_List
;
4310 -- All the parameters will get declared before calling the real
4311 -- subprograms. Also the out parameters will be declared.
4313 Statements
: constant List_Id
:= New_List
;
4315 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4316 -- Statements concerning extra formal parameters
4318 After_Statements
: constant List_Id
:= New_List
;
4319 -- Statements to be executed after the subprogram call
4321 Inner_Decls
: List_Id
:= No_List
;
4322 -- In case of a function, the inner declarations are needed since
4323 -- the result may be unconstrained.
4325 Excep_Handlers
: List_Id
:= No_List
;
4326 Excep_Choice
: Entity_Id
;
4327 Excep_Code
: List_Id
;
4329 Parameter_List
: constant List_Id
:= New_List
;
4330 -- List of parameters to be passed to the subprogram
4332 Current_Parameter
: Node_Id
;
4334 Ordered_Parameters_List
: constant List_Id
:=
4335 Build_Ordered_Parameters_List
4336 (Specification
(Vis_Decl
));
4338 Subp_Spec
: Node_Id
;
4339 -- Subprogram specification
4341 Called_Subprogram
: Node_Id
;
4342 -- The subprogram to call
4344 Null_Raise_Statement
: Node_Id
;
4346 Dynamic_Async
: Entity_Id
;
4349 if Present
(RACW_Type
) then
4350 Called_Subprogram
:=
4351 New_Occurrence_Of
(Parent_Primitive
, Loc
);
4353 Called_Subprogram
:=
4355 Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
4358 Request_Parameter
:=
4359 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4361 if Dynamically_Asynchronous
then
4363 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
4365 Dynamic_Async
:= Empty
;
4368 if not Asynchronous
or Dynamically_Asynchronous
then
4370 -- The first statement after the subprogram call is a statement to
4371 -- writes a Null_Occurrence into the result stream.
4373 Null_Raise_Statement
:=
4374 Make_Attribute_Reference
(Loc
,
4376 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4377 Attribute_Name
=> Name_Write
,
4378 Expressions
=> New_List
(
4379 Make_Selected_Component
(Loc
,
4380 Prefix
=> Request_Parameter
,
4381 Selector_Name
=> Name_Result
),
4382 New_Occurrence_Of
(RTE
(RE_Null_Occurrence
), Loc
)));
4384 if Dynamically_Asynchronous
then
4385 Null_Raise_Statement
:=
4386 Make_Implicit_If_Statement
(Vis_Decl
,
4388 Make_Op_Not
(Loc
, New_Occurrence_Of
(Dynamic_Async
, Loc
)),
4389 Then_Statements
=> New_List
(Null_Raise_Statement
));
4392 Append_To
(After_Statements
, Null_Raise_Statement
);
4395 -- Loop through every parameter and get its value from the stream. If
4396 -- the parameter is unconstrained, then the parameter is read using
4397 -- 'Input at the point of declaration.
4399 Current_Parameter
:= First
(Ordered_Parameters_List
);
4400 while Present
(Current_Parameter
) loop
4403 Constrained
: Boolean;
4405 Object
: constant Entity_Id
:=
4406 Make_Defining_Identifier
(Loc
,
4407 New_Internal_Name
('P'));
4409 Expr
: Node_Id
:= Empty
;
4411 Is_Controlling_Formal
: constant Boolean :=
4412 Is_RACW_Controlling_Formal
4413 (Current_Parameter
, Stub_Type
);
4416 Set_Ekind
(Object
, E_Variable
);
4418 if Is_Controlling_Formal
then
4420 -- We have a controlling formal parameter. Read its address
4421 -- rather than a real object. The address is in Unsigned_64
4424 Etyp
:= RTE
(RE_Unsigned_64
);
4426 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
4430 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
4432 if In_Present
(Current_Parameter
)
4433 or else not Out_Present
(Current_Parameter
)
4434 or else not Constrained
4435 or else Is_Controlling_Formal
4437 -- If an input parameter is contrained, then its reading is
4438 -- deferred until the beginning of the subprogram body. If
4439 -- it is unconstrained, then an expression is built for
4440 -- the object declaration and the variable is set using
4441 -- 'Input instead of 'Read.
4443 if Constrained
and then not Is_Controlling_Formal
then
4444 Append_To
(Statements
,
4445 Make_Attribute_Reference
(Loc
,
4446 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4447 Attribute_Name
=> Name_Read
,
4448 Expressions
=> New_List
(
4449 Make_Selected_Component
(Loc
,
4450 Prefix
=> Request_Parameter
,
4451 Selector_Name
=> Name_Params
),
4452 New_Occurrence_Of
(Object
, Loc
))));
4455 Expr
:= Input_With_Tag_Check
(Loc
,
4457 Stream
=> Make_Selected_Component
(Loc
,
4458 Prefix
=> Request_Parameter
,
4459 Selector_Name
=> Name_Params
));
4460 Append_To
(Decls
, Expr
);
4461 Expr
:= Make_Function_Call
(Loc
,
4462 New_Occurrence_Of
(Defining_Unit_Name
4463 (Specification
(Expr
)), Loc
));
4467 -- If we do not have to output the current parameter, then it
4468 -- can well be flagged as constant. This may allow further
4469 -- optimizations done by the back end.
4472 Make_Object_Declaration
(Loc
,
4473 Defining_Identifier
=> Object
,
4474 Constant_Present
=> not Constrained
4475 and then not Out_Present
(Current_Parameter
),
4476 Object_Definition
=>
4477 New_Occurrence_Of
(Etyp
, Loc
),
4478 Expression
=> Expr
));
4480 -- An out parameter may be written back using a 'Write
4481 -- attribute instead of a 'Output because it has been
4482 -- constrained by the parameter given to the caller. Note that
4483 -- out controlling arguments in the case of a RACW are not put
4484 -- back in the stream because the pointer on them has not
4487 if Out_Present
(Current_Parameter
)
4489 Etype
(Parameter_Type
(Current_Parameter
)) /= Stub_Type
4491 Append_To
(After_Statements
,
4492 Make_Attribute_Reference
(Loc
,
4493 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4494 Attribute_Name
=> Name_Write
,
4495 Expressions
=> New_List
(
4496 Make_Selected_Component
(Loc
,
4497 Prefix
=> Request_Parameter
,
4498 Selector_Name
=> Name_Result
),
4499 New_Occurrence_Of
(Object
, Loc
))));
4502 -- For RACW controlling formals, the Etyp of Object is always
4503 -- an RACW, even if the parameter is not of an anonymous access
4504 -- type. In such case, we need to dereference it at call time.
4506 if Is_Controlling_Formal
then
4507 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
4510 Append_To
(Parameter_List
,
4511 Make_Parameter_Association
(Loc
,
4514 Defining_Identifier
(Current_Parameter
), Loc
),
4515 Explicit_Actual_Parameter
=>
4516 Make_Explicit_Dereference
(Loc
,
4517 Unchecked_Convert_To
(RACW_Type
,
4518 OK_Convert_To
(RTE
(RE_Address
),
4519 New_Occurrence_Of
(Object
, Loc
))))));
4522 Append_To
(Parameter_List
,
4523 Make_Parameter_Association
(Loc
,
4526 Defining_Identifier
(Current_Parameter
), Loc
),
4527 Explicit_Actual_Parameter
=>
4528 Unchecked_Convert_To
(RACW_Type
,
4529 OK_Convert_To
(RTE
(RE_Address
),
4530 New_Occurrence_Of
(Object
, Loc
)))));
4534 Append_To
(Parameter_List
,
4535 Make_Parameter_Association
(Loc
,
4538 Defining_Identifier
(Current_Parameter
), Loc
),
4539 Explicit_Actual_Parameter
=>
4540 New_Occurrence_Of
(Object
, Loc
)));
4543 -- If the current parameter needs an extra formal, then read it
4544 -- from the stream and set the corresponding semantic field in
4545 -- the variable. If the kind of the parameter identifier is
4546 -- E_Void, then this is a compiler generated parameter that
4547 -- doesn't need an extra constrained status.
4549 -- The case of Extra_Accessibility should also be handled ???
4551 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
4554 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
4556 Present
(Extra_Constrained
4557 (Defining_Identifier
(Current_Parameter
)))
4560 Extra_Parameter
: constant Entity_Id
:=
4562 (Defining_Identifier
4563 (Current_Parameter
));
4565 Formal_Entity
: constant Entity_Id
:=
4566 Make_Defining_Identifier
4567 (Loc
, Chars
(Extra_Parameter
));
4569 Formal_Type
: constant Entity_Id
:=
4570 Etype
(Extra_Parameter
);
4574 Make_Object_Declaration
(Loc
,
4575 Defining_Identifier
=> Formal_Entity
,
4576 Object_Definition
=>
4577 New_Occurrence_Of
(Formal_Type
, Loc
)));
4579 Append_To
(Extra_Formal_Statements
,
4580 Make_Attribute_Reference
(Loc
,
4581 Prefix
=> New_Occurrence_Of
(
4583 Attribute_Name
=> Name_Read
,
4584 Expressions
=> New_List
(
4585 Make_Selected_Component
(Loc
,
4586 Prefix
=> Request_Parameter
,
4587 Selector_Name
=> Name_Params
),
4588 New_Occurrence_Of
(Formal_Entity
, Loc
))));
4589 Set_Extra_Constrained
(Object
, Formal_Entity
);
4594 Next
(Current_Parameter
);
4597 -- Append the formal statements list at the end of regular statements
4599 Append_List_To
(Statements
, Extra_Formal_Statements
);
4601 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
4603 -- The remote subprogram is a function. We build an inner block to
4604 -- be able to hold a potentially unconstrained result in a
4608 Etyp
: constant Entity_Id
:=
4609 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
4610 Result
: constant Node_Id
:=
4611 Make_Defining_Identifier
(Loc
,
4612 New_Internal_Name
('R'));
4614 Inner_Decls
:= New_List
(
4615 Make_Object_Declaration
(Loc
,
4616 Defining_Identifier
=> Result
,
4617 Constant_Present
=> True,
4618 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
4620 Make_Function_Call
(Loc
,
4621 Name
=> Called_Subprogram
,
4622 Parameter_Associations
=> Parameter_List
)));
4624 Append_To
(After_Statements
,
4625 Make_Attribute_Reference
(Loc
,
4626 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4627 Attribute_Name
=> Name_Output
,
4628 Expressions
=> New_List
(
4629 Make_Selected_Component
(Loc
,
4630 Prefix
=> Request_Parameter
,
4631 Selector_Name
=> Name_Result
),
4632 New_Occurrence_Of
(Result
, Loc
))));
4635 Append_To
(Statements
,
4636 Make_Block_Statement
(Loc
,
4637 Declarations
=> Inner_Decls
,
4638 Handled_Statement_Sequence
=>
4639 Make_Handled_Sequence_Of_Statements
(Loc
,
4640 Statements
=> After_Statements
)));
4643 -- The remote subprogram is a procedure. We do not need any inner
4644 -- block in this case.
4646 if Dynamically_Asynchronous
then
4648 Make_Object_Declaration
(Loc
,
4649 Defining_Identifier
=> Dynamic_Async
,
4650 Object_Definition
=>
4651 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
4653 Append_To
(Statements
,
4654 Make_Attribute_Reference
(Loc
,
4655 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4656 Attribute_Name
=> Name_Read
,
4657 Expressions
=> New_List
(
4658 Make_Selected_Component
(Loc
,
4659 Prefix
=> Request_Parameter
,
4660 Selector_Name
=> Name_Params
),
4661 New_Occurrence_Of
(Dynamic_Async
, Loc
))));
4664 Append_To
(Statements
,
4665 Make_Procedure_Call_Statement
(Loc
,
4666 Name
=> Called_Subprogram
,
4667 Parameter_Associations
=> Parameter_List
));
4669 Append_List_To
(Statements
, After_Statements
);
4672 if Asynchronous
and then not Dynamically_Asynchronous
then
4674 -- For an asynchronous procedure, add a null exception handler
4676 Excep_Handlers
:= New_List
(
4677 Make_Exception_Handler
(Loc
,
4678 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
4679 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
4682 -- In the other cases, if an exception is raised, then the
4683 -- exception occurrence is copied into the output stream and
4684 -- no other output parameter is written.
4687 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
4689 Excep_Code
:= New_List
(
4690 Make_Attribute_Reference
(Loc
,
4692 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4693 Attribute_Name
=> Name_Write
,
4694 Expressions
=> New_List
(
4695 Make_Selected_Component
(Loc
,
4696 Prefix
=> Request_Parameter
,
4697 Selector_Name
=> Name_Result
),
4698 New_Occurrence_Of
(Excep_Choice
, Loc
))));
4700 if Dynamically_Asynchronous
then
4701 Excep_Code
:= New_List
(
4702 Make_Implicit_If_Statement
(Vis_Decl
,
4703 Condition
=> Make_Op_Not
(Loc
,
4704 New_Occurrence_Of
(Dynamic_Async
, Loc
)),
4705 Then_Statements
=> Excep_Code
));
4708 Excep_Handlers
:= New_List
(
4709 Make_Exception_Handler
(Loc
,
4710 Choice_Parameter
=> Excep_Choice
,
4711 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
4712 Statements
=> Excep_Code
));
4717 Make_Procedure_Specification
(Loc
,
4718 Defining_Unit_Name
=>
4719 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
4721 Parameter_Specifications
=> New_List
(
4722 Make_Parameter_Specification
(Loc
,
4723 Defining_Identifier
=> Request_Parameter
,
4725 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
4728 Make_Subprogram_Body
(Loc
,
4729 Specification
=> Subp_Spec
,
4730 Declarations
=> Decls
,
4731 Handled_Statement_Sequence
=>
4732 Make_Handled_Sequence_Of_Statements
(Loc
,
4733 Statements
=> Statements
,
4734 Exception_Handlers
=> Excep_Handlers
));
4735 end Build_Subprogram_Receiving_Stubs
;
4741 function Result
return Node_Id
is
4743 return Make_Identifier
(Loc
, Name_V
);
4746 ----------------------
4747 -- Stream_Parameter --
4748 ----------------------
4750 function Stream_Parameter
return Node_Id
is
4752 return Make_Identifier
(Loc
, Name_S
);
4753 end Stream_Parameter
;
4757 -----------------------------
4758 -- Make_Selected_Component --
4759 -----------------------------
4761 function Make_Selected_Component
4764 Selector_Name
: Name_Id
) return Node_Id
4767 return Make_Selected_Component
(Loc
,
4768 Prefix
=> New_Occurrence_Of
(Prefix
, Loc
),
4769 Selector_Name
=> Make_Identifier
(Loc
, Selector_Name
));
4770 end Make_Selected_Component
;
4772 -----------------------
4773 -- Get_Subprogram_Id --
4774 -----------------------
4776 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
is
4778 return Get_Subprogram_Ids
(Def
).Str_Identifier
;
4779 end Get_Subprogram_Id
;
4781 -----------------------
4782 -- Get_Subprogram_Id --
4783 -----------------------
4785 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
is
4787 return Get_Subprogram_Ids
(Def
).Int_Identifier
;
4788 end Get_Subprogram_Id
;
4790 ------------------------
4791 -- Get_Subprogram_Ids --
4792 ------------------------
4794 function Get_Subprogram_Ids
4795 (Def
: Entity_Id
) return Subprogram_Identifiers
4797 Result
: Subprogram_Identifiers
:=
4798 Subprogram_Identifier_Table
.Get
(Def
);
4800 Current_Declaration
: Node_Id
;
4801 Current_Subp
: Entity_Id
;
4802 Current_Subp_Str
: String_Id
;
4803 Current_Subp_Number
: Int
:= First_RCI_Subprogram_Id
;
4806 if Result
.Str_Identifier
= No_String
then
4808 -- We are looking up this subprogram's identifier outside of the
4809 -- context of generating calling or receiving stubs. Hence we are
4810 -- processing an 'Access attribute_reference for an RCI subprogram,
4811 -- for the purpose of obtaining a RAS value.
4814 (Is_Remote_Call_Interface
(Scope
(Def
))
4816 (Nkind
(Parent
(Def
)) = N_Procedure_Specification
4818 Nkind
(Parent
(Def
)) = N_Function_Specification
));
4820 Current_Declaration
:=
4821 First
(Visible_Declarations
4822 (Package_Specification_Of_Scope
(Scope
(Def
))));
4823 while Present
(Current_Declaration
) loop
4824 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
4825 and then Comes_From_Source
(Current_Declaration
)
4827 Current_Subp
:= Defining_Unit_Name
(Specification
(
4828 Current_Declaration
));
4829 Assign_Subprogram_Identifier
4830 (Current_Subp
, Current_Subp_Number
, Current_Subp_Str
);
4832 if Current_Subp
= Def
then
4833 Result
:= (Current_Subp_Str
, Current_Subp_Number
);
4836 Current_Subp_Number
:= Current_Subp_Number
+ 1;
4839 Next
(Current_Declaration
);
4843 pragma Assert
(Result
.Str_Identifier
/= No_String
);
4845 end Get_Subprogram_Ids
;
4851 function Hash
(F
: Entity_Id
) return Hash_Index
is
4853 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
4856 function Hash
(F
: Name_Id
) return Hash_Index
is
4858 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
4861 --------------------------
4862 -- Input_With_Tag_Check --
4863 --------------------------
4865 function Input_With_Tag_Check
4867 Var_Type
: Entity_Id
;
4868 Stream
: Node_Id
) return Node_Id
4872 Make_Subprogram_Body
(Loc
,
4873 Specification
=> Make_Function_Specification
(Loc
,
4874 Defining_Unit_Name
=>
4875 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S')),
4876 Result_Definition
=> New_Occurrence_Of
(Var_Type
, Loc
)),
4877 Declarations
=> No_List
,
4878 Handled_Statement_Sequence
=>
4879 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
4880 Make_Tag_Check
(Loc
,
4881 Make_Return_Statement
(Loc
,
4882 Make_Attribute_Reference
(Loc
,
4883 Prefix
=> New_Occurrence_Of
(Var_Type
, Loc
),
4884 Attribute_Name
=> Name_Input
,
4886 New_List
(Stream
)))))));
4887 end Input_With_Tag_Check
;
4889 --------------------------------
4890 -- Is_RACW_Controlling_Formal --
4891 --------------------------------
4893 function Is_RACW_Controlling_Formal
4894 (Parameter
: Node_Id
;
4895 Stub_Type
: Entity_Id
) return Boolean
4900 -- If the kind of the parameter is E_Void, then it is not a
4901 -- controlling formal (this can happen in the context of RAS).
4903 if Ekind
(Defining_Identifier
(Parameter
)) = E_Void
then
4907 -- If the parameter is not a controlling formal, then it cannot
4908 -- be possibly a RACW_Controlling_Formal.
4910 if not Is_Controlling_Formal
(Defining_Identifier
(Parameter
)) then
4914 Typ
:= Parameter_Type
(Parameter
);
4915 return (Nkind
(Typ
) = N_Access_Definition
4916 and then Etype
(Subtype_Mark
(Typ
)) = Stub_Type
)
4917 or else Etype
(Typ
) = Stub_Type
;
4918 end Is_RACW_Controlling_Formal
;
4920 --------------------
4921 -- Make_Tag_Check --
4922 --------------------
4924 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
is
4925 Occ
: constant Entity_Id
:=
4926 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
4929 return Make_Block_Statement
(Loc
,
4930 Handled_Statement_Sequence
=>
4931 Make_Handled_Sequence_Of_Statements
(Loc
,
4932 Statements
=> New_List
(N
),
4934 Exception_Handlers
=> New_List
(
4935 Make_Exception_Handler
(Loc
,
4936 Choice_Parameter
=> Occ
,
4938 Exception_Choices
=>
4939 New_List
(New_Occurrence_Of
(RTE
(RE_Tag_Error
), Loc
)),
4942 New_List
(Make_Procedure_Call_Statement
(Loc
,
4944 (RTE
(RE_Raise_Program_Error_Unknown_Tag
), Loc
),
4945 New_List
(New_Occurrence_Of
(Occ
, Loc
))))))));
4948 ----------------------------
4949 -- Need_Extra_Constrained --
4950 ----------------------------
4952 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean is
4953 Etyp
: constant Entity_Id
:= Etype
(Parameter_Type
(Parameter
));
4955 return Out_Present
(Parameter
)
4956 and then Has_Discriminants
(Etyp
)
4957 and then not Is_Constrained
(Etyp
)
4958 and then not Is_Indefinite_Subtype
(Etyp
);
4959 end Need_Extra_Constrained
;
4961 ------------------------------------
4962 -- Pack_Entity_Into_Stream_Access --
4963 ------------------------------------
4965 function Pack_Entity_Into_Stream_Access
4969 Etyp
: Entity_Id
:= Empty
) return Node_Id
4974 if Present
(Etyp
) then
4977 Typ
:= Etype
(Object
);
4981 Pack_Node_Into_Stream_Access
(Loc
,
4983 Object
=> New_Occurrence_Of
(Object
, Loc
),
4985 end Pack_Entity_Into_Stream_Access
;
4987 ---------------------------
4988 -- Pack_Node_Into_Stream --
4989 ---------------------------
4991 function Pack_Node_Into_Stream
4995 Etyp
: Entity_Id
) return Node_Id
4997 Write_Attribute
: Name_Id
:= Name_Write
;
5000 if not Is_Constrained
(Etyp
) then
5001 Write_Attribute
:= Name_Output
;
5005 Make_Attribute_Reference
(Loc
,
5006 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5007 Attribute_Name
=> Write_Attribute
,
5008 Expressions
=> New_List
(
5009 Make_Attribute_Reference
(Loc
,
5010 Prefix
=> New_Occurrence_Of
(Stream
, Loc
),
5011 Attribute_Name
=> Name_Access
),
5013 end Pack_Node_Into_Stream
;
5015 ----------------------------------
5016 -- Pack_Node_Into_Stream_Access --
5017 ----------------------------------
5019 function Pack_Node_Into_Stream_Access
5023 Etyp
: Entity_Id
) return Node_Id
5025 Write_Attribute
: Name_Id
:= Name_Write
;
5028 if not Is_Constrained
(Etyp
) then
5029 Write_Attribute
:= Name_Output
;
5033 Make_Attribute_Reference
(Loc
,
5034 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5035 Attribute_Name
=> Write_Attribute
,
5036 Expressions
=> New_List
(
5039 end Pack_Node_Into_Stream_Access
;
5041 ---------------------
5042 -- PolyORB_Support --
5043 ---------------------
5045 package body PolyORB_Support
is
5047 -- Local subprograms
5049 procedure Add_RACW_Read_Attribute
5050 (RACW_Type
: Entity_Id
;
5051 Stub_Type
: Entity_Id
;
5052 Stub_Type_Access
: Entity_Id
;
5053 Declarations
: List_Id
);
5054 -- Add Read attribute in Decls for the RACW type. The Read attribute
5055 -- is added right after the RACW_Type declaration while the body is
5056 -- inserted after Declarations.
5058 procedure Add_RACW_Write_Attribute
5059 (RACW_Type
: Entity_Id
;
5060 Stub_Type
: Entity_Id
;
5061 Stub_Type_Access
: Entity_Id
;
5062 Declarations
: List_Id
);
5063 -- Same thing for the Write attribute
5065 procedure Add_RACW_From_Any
5066 (RACW_Type
: Entity_Id
;
5067 Stub_Type
: Entity_Id
;
5068 Stub_Type_Access
: Entity_Id
;
5069 Declarations
: List_Id
);
5070 -- Add the From_Any TSS for this RACW type
5072 procedure Add_RACW_To_Any
5073 (Designated_Type
: Entity_Id
;
5074 RACW_Type
: Entity_Id
;
5075 Stub_Type
: Entity_Id
;
5076 Stub_Type_Access
: Entity_Id
;
5077 Declarations
: List_Id
);
5078 -- Add the To_Any TSS for this RACW type
5080 procedure Add_RACW_TypeCode
5081 (Designated_Type
: Entity_Id
;
5082 RACW_Type
: Entity_Id
;
5083 Declarations
: List_Id
);
5084 -- Add the TypeCode TSS for this RACW type
5086 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
);
5087 -- Add the From_Any TSS for this RAS type
5089 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
);
5090 -- Add the To_Any TSS for this RAS type
5092 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
);
5093 -- Add the TypeCode TSS for this RAS type
5095 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
5096 -- Add a subprogram body for RAS Access TSS
5098 -------------------------------------
5099 -- Add_Obj_RPC_Receiver_Completion --
5100 -------------------------------------
5102 procedure Add_Obj_RPC_Receiver_Completion
5105 RPC_Receiver
: Entity_Id
;
5106 Stub_Elements
: Stub_Structure
)
5108 Desig
: constant Entity_Id
:=
5109 Etype
(Designated_Type
(Stub_Elements
.RACW_Type
));
5112 Make_Procedure_Call_Statement
(Loc
,
5115 RTE
(RE_Register_Obj_Receiving_Stub
), Loc
),
5117 Parameter_Associations
=> New_List
(
5121 Make_String_Literal
(Loc
,
5122 Full_Qualified_Name
(Desig
)),
5126 Make_Attribute_Reference
(Loc
,
5129 Defining_Unit_Name
(Parent
(RPC_Receiver
)), Loc
),
5135 Make_Attribute_Reference
(Loc
,
5138 Defining_Identifier
(
5139 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5142 end Add_Obj_RPC_Receiver_Completion
;
5144 -----------------------
5145 -- Add_RACW_Features --
5146 -----------------------
5148 procedure Add_RACW_Features
5149 (RACW_Type
: Entity_Id
;
5151 Stub_Type
: Entity_Id
;
5152 Stub_Type_Access
: Entity_Id
;
5153 RPC_Receiver_Decl
: Node_Id
;
5154 Declarations
: List_Id
)
5156 pragma Warnings
(Off
);
5157 pragma Unreferenced
(RPC_Receiver_Decl
);
5158 pragma Warnings
(On
);
5162 (RACW_Type
=> RACW_Type
,
5163 Stub_Type
=> Stub_Type
,
5164 Stub_Type_Access
=> Stub_Type_Access
,
5165 Declarations
=> Declarations
);
5168 (Designated_Type
=> Desig
,
5169 RACW_Type
=> RACW_Type
,
5170 Stub_Type
=> Stub_Type
,
5171 Stub_Type_Access
=> Stub_Type_Access
,
5172 Declarations
=> Declarations
);
5174 -- In the PolyORB case, the RACW 'Read and 'Write attributes
5175 -- are implemented in terms of the From_Any and To_Any TSSs,
5176 -- so these TSSs must be expanded before 'Read and 'Write.
5178 Add_RACW_Write_Attribute
5179 (RACW_Type
=> RACW_Type
,
5180 Stub_Type
=> Stub_Type
,
5181 Stub_Type_Access
=> Stub_Type_Access
,
5182 Declarations
=> Declarations
);
5184 Add_RACW_Read_Attribute
5185 (RACW_Type
=> RACW_Type
,
5186 Stub_Type
=> Stub_Type
,
5187 Stub_Type_Access
=> Stub_Type_Access
,
5188 Declarations
=> Declarations
);
5191 (Designated_Type
=> Desig
,
5192 RACW_Type
=> RACW_Type
,
5193 Declarations
=> Declarations
);
5194 end Add_RACW_Features
;
5196 -----------------------
5197 -- Add_RACW_From_Any --
5198 -----------------------
5200 procedure Add_RACW_From_Any
5201 (RACW_Type
: Entity_Id
;
5202 Stub_Type
: Entity_Id
;
5203 Stub_Type_Access
: Entity_Id
;
5204 Declarations
: List_Id
)
5206 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5207 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5209 Fnam
: constant Entity_Id
:=
5210 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F'));
5212 Func_Spec
: Node_Id
;
5213 Func_Decl
: Node_Id
;
5214 Func_Body
: Node_Id
;
5217 Statements
: List_Id
;
5218 Stub_Statements
: List_Id
;
5219 Local_Statements
: List_Id
;
5220 -- Various parts of the subprogram
5222 Any_Parameter
: constant Entity_Id
:=
5223 Make_Defining_Identifier
(Loc
, Name_A
);
5224 Reference
: constant Entity_Id
:=
5225 Make_Defining_Identifier
5226 (Loc
, New_Internal_Name
('R'));
5227 Is_Local
: constant Entity_Id
:=
5228 Make_Defining_Identifier
5229 (Loc
, New_Internal_Name
('L'));
5230 Addr
: constant Entity_Id
:=
5231 Make_Defining_Identifier
5232 (Loc
, New_Internal_Name
('A'));
5233 Local_Stub
: constant Entity_Id
:=
5234 Make_Defining_Identifier
5235 (Loc
, New_Internal_Name
('L'));
5236 Stubbed_Result
: constant Entity_Id
:=
5237 Make_Defining_Identifier
5238 (Loc
, New_Internal_Name
('S'));
5240 Stub_Condition
: Node_Id
;
5241 -- An expression that determines whether we create a stub for the
5242 -- newly-unpacked RACW. Normally we create a stub only for remote
5243 -- objects, but in the case of an RACW used to implement a RAS,
5244 -- we also create a stub for local subprograms if a pragma
5245 -- All_Calls_Remote applies.
5247 Asynchronous_Flag
: constant Entity_Id
:=
5248 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5249 -- The flag object declared in Add_RACW_Asynchronous_Flag
5252 -- Object declarations
5255 Make_Object_Declaration
(Loc
,
5256 Defining_Identifier
=>
5258 Object_Definition
=>
5259 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5261 Make_Function_Call
(Loc
,
5263 New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
5264 Parameter_Associations
=> New_List
(
5265 New_Occurrence_Of
(Any_Parameter
, Loc
)))),
5267 Make_Object_Declaration
(Loc
,
5268 Defining_Identifier
=> Local_Stub
,
5269 Aliased_Present
=> True,
5270 Object_Definition
=> New_Occurrence_Of
(Stub_Type
, Loc
)),
5272 Make_Object_Declaration
(Loc
,
5273 Defining_Identifier
=> Stubbed_Result
,
5274 Object_Definition
=>
5275 New_Occurrence_Of
(Stub_Type_Access
, Loc
),
5277 Make_Attribute_Reference
(Loc
,
5279 New_Occurrence_Of
(Local_Stub
, Loc
),
5281 Name_Unchecked_Access
)),
5283 Make_Object_Declaration
(Loc
,
5284 Defining_Identifier
=> Is_Local
,
5285 Object_Definition
=>
5286 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
5288 Make_Object_Declaration
(Loc
,
5289 Defining_Identifier
=> Addr
,
5290 Object_Definition
=>
5291 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
5293 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
5295 Set_Etype
(Stubbed_Result
, Stub_Type_Access
);
5297 -- If the ref Is_Nil, return a null pointer
5299 Statements
:= New_List
(
5300 Make_Implicit_If_Statement
(RACW_Type
,
5302 Make_Function_Call
(Loc
,
5304 New_Occurrence_Of
(RTE
(RE_Is_Nil
), Loc
),
5305 Parameter_Associations
=> New_List
(
5306 New_Occurrence_Of
(Reference
, Loc
))),
5307 Then_Statements
=> New_List
(
5308 Make_Return_Statement
(Loc
,
5310 Make_Null
(Loc
)))));
5312 Append_To
(Statements
,
5313 Make_Procedure_Call_Statement
(Loc
,
5315 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
5316 Parameter_Associations
=> New_List
(
5317 New_Occurrence_Of
(Reference
, Loc
),
5318 New_Occurrence_Of
(Is_Local
, Loc
),
5319 New_Occurrence_Of
(Addr
, Loc
))));
5321 -- If the object is located on another partition, then a stub object
5322 -- will be created with all the information needed to rebuild the
5323 -- real object at the other end. This stanza is always used in the
5324 -- case of RAS types, for which a stub is required even for local
5327 Stub_Statements
:= New_List
(
5328 Make_Assignment_Statement
(Loc
,
5329 Name
=> Make_Selected_Component
(Loc
,
5330 Prefix
=> Stubbed_Result
,
5331 Selector_Name
=> Name_Target
),
5333 Make_Function_Call
(Loc
,
5335 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
5336 Parameter_Associations
=> New_List
(
5337 New_Occurrence_Of
(Reference
, Loc
)))),
5339 Make_Procedure_Call_Statement
(Loc
,
5341 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
5342 Parameter_Associations
=> New_List
(
5343 Make_Selected_Component
(Loc
,
5344 Prefix
=> Stubbed_Result
,
5345 Selector_Name
=> Name_Target
))),
5347 Make_Assignment_Statement
(Loc
,
5348 Name
=> Make_Selected_Component
(Loc
,
5349 Prefix
=> Stubbed_Result
,
5350 Selector_Name
=> Name_Asynchronous
),
5352 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)));
5354 -- ??? Issue with asynchronous calls here: the Asynchronous
5355 -- flag is set on the stub type if, and only if, the RACW type
5356 -- has a pragma Asynchronous. This is incorrect for RACWs that
5357 -- implement RAS types, because in that case the /designated
5358 -- subprogram/ (not the type) might be asynchronous, and
5359 -- that causes the stub to need to be asynchronous too.
5360 -- A solution is to transport a RAS as a struct containing
5361 -- a RACW and an asynchronous flag, and to properly alter
5362 -- the Asynchronous component in the stub type in the RAS's
5365 Append_List_To
(Stub_Statements
,
5366 Build_Get_Unique_RP_Call
(Loc
, Stubbed_Result
, Stub_Type
));
5368 -- Distinguish between the local and remote cases, and execute the
5369 -- appropriate piece of code.
5371 Stub_Condition
:= New_Occurrence_Of
(Is_Local
, Loc
);
5374 Stub_Condition
:= Make_And_Then
(Loc
,
5378 Make_Selected_Component
(Loc
,
5380 Unchecked_Convert_To
(
5381 RTE
(RE_RAS_Proxy_Type_Access
),
5382 New_Occurrence_Of
(Addr
, Loc
)),
5384 Make_Identifier
(Loc
,
5385 Name_All_Calls_Remote
)));
5388 Local_Statements
:= New_List
(
5389 Make_Return_Statement
(Loc
,
5391 Unchecked_Convert_To
(RACW_Type
,
5392 New_Occurrence_Of
(Addr
, Loc
))));
5394 Append_To
(Statements
,
5395 Make_Implicit_If_Statement
(RACW_Type
,
5398 Then_Statements
=> Local_Statements
,
5399 Else_Statements
=> Stub_Statements
));
5401 Append_To
(Statements
,
5402 Make_Return_Statement
(Loc
,
5403 Expression
=> Unchecked_Convert_To
(RACW_Type
,
5404 New_Occurrence_Of
(Stubbed_Result
, Loc
))));
5407 Make_Function_Specification
(Loc
,
5408 Defining_Unit_Name
=>
5410 Parameter_Specifications
=> New_List
(
5411 Make_Parameter_Specification
(Loc
,
5412 Defining_Identifier
=>
5415 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
5416 Result_Definition
=> New_Occurrence_Of
(RACW_Type
, Loc
));
5418 -- NOTE: The usage occurrences of RACW_Parameter must
5419 -- refer to the entity in the declaration spec, not those
5420 -- of the body spec.
5422 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5425 Make_Subprogram_Body
(Loc
,
5427 Copy_Specification
(Loc
, Func_Spec
),
5428 Declarations
=> Decls
,
5429 Handled_Statement_Sequence
=>
5430 Make_Handled_Sequence_Of_Statements
(Loc
,
5431 Statements
=> Statements
));
5433 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5434 Append_To
(Declarations
, Func_Body
);
5436 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_From_Any
);
5437 end Add_RACW_From_Any
;
5439 -----------------------------
5440 -- Add_RACW_Read_Attribute --
5441 -----------------------------
5443 procedure Add_RACW_Read_Attribute
5444 (RACW_Type
: Entity_Id
;
5445 Stub_Type
: Entity_Id
;
5446 Stub_Type_Access
: Entity_Id
;
5447 Declarations
: List_Id
)
5449 pragma Warnings
(Off
);
5450 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
5451 pragma Warnings
(On
);
5452 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5454 Proc_Decl
: Node_Id
;
5455 Attr_Decl
: Node_Id
;
5457 Body_Node
: Node_Id
;
5460 Statements
: List_Id
;
5461 -- Various parts of the procedure
5463 Procedure_Name
: constant Name_Id
:=
5464 New_Internal_Name
('R');
5465 Source_Ref
: constant Entity_Id
:=
5466 Make_Defining_Identifier
5467 (Loc
, New_Internal_Name
('R'));
5468 Asynchronous_Flag
: constant Entity_Id
:=
5469 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5470 pragma Assert
(Present
(Asynchronous_Flag
));
5472 function Stream_Parameter
return Node_Id
;
5473 function Result
return Node_Id
;
5474 -- Functions to create occurrences of the formal parameter names
5480 function Result
return Node_Id
is
5482 return Make_Identifier
(Loc
, Name_V
);
5485 ----------------------
5486 -- Stream_Parameter --
5487 ----------------------
5489 function Stream_Parameter
return Node_Id
is
5491 return Make_Identifier
(Loc
, Name_S
);
5492 end Stream_Parameter
;
5494 -- Start of processing for Add_RACW_Read_Attribute
5497 -- Generate object declarations
5500 Make_Object_Declaration
(Loc
,
5501 Defining_Identifier
=> Source_Ref
,
5502 Object_Definition
=>
5503 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)));
5505 Statements
:= New_List
(
5506 Make_Attribute_Reference
(Loc
,
5508 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5509 Attribute_Name
=> Name_Read
,
5510 Expressions
=> New_List
(
5512 New_Occurrence_Of
(Source_Ref
, Loc
))),
5513 Make_Assignment_Statement
(Loc
,
5517 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
5519 Make_Function_Call
(Loc
,
5521 New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
5522 Parameter_Associations
=> New_List
(
5523 New_Occurrence_Of
(Source_Ref
, Loc
))),
5526 Build_Stream_Procedure
5527 (Loc
, RACW_Type
, Body_Node
,
5528 Make_Defining_Identifier
(Loc
, Procedure_Name
),
5529 Statements
, Outp
=> True);
5530 Set_Declarations
(Body_Node
, Decls
);
5532 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
5533 Copy_Specification
(Loc
, Specification
(Body_Node
)));
5536 Make_Attribute_Definition_Clause
(Loc
,
5537 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
5541 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
5543 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
5544 Insert_After
(Proc_Decl
, Attr_Decl
);
5545 Append_To
(Declarations
, Body_Node
);
5546 end Add_RACW_Read_Attribute
;
5548 ---------------------
5549 -- Add_RACW_To_Any --
5550 ---------------------
5552 procedure Add_RACW_To_Any
5553 (Designated_Type
: Entity_Id
;
5554 RACW_Type
: Entity_Id
;
5555 Stub_Type
: Entity_Id
;
5556 Stub_Type_Access
: Entity_Id
;
5557 Declarations
: List_Id
)
5559 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5561 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5565 Stub_Elements
: constant Stub_Structure
:=
5566 Stubs_Table
.Get
(Designated_Type
);
5567 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5569 Func_Spec
: Node_Id
;
5570 Func_Decl
: Node_Id
;
5571 Func_Body
: Node_Id
;
5574 Statements
: List_Id
;
5575 Null_Statements
: List_Id
;
5576 Local_Statements
: List_Id
:= No_List
;
5577 Stub_Statements
: List_Id
;
5579 -- Various parts of the subprogram
5581 RACW_Parameter
: constant Entity_Id
5582 := Make_Defining_Identifier
(Loc
, Name_R
);
5584 Reference
: constant Entity_Id
:=
5585 Make_Defining_Identifier
5586 (Loc
, New_Internal_Name
('R'));
5587 Any
: constant Entity_Id
:=
5588 Make_Defining_Identifier
5589 (Loc
, New_Internal_Name
('A'));
5592 -- Object declarations
5595 Make_Object_Declaration
(Loc
,
5596 Defining_Identifier
=>
5598 Object_Definition
=>
5599 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
5600 Make_Object_Declaration
(Loc
,
5601 Defining_Identifier
=>
5603 Object_Definition
=>
5604 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
5606 -- If the object is null, nothing to do (Reference is already
5609 Null_Statements
:= New_List
(Make_Null_Statement
(Loc
));
5613 -- If the object is a RAS designating a local subprogram,
5614 -- we already have a target reference.
5616 Local_Statements
:= New_List
(
5617 Make_Procedure_Call_Statement
(Loc
,
5619 New_Occurrence_Of
(RTE
(RE_Set_Ref
), Loc
),
5620 Parameter_Associations
=> New_List
(
5621 New_Occurrence_Of
(Reference
, Loc
),
5622 Make_Selected_Component
(Loc
,
5624 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
5625 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5626 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)))));
5629 -- If the object is a local RACW object, use Get_Reference now
5630 -- to obtain a reference.
5632 Local_Statements
:= New_List
(
5633 Make_Procedure_Call_Statement
(Loc
,
5635 New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
5636 Parameter_Associations
=> New_List
(
5637 Unchecked_Convert_To
(
5639 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5640 Make_String_Literal
(Loc
,
5641 Full_Qualified_Name
(Designated_Type
)),
5642 Make_Attribute_Reference
(Loc
,
5645 Defining_Identifier
(
5646 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5649 New_Occurrence_Of
(Reference
, Loc
))));
5652 -- If the object is located on another partition, use the target
5655 Stub_Statements
:= New_List
(
5656 Make_Procedure_Call_Statement
(Loc
,
5658 New_Occurrence_Of
(RTE
(RE_Set_Ref
), Loc
),
5659 Parameter_Associations
=> New_List
(
5660 New_Occurrence_Of
(Reference
, Loc
),
5661 Make_Selected_Component
(Loc
,
5662 Prefix
=> Unchecked_Convert_To
(Stub_Type_Access
,
5663 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5665 Make_Identifier
(Loc
, Name_Target
)))));
5667 -- Distinguish between the null, local and remote cases,
5668 -- and execute the appropriate piece of code.
5671 Make_Implicit_If_Statement
(RACW_Type
,
5674 Left_Opnd
=> New_Occurrence_Of
(RACW_Parameter
, Loc
),
5675 Right_Opnd
=> Make_Null
(Loc
)),
5676 Then_Statements
=> Null_Statements
,
5677 Elsif_Parts
=> New_List
(
5678 Make_Elsif_Part
(Loc
,
5682 Make_Attribute_Reference
(Loc
,
5684 New_Occurrence_Of
(RACW_Parameter
, Loc
),
5685 Attribute_Name
=> Name_Tag
),
5687 Make_Attribute_Reference
(Loc
,
5688 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
5689 Attribute_Name
=> Name_Tag
)),
5690 Then_Statements
=> Local_Statements
)),
5691 Else_Statements
=> Stub_Statements
);
5693 Statements
:= New_List
(
5695 Make_Assignment_Statement
(Loc
,
5697 New_Occurrence_Of
(Any
, Loc
),
5699 Make_Function_Call
(Loc
,
5700 Name
=> New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
5701 Parameter_Associations
=> New_List
(
5702 New_Occurrence_Of
(Reference
, Loc
)))),
5703 Make_Procedure_Call_Statement
(Loc
,
5705 New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
5706 Parameter_Associations
=> New_List
(
5707 New_Occurrence_Of
(Any
, Loc
),
5708 Make_Selected_Component
(Loc
,
5710 Defining_Identifier
(
5711 Stub_Elements
.RPC_Receiver_Decl
),
5712 Selector_Name
=> Name_Obj_TypeCode
))),
5713 Make_Return_Statement
(Loc
,
5715 New_Occurrence_Of
(Any
, Loc
)));
5717 Fnam
:= Make_Defining_Identifier
(
5718 Loc
, New_Internal_Name
('T'));
5721 Make_Function_Specification
(Loc
,
5722 Defining_Unit_Name
=>
5724 Parameter_Specifications
=> New_List
(
5725 Make_Parameter_Specification
(Loc
,
5726 Defining_Identifier
=>
5729 New_Occurrence_Of
(RACW_Type
, Loc
))),
5730 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
5732 -- NOTE: The usage occurrences of RACW_Parameter must
5733 -- refer to the entity in the declaration spec, not in
5736 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5739 Make_Subprogram_Body
(Loc
,
5741 Copy_Specification
(Loc
, Func_Spec
),
5742 Declarations
=> Decls
,
5743 Handled_Statement_Sequence
=>
5744 Make_Handled_Sequence_Of_Statements
(Loc
,
5745 Statements
=> Statements
));
5747 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5748 Append_To
(Declarations
, Func_Body
);
5750 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_To_Any
);
5751 end Add_RACW_To_Any
;
5753 -----------------------
5754 -- Add_RACW_TypeCode --
5755 -----------------------
5757 procedure Add_RACW_TypeCode
5758 (Designated_Type
: Entity_Id
;
5759 RACW_Type
: Entity_Id
;
5760 Declarations
: List_Id
)
5762 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5766 Stub_Elements
: constant Stub_Structure
:=
5767 Stubs_Table
.Get
(Designated_Type
);
5768 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5770 Func_Spec
: Node_Id
;
5771 Func_Decl
: Node_Id
;
5772 Func_Body
: Node_Id
;
5776 Make_Defining_Identifier
(Loc
,
5777 Chars
=> New_Internal_Name
('T'));
5779 -- The spec for this subprogram has a dummy 'access RACW'
5780 -- argument, which serves only for overloading purposes.
5783 Make_Function_Specification
(Loc
,
5784 Defining_Unit_Name
=>
5786 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
5788 -- NOTE: The usage occurrences of RACW_Parameter must
5789 -- refer to the entity in the declaration spec, not those
5790 -- of the body spec.
5792 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5795 Make_Subprogram_Body
(Loc
,
5797 Copy_Specification
(Loc
, Func_Spec
),
5798 Declarations
=> Empty_List
,
5799 Handled_Statement_Sequence
=>
5800 Make_Handled_Sequence_Of_Statements
(Loc
,
5801 Statements
=> New_List
(
5802 Make_Return_Statement
(Loc
,
5804 Make_Selected_Component
(Loc
,
5806 Defining_Identifier
(
5807 Stub_Elements
.RPC_Receiver_Decl
),
5808 Selector_Name
=> Name_Obj_TypeCode
)))));
5810 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5811 Append_To
(Declarations
, Func_Body
);
5813 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_TypeCode
);
5814 end Add_RACW_TypeCode
;
5816 ------------------------------
5817 -- Add_RACW_Write_Attribute --
5818 ------------------------------
5820 procedure Add_RACW_Write_Attribute
5821 (RACW_Type
: Entity_Id
;
5822 Stub_Type
: Entity_Id
;
5823 Stub_Type_Access
: Entity_Id
;
5824 Declarations
: List_Id
)
5826 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5827 pragma Warnings
(Off
);
5828 pragma Unreferenced
(
5832 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5833 pragma Unreferenced
(Is_RAS
);
5834 pragma Warnings
(On
);
5836 Body_Node
: Node_Id
;
5837 Proc_Decl
: Node_Id
;
5838 Attr_Decl
: Node_Id
;
5840 Statements
: List_Id
;
5841 Procedure_Name
: constant Name_Id
:= New_Internal_Name
('R');
5843 function Stream_Parameter
return Node_Id
;
5844 function Object
return Node_Id
;
5845 -- Functions to create occurrences of the formal parameter names
5851 function Object
return Node_Id
is
5852 Object_Ref
: constant Node_Id
:=
5853 Make_Identifier
(Loc
, Name_V
);
5856 -- Etype must be set for Build_To_Any_Call
5858 Set_Etype
(Object_Ref
, RACW_Type
);
5863 ----------------------
5864 -- Stream_Parameter --
5865 ----------------------
5867 function Stream_Parameter
return Node_Id
is
5869 return Make_Identifier
(Loc
, Name_S
);
5870 end Stream_Parameter
;
5872 -- Start of processing for Add_RACW_Write_Attribute
5875 Statements
:= New_List
(
5876 Pack_Node_Into_Stream_Access
(Loc
,
5877 Stream
=> Stream_Parameter
,
5879 Make_Function_Call
(Loc
,
5881 New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
5882 Parameter_Associations
=> New_List
(
5883 PolyORB_Support
.Helpers
.Build_To_Any_Call
5884 (Object
, Declarations
))),
5885 Etyp
=> RTE
(RE_Object_Ref
)));
5887 Build_Stream_Procedure
5888 (Loc
, RACW_Type
, Body_Node
,
5889 Make_Defining_Identifier
(Loc
, Procedure_Name
),
5890 Statements
, Outp
=> False);
5893 Make_Subprogram_Declaration
(Loc
,
5894 Copy_Specification
(Loc
, Specification
(Body_Node
)));
5897 Make_Attribute_Definition_Clause
(Loc
,
5898 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
5899 Chars
=> Name_Write
,
5902 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
5904 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
5905 Insert_After
(Proc_Decl
, Attr_Decl
);
5906 Append_To
(Declarations
, Body_Node
);
5907 end Add_RACW_Write_Attribute
;
5909 -----------------------
5910 -- Add_RAST_Features --
5911 -----------------------
5913 procedure Add_RAST_Features
5914 (Vis_Decl
: Node_Id
;
5915 RAS_Type
: Entity_Id
)
5918 Add_RAS_Access_TSS
(Vis_Decl
);
5920 Add_RAS_From_Any
(RAS_Type
);
5921 Add_RAS_TypeCode
(RAS_Type
);
5923 -- To_Any uses TypeCode, and therefore needs to be generated last
5925 Add_RAS_To_Any
(RAS_Type
);
5926 end Add_RAST_Features
;
5928 ------------------------
5929 -- Add_RAS_Access_TSS --
5930 ------------------------
5932 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
5933 Loc
: constant Source_Ptr
:= Sloc
(N
);
5935 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
5936 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
5937 -- Ras_Type is the access to subprogram type; Fat_Type is the
5938 -- corresponding record type.
5940 RACW_Type
: constant Entity_Id
:=
5941 Underlying_RACW_Type
(Ras_Type
);
5942 Desig
: constant Entity_Id
:=
5943 Etype
(Designated_Type
(RACW_Type
));
5945 Stub_Elements
: constant Stub_Structure
:=
5946 Stubs_Table
.Get
(Desig
);
5947 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5949 Proc
: constant Entity_Id
:=
5950 Make_Defining_Identifier
(Loc
,
5951 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
5953 Proc_Spec
: Node_Id
;
5955 -- Formal parameters
5957 Package_Name
: constant Entity_Id
:=
5958 Make_Defining_Identifier
(Loc
,
5963 Subp_Id
: constant Entity_Id
:=
5964 Make_Defining_Identifier
(Loc
,
5967 -- Target subprogram
5969 Asynch_P
: constant Entity_Id
:=
5970 Make_Defining_Identifier
(Loc
,
5971 Chars
=> Name_Asynchronous
);
5972 -- Is the procedure to which the 'Access applies asynchronous?
5974 All_Calls_Remote
: constant Entity_Id
:=
5975 Make_Defining_Identifier
(Loc
,
5976 Chars
=> Name_All_Calls_Remote
);
5977 -- True if an All_Calls_Remote pragma applies to the RCI unit
5978 -- that contains the subprogram.
5980 -- Common local variables
5982 Proc_Decls
: List_Id
;
5983 Proc_Statements
: List_Id
;
5985 Subp_Ref
: constant Entity_Id
:=
5986 Make_Defining_Identifier
(Loc
, Name_R
);
5987 -- Reference that designates the target subprogram (returned
5988 -- by Get_RAS_Info).
5990 Is_Local
: constant Entity_Id
:=
5991 Make_Defining_Identifier
(Loc
, Name_L
);
5992 Local_Addr
: constant Entity_Id
:=
5993 Make_Defining_Identifier
(Loc
, Name_A
);
5994 -- For the call to Get_Local_Address
5996 -- Additional local variables for the remote case
5998 Local_Stub
: constant Entity_Id
:=
5999 Make_Defining_Identifier
(Loc
,
6000 Chars
=> New_Internal_Name
('L'));
6002 Stub_Ptr
: constant Entity_Id
:=
6003 Make_Defining_Identifier
(Loc
,
6004 Chars
=> New_Internal_Name
('S'));
6007 (Field_Name
: Name_Id
;
6008 Value
: Node_Id
) return Node_Id
;
6009 -- Construct an assignment that sets the named component in the
6017 (Field_Name
: Name_Id
;
6018 Value
: Node_Id
) return Node_Id
6022 Make_Assignment_Statement
(Loc
,
6024 Make_Selected_Component
(Loc
,
6026 Selector_Name
=> Field_Name
),
6027 Expression
=> Value
);
6030 -- Start of processing for Add_RAS_Access_TSS
6033 Proc_Decls
:= New_List
(
6035 -- Common declarations
6037 Make_Object_Declaration
(Loc
,
6038 Defining_Identifier
=> Subp_Ref
,
6039 Object_Definition
=>
6040 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
6042 Make_Object_Declaration
(Loc
,
6043 Defining_Identifier
=> Is_Local
,
6044 Object_Definition
=>
6045 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6047 Make_Object_Declaration
(Loc
,
6048 Defining_Identifier
=> Local_Addr
,
6049 Object_Definition
=>
6050 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
6052 Make_Object_Declaration
(Loc
,
6053 Defining_Identifier
=> Local_Stub
,
6054 Aliased_Present
=> True,
6055 Object_Definition
=>
6056 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
6058 Make_Object_Declaration
(Loc
,
6059 Defining_Identifier
=>
6061 Object_Definition
=>
6062 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
6064 Make_Attribute_Reference
(Loc
,
6065 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
6066 Attribute_Name
=> Name_Unchecked_Access
)));
6068 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
6069 -- Build_Get_Unique_RP_Call needs this information
6071 -- Get_RAS_Info (Pkg, Subp, R);
6072 -- Obtain a reference to the target subprogram
6074 Proc_Statements
:= New_List
(
6075 Make_Procedure_Call_Statement
(Loc
,
6077 New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
6078 Parameter_Associations
=> New_List
(
6079 New_Occurrence_Of
(Package_Name
, Loc
),
6080 New_Occurrence_Of
(Subp_Id
, Loc
),
6081 New_Occurrence_Of
(Subp_Ref
, Loc
))),
6083 -- Get_Local_Address (R, L, A);
6084 -- Determine whether the subprogram is local (L), and if so
6085 -- obtain the local address of its proxy (A).
6087 Make_Procedure_Call_Statement
(Loc
,
6089 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6090 Parameter_Associations
=> New_List
(
6091 New_Occurrence_Of
(Subp_Ref
, Loc
),
6092 New_Occurrence_Of
(Is_Local
, Loc
),
6093 New_Occurrence_Of
(Local_Addr
, Loc
))));
6095 -- Note: Here we assume that the Fat_Type is a record containing just
6096 -- an access to a proxy or stub object.
6098 Append_To
(Proc_Statements
,
6102 Make_Implicit_If_Statement
(N
,
6104 New_Occurrence_Of
(Is_Local
, Loc
),
6106 Then_Statements
=> New_List
(
6108 -- if A.Target = null then
6110 Make_Implicit_If_Statement
(N
,
6113 Make_Selected_Component
(Loc
,
6115 Unchecked_Convert_To
(
6116 RTE
(RE_RAS_Proxy_Type_Access
),
6117 New_Occurrence_Of
(Local_Addr
, Loc
)),
6119 Make_Identifier
(Loc
, Name_Target
)),
6122 Then_Statements
=> New_List
(
6124 -- A.Target := Entity_Of (Ref);
6126 Make_Assignment_Statement
(Loc
,
6128 Make_Selected_Component
(Loc
,
6130 Unchecked_Convert_To
(
6131 RTE
(RE_RAS_Proxy_Type_Access
),
6132 New_Occurrence_Of
(Local_Addr
, Loc
)),
6134 Make_Identifier
(Loc
, Name_Target
)),
6136 Make_Function_Call
(Loc
,
6138 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6139 Parameter_Associations
=> New_List
(
6140 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6142 -- Inc_Usage (A.Target);
6144 Make_Procedure_Call_Statement
(Loc
,
6146 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6147 Parameter_Associations
=> New_List
(
6148 Make_Selected_Component
(Loc
,
6150 Unchecked_Convert_To
(
6151 RTE
(RE_RAS_Proxy_Type_Access
),
6152 New_Occurrence_Of
(Local_Addr
, Loc
)),
6153 Selector_Name
=> Make_Identifier
(Loc
,
6157 -- if not All_Calls_Remote then
6158 -- return Fat_Type!(A);
6161 Make_Implicit_If_Statement
(N
,
6164 New_Occurrence_Of
(All_Calls_Remote
, Loc
)),
6166 Then_Statements
=> New_List
(
6167 Make_Return_Statement
(Loc
,
6168 Unchecked_Convert_To
(Fat_Type
,
6169 New_Occurrence_Of
(Local_Addr
, Loc
))))))));
6171 Append_List_To
(Proc_Statements
, New_List
(
6173 -- Stub.Target := Entity_Of (Ref);
6175 Set_Field
(Name_Target
,
6176 Make_Function_Call
(Loc
,
6178 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6179 Parameter_Associations
=> New_List
(
6180 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6182 -- Inc_Usage (Stub.Target);
6184 Make_Procedure_Call_Statement
(Loc
,
6186 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6187 Parameter_Associations
=> New_List
(
6188 Make_Selected_Component
(Loc
,
6190 Selector_Name
=> Name_Target
))),
6192 -- E.4.1(9) A remote call is asynchronous if it is a call to
6193 -- a procedure, or a call through a value of an access-to-procedure
6194 -- type, to which a pragma Asynchronous applies.
6196 -- Parameter Asynch_P is true when the procedure is asynchronous;
6197 -- Expression Asynch_T is true when the type is asynchronous.
6199 Set_Field
(Name_Asynchronous
,
6201 New_Occurrence_Of
(Asynch_P
, Loc
),
6202 New_Occurrence_Of
(Boolean_Literals
(
6203 Is_Asynchronous
(Ras_Type
)), Loc
)))));
6205 Append_List_To
(Proc_Statements
,
6206 Build_Get_Unique_RP_Call
(Loc
,
6207 Stub_Ptr
, Stub_Elements
.Stub_Type
));
6209 Append_To
(Proc_Statements
,
6210 Make_Return_Statement
(Loc
,
6212 Unchecked_Convert_To
(Fat_Type
,
6213 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
6216 Make_Function_Specification
(Loc
,
6217 Defining_Unit_Name
=> Proc
,
6218 Parameter_Specifications
=> New_List
(
6219 Make_Parameter_Specification
(Loc
,
6220 Defining_Identifier
=> Package_Name
,
6222 New_Occurrence_Of
(Standard_String
, Loc
)),
6224 Make_Parameter_Specification
(Loc
,
6225 Defining_Identifier
=> Subp_Id
,
6227 New_Occurrence_Of
(Standard_String
, Loc
)),
6229 Make_Parameter_Specification
(Loc
,
6230 Defining_Identifier
=> Asynch_P
,
6232 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6234 Make_Parameter_Specification
(Loc
,
6235 Defining_Identifier
=> All_Calls_Remote
,
6237 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
6239 Result_Definition
=>
6240 New_Occurrence_Of
(Fat_Type
, Loc
));
6242 -- Set the kind and return type of the function to prevent
6243 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6245 Set_Ekind
(Proc
, E_Function
);
6246 Set_Etype
(Proc
, Fat_Type
);
6249 Make_Subprogram_Body
(Loc
,
6250 Specification
=> Proc_Spec
,
6251 Declarations
=> Proc_Decls
,
6252 Handled_Statement_Sequence
=>
6253 Make_Handled_Sequence_Of_Statements
(Loc
,
6254 Statements
=> Proc_Statements
)));
6256 Set_TSS
(Fat_Type
, Proc
);
6257 end Add_RAS_Access_TSS
;
6259 ----------------------
6260 -- Add_RAS_From_Any --
6261 ----------------------
6263 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
) is
6264 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6266 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6267 Make_TSS_Name
(RAS_Type
, TSS_From_Any
));
6269 Func_Spec
: Node_Id
;
6271 Statements
: List_Id
;
6273 Any_Parameter
: constant Entity_Id
:=
6274 Make_Defining_Identifier
(Loc
, Name_A
);
6277 Statements
:= New_List
(
6278 Make_Return_Statement
(Loc
,
6280 Make_Aggregate
(Loc
,
6281 Component_Associations
=> New_List
(
6282 Make_Component_Association
(Loc
,
6283 Choices
=> New_List
(
6284 Make_Identifier
(Loc
, Name_Ras
)),
6286 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
6287 Underlying_RACW_Type
(RAS_Type
),
6288 New_Occurrence_Of
(Any_Parameter
, Loc
),
6292 Make_Function_Specification
(Loc
,
6293 Defining_Unit_Name
=>
6295 Parameter_Specifications
=> New_List
(
6296 Make_Parameter_Specification
(Loc
,
6297 Defining_Identifier
=>
6300 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
6301 Result_Definition
=> New_Occurrence_Of
(RAS_Type
, Loc
));
6304 Make_Subprogram_Body
(Loc
,
6305 Specification
=> Func_Spec
,
6306 Declarations
=> No_List
,
6307 Handled_Statement_Sequence
=>
6308 Make_Handled_Sequence_Of_Statements
(Loc
,
6309 Statements
=> Statements
)));
6310 Set_TSS
(RAS_Type
, Fnam
);
6311 end Add_RAS_From_Any
;
6313 --------------------
6314 -- Add_RAS_To_Any --
6315 --------------------
6317 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
) is
6318 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6320 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6321 Make_TSS_Name
(RAS_Type
, TSS_To_Any
));
6324 Statements
: List_Id
;
6326 Func_Spec
: Node_Id
;
6328 Any
: constant Entity_Id
:=
6329 Make_Defining_Identifier
(Loc
,
6330 Chars
=> New_Internal_Name
('A'));
6331 RAS_Parameter
: constant Entity_Id
:=
6332 Make_Defining_Identifier
(Loc
,
6333 Chars
=> New_Internal_Name
('R'));
6334 RACW_Parameter
: constant Node_Id
:=
6335 Make_Selected_Component
(Loc
,
6336 Prefix
=> RAS_Parameter
,
6337 Selector_Name
=> Name_Ras
);
6340 -- Object declarations
6342 Set_Etype
(RACW_Parameter
, Underlying_RACW_Type
(RAS_Type
));
6344 Make_Object_Declaration
(Loc
,
6345 Defining_Identifier
=>
6347 Object_Definition
=>
6348 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
6350 PolyORB_Support
.Helpers
.Build_To_Any_Call
6351 (RACW_Parameter
, No_List
)));
6353 Statements
:= New_List
(
6354 Make_Procedure_Call_Statement
(Loc
,
6356 New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
6357 Parameter_Associations
=> New_List
(
6358 New_Occurrence_Of
(Any
, Loc
),
6359 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
6361 Make_Return_Statement
(Loc
,
6363 New_Occurrence_Of
(Any
, Loc
)));
6366 Make_Function_Specification
(Loc
,
6367 Defining_Unit_Name
=>
6369 Parameter_Specifications
=> New_List
(
6370 Make_Parameter_Specification
(Loc
,
6371 Defining_Identifier
=>
6374 New_Occurrence_Of
(RAS_Type
, Loc
))),
6375 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
6378 Make_Subprogram_Body
(Loc
,
6379 Specification
=> Func_Spec
,
6380 Declarations
=> Decls
,
6381 Handled_Statement_Sequence
=>
6382 Make_Handled_Sequence_Of_Statements
(Loc
,
6383 Statements
=> Statements
)));
6384 Set_TSS
(RAS_Type
, Fnam
);
6387 ----------------------
6388 -- Add_RAS_TypeCode --
6389 ----------------------
6391 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
) is
6392 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6394 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6395 Make_TSS_Name
(RAS_Type
, TSS_TypeCode
));
6397 Func_Spec
: Node_Id
;
6399 Decls
: constant List_Id
:= New_List
;
6400 Name_String
, Repo_Id_String
: String_Id
;
6404 Make_Function_Specification
(Loc
,
6405 Defining_Unit_Name
=>
6407 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6409 PolyORB_Support
.Helpers
.Build_Name_And_Repository_Id
6410 (RAS_Type
, Name_Str
=> Name_String
, Repo_Id_Str
=> Repo_Id_String
);
6413 Make_Subprogram_Body
(Loc
,
6414 Specification
=> Func_Spec
,
6415 Declarations
=> Decls
,
6416 Handled_Statement_Sequence
=>
6417 Make_Handled_Sequence_Of_Statements
(Loc
,
6418 Statements
=> New_List
(
6419 Make_Return_Statement
(Loc
,
6421 Make_Function_Call
(Loc
,
6423 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
6424 Parameter_Associations
=> New_List
(
6425 New_Occurrence_Of
(RTE
(RE_TC_Object
), Loc
),
6426 Make_Aggregate
(Loc
,
6429 Make_Function_Call
(Loc
,
6430 Name
=> New_Occurrence_Of
(
6431 RTE
(RE_TA_String
), Loc
),
6432 Parameter_Associations
=> New_List
(
6433 Make_String_Literal
(Loc
, Name_String
))),
6434 Make_Function_Call
(Loc
,
6435 Name
=> New_Occurrence_Of
(
6436 RTE
(RE_TA_String
), Loc
),
6437 Parameter_Associations
=> New_List
(
6438 Make_String_Literal
(Loc
,
6439 Repo_Id_String
))))))))))));
6440 Set_TSS
(RAS_Type
, Fnam
);
6441 end Add_RAS_TypeCode
;
6443 -----------------------------------------
6444 -- Add_Receiving_Stubs_To_Declarations --
6445 -----------------------------------------
6447 procedure Add_Receiving_Stubs_To_Declarations
6448 (Pkg_Spec
: Node_Id
;
6451 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
6453 Pkg_RPC_Receiver
: constant Entity_Id
:=
6454 Make_Defining_Identifier
(Loc
,
6455 New_Internal_Name
('H'));
6456 Pkg_RPC_Receiver_Object
: Node_Id
;
6458 Pkg_RPC_Receiver_Body
: Node_Id
;
6459 Pkg_RPC_Receiver_Decls
: List_Id
;
6460 Pkg_RPC_Receiver_Statements
: List_Id
;
6461 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
6462 -- A Pkg_RPC_Receiver is built to decode the request
6465 -- Request object received from neutral layer
6467 Subp_Id
: Entity_Id
;
6468 -- Subprogram identifier as received from the neutral
6469 -- distribution core.
6471 Subp_Index
: Entity_Id
;
6472 -- Internal index as determined by matching either the
6473 -- method name from the request structure, or the local
6474 -- subprogram address (in case of a RAS).
6476 Is_Local
: constant Entity_Id
:=
6477 Make_Defining_Identifier
(Loc
, New_Internal_Name
('L'));
6478 Local_Address
: constant Entity_Id
:=
6479 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
6480 -- Address of a local subprogram designated by a
6481 -- reference corresponding to a RAS.
6483 Dispatch_On_Address
: constant List_Id
:= New_List
;
6484 Dispatch_On_Name
: constant List_Id
:= New_List
;
6486 Current_Declaration
: Node_Id
;
6487 Current_Stubs
: Node_Id
;
6488 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
6490 Subp_Info_Array
: constant Entity_Id
:=
6491 Make_Defining_Identifier
(Loc
,
6492 Chars
=> New_Internal_Name
('I'));
6494 Subp_Info_List
: constant List_Id
:= New_List
;
6496 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
6498 All_Calls_Remote_E
: Entity_Id
;
6500 procedure Append_Stubs_To
6501 (RPC_Receiver_Cases
: List_Id
;
6502 Declaration
: Node_Id
;
6505 Subp_Dist_Name
: Entity_Id
;
6506 Subp_Proxy_Addr
: Entity_Id
);
6507 -- Add one case to the specified RPC receiver case list associating
6508 -- Subprogram_Number with the subprogram declared by Declaration, for
6509 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6510 -- subprogram index. Subp_Dist_Name is the string used to call the
6511 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6512 -- object, used in the context of calls through remote
6513 -- access-to-subprogram types.
6515 ---------------------
6516 -- Append_Stubs_To --
6517 ---------------------
6519 procedure Append_Stubs_To
6520 (RPC_Receiver_Cases
: List_Id
;
6521 Declaration
: Node_Id
;
6524 Subp_Dist_Name
: Entity_Id
;
6525 Subp_Proxy_Addr
: Entity_Id
)
6527 Case_Stmts
: List_Id
;
6529 Case_Stmts
:= New_List
(
6530 Make_Procedure_Call_Statement
(Loc
,
6533 Defining_Entity
(Stubs
), Loc
),
6534 Parameter_Associations
=>
6535 New_List
(New_Occurrence_Of
(Request
, Loc
))));
6536 if Nkind
(Specification
(Declaration
))
6537 = N_Function_Specification
6539 Is_Asynchronous
(Defining_Entity
(Specification
(Declaration
)))
6541 Append_To
(Case_Stmts
, Make_Return_Statement
(Loc
));
6544 Append_To
(RPC_Receiver_Cases
,
6545 Make_Case_Statement_Alternative
(Loc
,
6547 New_List
(Make_Integer_Literal
(Loc
, Subp_Number
)),
6551 Append_To
(Dispatch_On_Name
,
6552 Make_Elsif_Part
(Loc
,
6554 Make_Function_Call
(Loc
,
6556 New_Occurrence_Of
(RTE
(RE_Caseless_String_Eq
), Loc
),
6557 Parameter_Associations
=> New_List
(
6558 New_Occurrence_Of
(Subp_Id
, Loc
),
6559 New_Occurrence_Of
(Subp_Dist_Name
, Loc
))),
6560 Then_Statements
=> New_List
(
6561 Make_Assignment_Statement
(Loc
,
6562 New_Occurrence_Of
(Subp_Index
, Loc
),
6563 Make_Integer_Literal
(Loc
,
6566 Append_To
(Dispatch_On_Address
,
6567 Make_Elsif_Part
(Loc
,
6571 New_Occurrence_Of
(Local_Address
, Loc
),
6573 New_Occurrence_Of
(Subp_Proxy_Addr
, Loc
)),
6574 Then_Statements
=> New_List
(
6575 Make_Assignment_Statement
(Loc
,
6576 New_Occurrence_Of
(Subp_Index
, Loc
),
6577 Make_Integer_Literal
(Loc
,
6579 end Append_Stubs_To
;
6581 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6584 -- Building receiving stubs consist in several operations:
6586 -- - a package RPC receiver must be built. This subprogram
6587 -- will get a Subprogram_Id from the incoming stream
6588 -- and will dispatch the call to the right subprogram
6590 -- - a receiving stub for any subprogram visible in the package
6591 -- spec. This stub will read all the parameters from the stream,
6592 -- and put the result as well as the exception occurrence in the
6595 -- - a dummy package with an empty spec and a body made of an
6596 -- elaboration part, whose job is to register the receiving
6597 -- part of this RCI package on the name server. This is done
6598 -- by calling System.Partition_Interface.Register_Receiving_Stub
6600 Build_RPC_Receiver_Body
(
6601 RPC_Receiver
=> Pkg_RPC_Receiver
,
6604 Subp_Index
=> Subp_Index
,
6605 Stmts
=> Pkg_RPC_Receiver_Statements
,
6606 Decl
=> Pkg_RPC_Receiver_Body
);
6607 Pkg_RPC_Receiver_Decls
:= Declarations
(Pkg_RPC_Receiver_Body
);
6609 -- Extract local address information from the target reference:
6610 -- if non-null, that means that this is a reference that denotes
6611 -- one particular operation, and hence that the operation name
6612 -- must not be taken into account for dispatching.
6614 Append_To
(Pkg_RPC_Receiver_Decls
,
6615 Make_Object_Declaration
(Loc
,
6616 Defining_Identifier
=>
6618 Object_Definition
=>
6619 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
6620 Append_To
(Pkg_RPC_Receiver_Decls
,
6621 Make_Object_Declaration
(Loc
,
6622 Defining_Identifier
=>
6624 Object_Definition
=>
6625 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6626 Append_To
(Pkg_RPC_Receiver_Statements
,
6627 Make_Procedure_Call_Statement
(Loc
,
6629 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6630 Parameter_Associations
=> New_List
(
6631 Make_Selected_Component
(Loc
,
6633 Selector_Name
=> Name_Target
),
6634 New_Occurrence_Of
(Is_Local
, Loc
),
6635 New_Occurrence_Of
(Local_Address
, Loc
))));
6637 -- Determine whether the reference that was used to make
6638 -- the call was the base RCI reference (in which case
6639 -- Local_Address is 0, and the method identifier from the
6640 -- request must be used to determine which subprogram is
6641 -- called) or a reference identifying one particular subprogram
6642 -- (in which case Local_Address is the address of that
6643 -- subprogram, and the method name from the request is
6645 -- In each case, cascaded elsifs are used to determine the
6646 -- proper subprogram index. Using hash tables might be
6649 Append_To
(Pkg_RPC_Receiver_Statements
,
6650 Make_Implicit_If_Statement
(Pkg_Spec
,
6653 Left_Opnd
=> New_Occurrence_Of
(Local_Address
, Loc
),
6654 Right_Opnd
=> New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)),
6655 Then_Statements
=> New_List
(
6656 Make_Implicit_If_Statement
(Pkg_Spec
,
6658 New_Occurrence_Of
(Standard_False
, Loc
),
6659 Then_Statements
=> New_List
(
6660 Make_Null_Statement
(Loc
)),
6662 Dispatch_On_Address
)),
6663 Else_Statements
=> New_List
(
6664 Make_Implicit_If_Statement
(Pkg_Spec
,
6666 New_Occurrence_Of
(Standard_False
, Loc
),
6667 Then_Statements
=> New_List
(
6668 Make_Null_Statement
(Loc
)),
6670 Dispatch_On_Name
))));
6672 -- For each subprogram, the receiving stub will be built and a
6673 -- case statement will be made on the Subprogram_Id to dispatch
6674 -- to the right subprogram.
6676 All_Calls_Remote_E
:= Boolean_Literals
(
6677 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
6679 Overload_Counter_Table
.Reset
;
6680 Reserve_NamingContext_Methods
;
6682 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
6683 while Present
(Current_Declaration
) loop
6684 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
6685 and then Comes_From_Source
(Current_Declaration
)
6688 Loc
: constant Source_Ptr
:=
6689 Sloc
(Current_Declaration
);
6690 -- While specifically processing Current_Declaration, use
6691 -- its Sloc as the location of all generated nodes.
6693 Subp_Def
: constant Entity_Id
:=
6695 (Specification
(Current_Declaration
));
6697 Subp_Val
: String_Id
;
6699 Subp_Dist_Name
: constant Entity_Id
:=
6700 Make_Defining_Identifier
(Loc
,
6702 Related_Id
=> Chars
(Subp_Def
),
6704 Suffix_Index
=> -1));
6706 Proxy_Object_Addr
: Entity_Id
;
6709 pragma Assert
(Current_Subprogram_Number
=
6710 Get_Subprogram_Id
(Subp_Def
));
6712 -- Build receiving stub
6715 Build_Subprogram_Receiving_Stubs
6716 (Vis_Decl
=> Current_Declaration
,
6718 Nkind
(Specification
(Current_Declaration
)) =
6719 N_Procedure_Specification
6720 and then Is_Asynchronous
(Subp_Def
));
6722 Append_To
(Decls
, Current_Stubs
);
6723 Analyze
(Current_Stubs
);
6727 Add_RAS_Proxy_And_Analyze
(Decls
,
6729 Current_Declaration
,
6730 All_Calls_Remote_E
=>
6732 Proxy_Object_Addr
=>
6735 -- Compute distribution identifier
6737 Assign_Subprogram_Identifier
(
6739 Current_Subprogram_Number
,
6743 Make_Object_Declaration
(Loc
,
6744 Defining_Identifier
=> Subp_Dist_Name
,
6745 Constant_Present
=> True,
6746 Object_Definition
=> New_Occurrence_Of
(
6747 Standard_String
, Loc
),
6749 Make_String_Literal
(Loc
, Subp_Val
)));
6750 Analyze
(Last
(Decls
));
6752 -- Add subprogram descriptor (RCI_Subp_Info) to the
6753 -- subprograms table for this receiver. The aggregate
6754 -- below must be kept consistent with the declaration
6755 -- of type RCI_Subp_Info in System.Partition_Interface.
6757 Append_To
(Subp_Info_List
,
6758 Make_Component_Association
(Loc
,
6759 Choices
=> New_List
(
6760 Make_Integer_Literal
(Loc
,
6761 Current_Subprogram_Number
)),
6763 Make_Aggregate
(Loc
,
6764 Expressions
=> New_List
(
6765 Make_Attribute_Reference
(Loc
,
6768 Subp_Dist_Name
, Loc
),
6769 Attribute_Name
=> Name_Address
),
6770 Make_Attribute_Reference
(Loc
,
6773 Subp_Dist_Name
, Loc
),
6774 Attribute_Name
=> Name_Length
),
6775 New_Occurrence_Of
(Proxy_Object_Addr
, Loc
)))));
6777 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
6778 Declaration
=> Current_Declaration
,
6779 Stubs
=> Current_Stubs
,
6780 Subp_Number
=> Current_Subprogram_Number
,
6781 Subp_Dist_Name
=> Subp_Dist_Name
,
6782 Subp_Proxy_Addr
=> Proxy_Object_Addr
);
6785 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
6788 Next
(Current_Declaration
);
6791 -- If we receive an invalid Subprogram_Id, it is best to do nothing
6792 -- rather than raising an exception since we do not want someone
6793 -- to crash a remote partition by sending invalid subprogram ids.
6794 -- This is consistent with the other parts of the case statement
6795 -- since even in presence of incorrect parameters in the stream,
6796 -- every exception will be caught and (if the subprogram is not an
6797 -- APC) put into the result stream and sent away.
6799 Append_To
(Pkg_RPC_Receiver_Cases
,
6800 Make_Case_Statement_Alternative
(Loc
,
6802 New_List
(Make_Others_Choice
(Loc
)),
6804 New_List
(Make_Null_Statement
(Loc
))));
6806 Append_To
(Pkg_RPC_Receiver_Statements
,
6807 Make_Case_Statement
(Loc
,
6809 New_Occurrence_Of
(Subp_Index
, Loc
),
6810 Alternatives
=> Pkg_RPC_Receiver_Cases
));
6813 Make_Object_Declaration
(Loc
,
6814 Defining_Identifier
=> Subp_Info_Array
,
6815 Constant_Present
=> True,
6816 Aliased_Present
=> True,
6817 Object_Definition
=>
6818 Make_Subtype_Indication
(Loc
,
6820 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
6822 Make_Index_Or_Discriminant_Constraint
(Loc
,
6825 Low_Bound
=> Make_Integer_Literal
(Loc
,
6826 First_RCI_Subprogram_Id
),
6828 Make_Integer_Literal
(Loc
,
6829 First_RCI_Subprogram_Id
6830 + List_Length
(Subp_Info_List
) - 1))))),
6832 Make_Aggregate
(Loc
,
6833 Component_Associations
=> Subp_Info_List
)));
6834 Analyze
(Last
(Decls
));
6836 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
6837 Analyze
(Last
(Decls
));
6839 Pkg_RPC_Receiver_Object
:=
6840 Make_Object_Declaration
(Loc
,
6841 Defining_Identifier
=>
6842 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
6843 Aliased_Present
=> True,
6844 Object_Definition
=>
6845 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
6846 Append_To
(Decls
, Pkg_RPC_Receiver_Object
);
6847 Analyze
(Last
(Decls
));
6849 Get_Library_Unit_Name_String
(Pkg_Spec
);
6850 Append_To
(Register_Pkg_Actuals
,
6852 Make_String_Literal
(Loc
,
6853 Strval
=> String_From_Name_Buffer
));
6855 Append_To
(Register_Pkg_Actuals
,
6857 Make_Attribute_Reference
(Loc
,
6860 (Defining_Entity
(Pkg_Spec
), Loc
),
6864 Append_To
(Register_Pkg_Actuals
,
6866 Make_Attribute_Reference
(Loc
,
6868 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
6869 Attribute_Name
=> Name_Access
));
6871 Append_To
(Register_Pkg_Actuals
,
6873 Make_Attribute_Reference
(Loc
,
6876 Defining_Identifier
(
6877 Pkg_RPC_Receiver_Object
), Loc
),
6881 Append_To
(Register_Pkg_Actuals
,
6883 Make_Attribute_Reference
(Loc
,
6885 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
6889 Append_To
(Register_Pkg_Actuals
,
6891 Make_Attribute_Reference
(Loc
,
6893 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
6897 Append_To
(Register_Pkg_Actuals
,
6898 -- Is_All_Calls_Remote
6899 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
));
6902 Make_Procedure_Call_Statement
(Loc
,
6904 New_Occurrence_Of
(RTE
(RE_Register_Pkg_Receiving_Stub
), Loc
),
6905 Parameter_Associations
=> Register_Pkg_Actuals
));
6906 Analyze
(Last
(Decls
));
6908 end Add_Receiving_Stubs_To_Declarations
;
6910 ---------------------------------
6911 -- Build_General_Calling_Stubs --
6912 ---------------------------------
6914 procedure Build_General_Calling_Stubs
6916 Statements
: List_Id
;
6917 Target_Object
: Node_Id
;
6918 Subprogram_Id
: Node_Id
;
6919 Asynchronous
: Node_Id
:= Empty
;
6920 Is_Known_Asynchronous
: Boolean := False;
6921 Is_Known_Non_Asynchronous
: Boolean := False;
6922 Is_Function
: Boolean;
6924 Stub_Type
: Entity_Id
:= Empty
;
6925 RACW_Type
: Entity_Id
:= Empty
;
6928 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
6930 Arguments
: Node_Id
;
6931 -- Name of the named values list used to transmit parameters
6932 -- to the remote package
6935 -- The request object constructed by these stubs
6938 -- Name of the result named value (in non-APC cases) which get the
6939 -- result of the remote subprogram.
6941 Result_TC
: Node_Id
;
6942 -- Typecode expression for the result of the request (void
6943 -- typecode for procedures).
6945 Exception_Return_Parameter
: Node_Id
;
6946 -- Name of the parameter which will hold the exception sent by the
6947 -- remote subprogram.
6949 Current_Parameter
: Node_Id
;
6950 -- Current parameter being handled
6952 Ordered_Parameters_List
: constant List_Id
:=
6953 Build_Ordered_Parameters_List
(Spec
);
6955 Asynchronous_P
: Node_Id
;
6956 -- A Boolean expression indicating whether this call is asynchronous
6958 Asynchronous_Statements
: List_Id
:= No_List
;
6959 Non_Asynchronous_Statements
: List_Id
:= No_List
;
6960 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
6962 Extra_Formal_Statements
: constant List_Id
:= New_List
;
6963 -- List of statements for extra formal parameters. It will appear
6964 -- after the regular statements for writing out parameters.
6966 After_Statements
: constant List_Id
:= New_List
;
6967 -- Statements to be executed after call returns (to assign
6968 -- in out or out parameter values).
6971 -- The type of the formal parameter being processed
6973 Is_Controlling_Formal
: Boolean;
6974 Is_First_Controlling_Formal
: Boolean;
6975 First_Controlling_Formal_Seen
: Boolean := False;
6976 -- Controlling formal parameters of distributed object
6977 -- primitives require special handling, and the first
6978 -- such parameter needs even more.
6981 -- ??? document general form of stub subprograms for the PolyORB case
6983 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
6986 Make_Object_Declaration
(Loc
,
6987 Defining_Identifier
=> Request
,
6988 Aliased_Present
=> False,
6989 Object_Definition
=>
6990 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
)));
6993 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
6996 Result_TC
:= PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
6997 Etype
(Result_Definition
(Spec
)), Decls
);
6999 Result_TC
:= New_Occurrence_Of
(RTE
(RE_TC_Void
), Loc
);
7003 Make_Object_Declaration
(Loc
,
7004 Defining_Identifier
=> Result
,
7005 Aliased_Present
=> False,
7006 Object_Definition
=>
7007 New_Occurrence_Of
(RTE
(RE_NamedValue
), Loc
),
7009 Make_Aggregate
(Loc
,
7010 Component_Associations
=> New_List
(
7011 Make_Component_Association
(Loc
,
7012 Choices
=> New_List
(
7013 Make_Identifier
(Loc
, Name_Name
)),
7015 New_Occurrence_Of
(RTE
(RE_Result_Name
), Loc
)),
7016 Make_Component_Association
(Loc
,
7017 Choices
=> New_List
(
7018 Make_Identifier
(Loc
, Name_Argument
)),
7020 Make_Function_Call
(Loc
,
7022 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7023 Parameter_Associations
=> New_List
(
7025 Make_Component_Association
(Loc
,
7026 Choices
=> New_List
(
7027 Make_Identifier
(Loc
, Name_Arg_Modes
)),
7029 Make_Integer_Literal
(Loc
, 0))))));
7031 if not Is_Known_Asynchronous
then
7032 Exception_Return_Parameter
:=
7033 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
7036 Make_Object_Declaration
(Loc
,
7037 Defining_Identifier
=> Exception_Return_Parameter
,
7038 Object_Definition
=>
7039 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
7042 Exception_Return_Parameter
:= Empty
;
7045 -- Initialize and fill in arguments list
7048 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
7049 Declare_Create_NVList
(Loc
, Arguments
, Decls
, Statements
);
7051 Current_Parameter
:= First
(Ordered_Parameters_List
);
7052 while Present
(Current_Parameter
) loop
7054 if Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
) then
7055 Is_Controlling_Formal
:= True;
7056 Is_First_Controlling_Formal
:=
7057 not First_Controlling_Formal_Seen
;
7058 First_Controlling_Formal_Seen
:= True;
7060 Is_Controlling_Formal
:= False;
7061 Is_First_Controlling_Formal
:= False;
7064 if Is_Controlling_Formal
then
7066 -- In the case of a controlling formal argument, we send
7072 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7075 -- The first controlling formal parameter is treated
7076 -- specially: it is used to set the target object of
7079 if not Is_First_Controlling_Formal
then
7082 Constrained
: constant Boolean :=
7083 Is_Constrained
(Etyp
)
7084 or else Is_Elementary_Type
(Etyp
);
7086 Any
: constant Entity_Id
:=
7087 Make_Defining_Identifier
(Loc
,
7088 New_Internal_Name
('A'));
7090 Actual_Parameter
: Node_Id
:=
7092 Defining_Identifier
(
7093 Current_Parameter
), Loc
);
7098 if Is_Controlling_Formal
then
7100 -- For a controlling formal parameter (other
7101 -- than the first one), use the corresponding
7102 -- RACW. If the parameter is not an anonymous
7103 -- access parameter, that involves taking
7104 -- its 'Unrestricted_Access.
7106 if Nkind
(Parameter_Type
(Current_Parameter
))
7107 = N_Access_Definition
7109 Actual_Parameter
:= OK_Convert_To
7110 (Etyp
, Actual_Parameter
);
7112 Actual_Parameter
:= OK_Convert_To
(Etyp
,
7113 Make_Attribute_Reference
(Loc
,
7117 Name_Unrestricted_Access
));
7122 if In_Present
(Current_Parameter
)
7123 or else not Out_Present
(Current_Parameter
)
7124 or else not Constrained
7125 or else Is_Controlling_Formal
7127 -- The parameter has an input value, is constrained
7128 -- at runtime by an input value, or is a controlling
7129 -- formal parameter (always passed as a reference)
7130 -- other than the first one.
7132 Expr
:= PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7133 Actual_Parameter
, Decls
);
7135 Expr
:= Make_Function_Call
(Loc
,
7137 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7138 Parameter_Associations
=> New_List
(
7139 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
7144 Make_Object_Declaration
(Loc
,
7145 Defining_Identifier
=>
7147 Aliased_Present
=> False,
7148 Object_Definition
=>
7149 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7153 Append_To
(Statements
,
7154 Add_Parameter_To_NVList
(Loc
,
7155 Parameter
=> Current_Parameter
,
7156 NVList
=> Arguments
,
7157 Constrained
=> Constrained
,
7160 if Out_Present
(Current_Parameter
)
7161 and then not Is_Controlling_Formal
7163 Append_To
(After_Statements
,
7164 Make_Assignment_Statement
(Loc
,
7167 Defining_Identifier
(Current_Parameter
), Loc
),
7169 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7170 Etype
(Parameter_Type
(Current_Parameter
)),
7171 New_Occurrence_Of
(Any
, Loc
),
7178 -- If the current parameter has a dynamic constrained status,
7179 -- then this status is transmitted as well.
7180 -- This should be done for accessibility as well ???
7182 if Nkind
(Parameter_Type
(Current_Parameter
))
7183 /= N_Access_Definition
7184 and then Need_Extra_Constrained
(Current_Parameter
)
7186 -- In this block, we do not use the extra formal that has been
7187 -- created because it does not exist at the time of expansion
7188 -- when building calling stubs for remote access to subprogram
7189 -- types. We create an extra variable of this type and push it
7190 -- in the stream after the regular parameters.
7193 Extra_Any_Parameter
: constant Entity_Id
:=
7194 Make_Defining_Identifier
7195 (Loc
, New_Internal_Name
('P'));
7199 Make_Object_Declaration
(Loc
,
7200 Defining_Identifier
=>
7201 Extra_Any_Parameter
,
7202 Aliased_Present
=> False,
7203 Object_Definition
=>
7204 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7206 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7207 Make_Attribute_Reference
(Loc
,
7210 Defining_Identifier
(Current_Parameter
), Loc
),
7211 Attribute_Name
=> Name_Constrained
),
7213 Append_To
(Extra_Formal_Statements
,
7214 Add_Parameter_To_NVList
(Loc
,
7215 Parameter
=> Extra_Any_Parameter
,
7216 NVList
=> Arguments
,
7217 Constrained
=> True,
7218 Any
=> Extra_Any_Parameter
));
7222 Next
(Current_Parameter
);
7225 -- Append the formal statements list to the statements
7227 Append_List_To
(Statements
, Extra_Formal_Statements
);
7229 Append_To
(Statements
,
7230 Make_Procedure_Call_Statement
(Loc
,
7232 New_Occurrence_Of
(RTE
(RE_Request_Create
), Loc
),
7233 Parameter_Associations
=> New_List
(
7236 New_Occurrence_Of
(Arguments
, Loc
),
7237 New_Occurrence_Of
(Result
, Loc
),
7238 New_Occurrence_Of
(RTE
(RE_Nil_Exc_List
), Loc
))));
7240 Append_To
(Parameter_Associations
(Last
(Statements
)),
7241 New_Occurrence_Of
(Request
, Loc
));
7244 not (Is_Known_Non_Asynchronous
and Is_Known_Asynchronous
));
7245 if Is_Known_Non_Asynchronous
or Is_Known_Asynchronous
then
7246 Asynchronous_P
:= New_Occurrence_Of
(
7247 Boolean_Literals
(Is_Known_Asynchronous
), Loc
);
7249 pragma Assert
(Present
(Asynchronous
));
7250 Asynchronous_P
:= New_Copy_Tree
(Asynchronous
);
7251 -- The expression node Asynchronous will be used to build
7252 -- an 'if' statement at the end of Build_General_Calling_Stubs:
7253 -- we need to make a copy here.
7256 Append_To
(Parameter_Associations
(Last
(Statements
)),
7257 Make_Indexed_Component
(Loc
,
7260 RTE
(RE_Asynchronous_P_To_Sync_Scope
), Loc
),
7261 Expressions
=> New_List
(Asynchronous_P
)));
7263 Append_To
(Statements
,
7264 Make_Procedure_Call_Statement
(Loc
,
7266 New_Occurrence_Of
(RTE
(RE_Request_Invoke
), Loc
),
7267 Parameter_Associations
=> New_List
(
7268 New_Occurrence_Of
(Request
, Loc
))));
7270 Non_Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7271 Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7273 if not Is_Known_Asynchronous
then
7275 -- Reraise an exception occurrence from the completed request.
7276 -- If the exception occurrence is empty, this is a no-op.
7278 Append_To
(Non_Asynchronous_Statements
,
7279 Make_Procedure_Call_Statement
(Loc
,
7281 New_Occurrence_Of
(RTE
(RE_Request_Raise_Occurrence
), Loc
),
7282 Parameter_Associations
=> New_List
(
7283 New_Occurrence_Of
(Request
, Loc
))));
7287 -- If this is a function call, then read the value and
7290 Append_To
(Non_Asynchronous_Statements
,
7291 Make_Tag_Check
(Loc
,
7292 Make_Return_Statement
(Loc
,
7293 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7294 Etype
(Result_Definition
(Spec
)),
7295 Make_Selected_Component
(Loc
,
7297 Selector_Name
=> Name_Argument
),
7302 Append_List_To
(Non_Asynchronous_Statements
,
7305 if Is_Known_Asynchronous
then
7306 Append_List_To
(Statements
, Asynchronous_Statements
);
7308 elsif Is_Known_Non_Asynchronous
then
7309 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
7312 pragma Assert
(Present
(Asynchronous
));
7313 Append_To
(Statements
,
7314 Make_Implicit_If_Statement
(Nod
,
7315 Condition
=> Asynchronous
,
7316 Then_Statements
=> Asynchronous_Statements
,
7317 Else_Statements
=> Non_Asynchronous_Statements
));
7319 end Build_General_Calling_Stubs
;
7321 -----------------------
7322 -- Build_Stub_Target --
7323 -----------------------
7325 function Build_Stub_Target
7328 RCI_Locator
: Entity_Id
;
7329 Controlling_Parameter
: Entity_Id
) return RPC_Target
7331 Target_Info
: RPC_Target
(PCS_Kind
=> Name_PolyORB_DSA
);
7332 Target_Reference
: constant Entity_Id
:=
7333 Make_Defining_Identifier
(Loc
,
7334 New_Internal_Name
('T'));
7336 if Present
(Controlling_Parameter
) then
7338 Make_Object_Declaration
(Loc
,
7339 Defining_Identifier
=> Target_Reference
,
7340 Object_Definition
=>
7341 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
7343 Make_Function_Call
(Loc
,
7345 New_Occurrence_Of
(RTE
(RE_Make_Ref
), Loc
),
7346 Parameter_Associations
=> New_List
(
7347 Make_Selected_Component
(Loc
,
7348 Prefix
=> Controlling_Parameter
,
7349 Selector_Name
=> Name_Target
)))));
7350 -- Controlling_Parameter has the same components
7351 -- as System.Partition_Interface.RACW_Stub_Type.
7353 Target_Info
.Object
:= New_Occurrence_Of
(Target_Reference
, Loc
);
7356 Target_Info
.Object
:=
7357 Make_Selected_Component
(Loc
,
7359 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
7361 Make_Identifier
(Loc
, Name_Get_RCI_Package_Ref
));
7364 end Build_Stub_Target
;
7366 ---------------------
7367 -- Build_Stub_Type --
7368 ---------------------
7370 procedure Build_Stub_Type
7371 (RACW_Type
: Entity_Id
;
7372 Stub_Type
: Entity_Id
;
7373 Stub_Type_Decl
: out Node_Id
;
7374 RPC_Receiver_Decl
: out Node_Id
)
7376 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
7377 pragma Warnings
(Off
);
7378 pragma Unreferenced
(RACW_Type
);
7379 pragma Warnings
(On
);
7383 Make_Full_Type_Declaration
(Loc
,
7384 Defining_Identifier
=> Stub_Type
,
7386 Make_Record_Definition
(Loc
,
7387 Tagged_Present
=> True,
7388 Limited_Present
=> True,
7390 Make_Component_List
(Loc
,
7391 Component_Items
=> New_List
(
7393 Make_Component_Declaration
(Loc
,
7394 Defining_Identifier
=>
7395 Make_Defining_Identifier
(Loc
, Name_Target
),
7396 Component_Definition
=>
7397 Make_Component_Definition
(Loc
,
7400 Subtype_Indication
=>
7401 New_Occurrence_Of
(RTE
(RE_Entity_Ptr
), Loc
))),
7403 Make_Component_Declaration
(Loc
,
7404 Defining_Identifier
=>
7405 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
7406 Component_Definition
=>
7407 Make_Component_Definition
(Loc
,
7408 Aliased_Present
=> False,
7409 Subtype_Indication
=>
7411 Standard_Boolean
, Loc
)))))));
7413 RPC_Receiver_Decl
:=
7414 Make_Object_Declaration
(Loc
,
7415 Defining_Identifier
=> Make_Defining_Identifier
(Loc
,
7416 New_Internal_Name
('R')),
7417 Aliased_Present
=> True,
7418 Object_Definition
=>
7419 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7420 end Build_Stub_Type
;
7422 -----------------------------
7423 -- Build_RPC_Receiver_Body --
7424 -----------------------------
7426 procedure Build_RPC_Receiver_Body
7427 (RPC_Receiver
: Entity_Id
;
7428 Request
: out Entity_Id
;
7429 Subp_Id
: out Entity_Id
;
7430 Subp_Index
: out Entity_Id
;
7431 Stmts
: out List_Id
;
7434 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
7436 RPC_Receiver_Spec
: Node_Id
;
7437 RPC_Receiver_Decls
: List_Id
;
7440 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
7442 RPC_Receiver_Spec
:=
7443 Build_RPC_Receiver_Specification
(
7444 RPC_Receiver
=> RPC_Receiver
,
7445 Request_Parameter
=> Request
);
7447 Subp_Id
:= Make_Defining_Identifier
(Loc
, Name_P
);
7448 Subp_Index
:= Make_Defining_Identifier
(Loc
, Name_I
);
7450 RPC_Receiver_Decls
:= New_List
(
7451 Make_Object_Renaming_Declaration
(Loc
,
7452 Defining_Identifier
=> Subp_Id
,
7453 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
7455 Make_Explicit_Dereference
(Loc
,
7457 Make_Selected_Component
(Loc
,
7459 Selector_Name
=> Name_Operation
))),
7461 Make_Object_Declaration
(Loc
,
7462 Defining_Identifier
=> Subp_Index
,
7463 Object_Definition
=>
7464 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7466 Make_Attribute_Reference
(Loc
,
7468 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7469 Attribute_Name
=> Name_Last
)));
7474 Make_Subprogram_Body
(Loc
,
7475 Specification
=> RPC_Receiver_Spec
,
7476 Declarations
=> RPC_Receiver_Decls
,
7477 Handled_Statement_Sequence
=>
7478 Make_Handled_Sequence_Of_Statements
(Loc
,
7479 Statements
=> Stmts
));
7480 end Build_RPC_Receiver_Body
;
7482 --------------------------------------
7483 -- Build_Subprogram_Receiving_Stubs --
7484 --------------------------------------
7486 function Build_Subprogram_Receiving_Stubs
7487 (Vis_Decl
: Node_Id
;
7488 Asynchronous
: Boolean;
7489 Dynamically_Asynchronous
: Boolean := False;
7490 Stub_Type
: Entity_Id
:= Empty
;
7491 RACW_Type
: Entity_Id
:= Empty
;
7492 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
7494 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
7496 Request_Parameter
: Node_Id
;
7499 Outer_Decls
: constant List_Id
:= New_List
;
7500 -- At the outermost level, an NVList and Any's are
7501 -- declared for all parameters. The Dynamic_Async
7502 -- flag also needs to be declared there to be visible
7503 -- from the exception handling code.
7505 Outer_Statements
: constant List_Id
:= New_List
;
7506 -- Statements that occur prior to the declaration of the actual
7507 -- parameter variables.
7509 Decls
: constant List_Id
:= New_List
;
7510 -- All the parameters will get declared before calling the real
7511 -- subprograms. Also the out parameters will be declared.
7512 -- At this level, parameters may be unconstrained.
7514 Statements
: constant List_Id
:= New_List
;
7516 Extra_Formal_Statements
: constant List_Id
:= New_List
;
7517 -- Statements concerning extra formal parameters
7519 After_Statements
: constant List_Id
:= New_List
;
7520 -- Statements to be executed after the subprogram call
7522 Inner_Decls
: List_Id
:= No_List
;
7523 -- In case of a function, the inner declarations are needed since
7524 -- the result may be unconstrained.
7526 Excep_Handlers
: List_Id
:= No_List
;
7528 Parameter_List
: constant List_Id
:= New_List
;
7529 -- List of parameters to be passed to the subprogram
7531 First_Controlling_Formal_Seen
: Boolean := False;
7533 Current_Parameter
: Node_Id
;
7535 Ordered_Parameters_List
: constant List_Id
:=
7536 Build_Ordered_Parameters_List
7537 (Specification
(Vis_Decl
));
7539 Arguments
: Node_Id
;
7540 -- Name of the named values list used to retrieve parameters
7542 Subp_Spec
: Node_Id
;
7543 -- Subprogram specification
7545 Called_Subprogram
: Node_Id
;
7546 -- The subprogram to call
7549 if Present
(RACW_Type
) then
7550 Called_Subprogram
:=
7551 New_Occurrence_Of
(Parent_Primitive
, Loc
);
7553 Called_Subprogram
:=
7555 Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
7558 Request_Parameter
:=
7559 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
7562 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
7563 Declare_Create_NVList
(Loc
, Arguments
, Outer_Decls
, Outer_Statements
);
7565 -- Loop through every parameter and get its value from the stream. If
7566 -- the parameter is unconstrained, then the parameter is read using
7567 -- 'Input at the point of declaration.
7569 Current_Parameter
:= First
(Ordered_Parameters_List
);
7570 while Present
(Current_Parameter
) loop
7573 Constrained
: Boolean;
7574 Any
: Entity_Id
:= Empty
;
7575 Object
: constant Entity_Id
:=
7576 Make_Defining_Identifier
(Loc
,
7577 New_Internal_Name
('P'));
7578 Expr
: Node_Id
:= Empty
;
7580 Is_Controlling_Formal
: constant Boolean
7581 := Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
);
7583 Is_First_Controlling_Formal
: Boolean := False;
7585 Set_Ekind
(Object
, E_Variable
);
7587 if Is_Controlling_Formal
then
7589 -- Controlling formals in distributed object primitive
7590 -- operations are handled specially:
7591 -- - the first controlling formal is used as the
7592 -- target of the call;
7593 -- - the remaining controlling formals are transmitted
7597 Is_First_Controlling_Formal
:=
7598 not First_Controlling_Formal_Seen
;
7599 First_Controlling_Formal_Seen
:= True;
7601 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7605 Is_Constrained
(Etyp
)
7606 or else Is_Elementary_Type
(Etyp
);
7608 if not Is_First_Controlling_Formal
then
7609 Any
:= Make_Defining_Identifier
(Loc
,
7610 New_Internal_Name
('A'));
7611 Append_To
(Outer_Decls
,
7612 Make_Object_Declaration
(Loc
,
7613 Defining_Identifier
=>
7615 Object_Definition
=>
7616 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7618 Make_Function_Call
(Loc
,
7620 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7621 Parameter_Associations
=> New_List
(
7622 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
7623 Etyp
, Outer_Decls
)))));
7625 Append_To
(Outer_Statements
,
7626 Add_Parameter_To_NVList
(Loc
,
7627 Parameter
=> Current_Parameter
,
7628 NVList
=> Arguments
,
7629 Constrained
=> Constrained
,
7633 if Is_First_Controlling_Formal
then
7635 Addr
: constant Entity_Id
:=
7636 Make_Defining_Identifier
(Loc
,
7637 New_Internal_Name
('A'));
7638 Is_Local
: constant Entity_Id
:=
7639 Make_Defining_Identifier
(Loc
,
7640 New_Internal_Name
('L'));
7643 -- Special case: obtain the first controlling
7644 -- formal from the target of the remote call,
7645 -- instead of the argument list.
7647 Append_To
(Outer_Decls
,
7648 Make_Object_Declaration
(Loc
,
7649 Defining_Identifier
=>
7651 Object_Definition
=>
7652 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
7653 Append_To
(Outer_Decls
,
7654 Make_Object_Declaration
(Loc
,
7655 Defining_Identifier
=>
7657 Object_Definition
=>
7658 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7659 Append_To
(Outer_Statements
,
7660 Make_Procedure_Call_Statement
(Loc
,
7663 RTE
(RE_Get_Local_Address
), Loc
),
7664 Parameter_Associations
=> New_List
(
7665 Make_Selected_Component
(Loc
,
7668 Request_Parameter
, Loc
),
7670 Make_Identifier
(Loc
, Name_Target
)),
7671 New_Occurrence_Of
(Is_Local
, Loc
),
7672 New_Occurrence_Of
(Addr
, Loc
))));
7674 Expr
:= Unchecked_Convert_To
(RACW_Type
,
7675 New_Occurrence_Of
(Addr
, Loc
));
7678 elsif In_Present
(Current_Parameter
)
7679 or else not Out_Present
(Current_Parameter
)
7680 or else not Constrained
7682 -- If an input parameter is contrained, then its reading is
7683 -- deferred until the beginning of the subprogram body. If
7684 -- it is unconstrained, then an expression is built for
7685 -- the object declaration and the variable is set using
7686 -- 'Input instead of 'Read.
7688 Expr
:= PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7689 Etyp
, New_Occurrence_Of
(Any
, Loc
), Decls
);
7693 Append_To
(Statements
,
7694 Make_Assignment_Statement
(Loc
,
7696 New_Occurrence_Of
(Object
, Loc
),
7702 -- Expr will be used to initialize (and constrain)
7703 -- the parameter when it is declared.
7708 -- If we do not have to output the current parameter, then
7709 -- it can well be flagged as constant. This may allow further
7710 -- optimizations done by the back end.
7713 Make_Object_Declaration
(Loc
,
7714 Defining_Identifier
=> Object
,
7715 Constant_Present
=> not Constrained
7716 and then not Out_Present
(Current_Parameter
),
7717 Object_Definition
=>
7718 New_Occurrence_Of
(Etyp
, Loc
),
7719 Expression
=> Expr
));
7720 Set_Etype
(Object
, Etyp
);
7722 -- An out parameter may be written back using a 'Write
7723 -- attribute instead of a 'Output because it has been
7724 -- constrained by the parameter given to the caller. Note that
7725 -- out controlling arguments in the case of a RACW are not put
7726 -- back in the stream because the pointer on them has not
7729 if Out_Present
(Current_Parameter
)
7730 and then not Is_Controlling_Formal
7732 Append_To
(After_Statements
,
7733 Make_Procedure_Call_Statement
(Loc
,
7735 New_Occurrence_Of
(RTE
(RE_Copy_Any_Value
), Loc
),
7736 Parameter_Associations
=> New_List
(
7737 New_Occurrence_Of
(Any
, Loc
),
7738 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7739 New_Occurrence_Of
(Object
, Loc
),
7743 -- For RACW controlling formals, the Etyp of Object is always
7744 -- an RACW, even if the parameter is not of an anonymous access
7745 -- type. In such case, we need to dereference it at call time.
7747 if Is_Controlling_Formal
then
7748 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7751 Append_To
(Parameter_List
,
7752 Make_Parameter_Association
(Loc
,
7755 Defining_Identifier
(Current_Parameter
), Loc
),
7756 Explicit_Actual_Parameter
=>
7757 Make_Explicit_Dereference
(Loc
,
7758 Unchecked_Convert_To
(RACW_Type
,
7759 OK_Convert_To
(RTE
(RE_Address
),
7760 New_Occurrence_Of
(Object
, Loc
))))));
7763 Append_To
(Parameter_List
,
7764 Make_Parameter_Association
(Loc
,
7767 Defining_Identifier
(Current_Parameter
), Loc
),
7768 Explicit_Actual_Parameter
=>
7769 Unchecked_Convert_To
(RACW_Type
,
7770 OK_Convert_To
(RTE
(RE_Address
),
7771 New_Occurrence_Of
(Object
, Loc
)))));
7775 Append_To
(Parameter_List
,
7776 Make_Parameter_Association
(Loc
,
7779 Defining_Identifier
(Current_Parameter
), Loc
),
7780 Explicit_Actual_Parameter
=>
7781 New_Occurrence_Of
(Object
, Loc
)));
7784 -- If the current parameter needs an extra formal, then read it
7785 -- from the stream and set the corresponding semantic field in
7786 -- the variable. If the kind of the parameter identifier is
7787 -- E_Void, then this is a compiler generated parameter that
7788 -- doesn't need an extra constrained status.
7790 -- The case of Extra_Accessibility should also be handled ???
7792 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7795 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
7797 Present
(Extra_Constrained
7798 (Defining_Identifier
(Current_Parameter
)))
7801 Extra_Parameter
: constant Entity_Id
:=
7803 (Defining_Identifier
7804 (Current_Parameter
));
7805 Extra_Any
: constant Entity_Id
:=
7806 Make_Defining_Identifier
7807 (Loc
, New_Internal_Name
('A'));
7808 Formal_Entity
: constant Entity_Id
:=
7809 Make_Defining_Identifier
7810 (Loc
, Chars
(Extra_Parameter
));
7812 Formal_Type
: constant Entity_Id
:=
7813 Etype
(Extra_Parameter
);
7815 Append_To
(Outer_Decls
,
7816 Make_Object_Declaration
(Loc
,
7817 Defining_Identifier
=>
7819 Object_Definition
=>
7820 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
7822 Append_To
(Outer_Statements
,
7823 Add_Parameter_To_NVList
(Loc
,
7824 Parameter
=> Extra_Parameter
,
7825 NVList
=> Arguments
,
7826 Constrained
=> True,
7830 Make_Object_Declaration
(Loc
,
7831 Defining_Identifier
=> Formal_Entity
,
7832 Object_Definition
=>
7833 New_Occurrence_Of
(Formal_Type
, Loc
)));
7835 Append_To
(Extra_Formal_Statements
,
7836 Make_Assignment_Statement
(Loc
,
7838 New_Occurrence_Of
(Extra_Parameter
, Loc
),
7840 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7841 Etype
(Extra_Parameter
),
7842 New_Occurrence_Of
(Extra_Any
, Loc
),
7844 Set_Extra_Constrained
(Object
, Formal_Entity
);
7850 Next
(Current_Parameter
);
7853 Append_To
(Outer_Statements
,
7854 Make_Procedure_Call_Statement
(Loc
,
7856 New_Occurrence_Of
(RTE
(RE_Request_Arguments
), Loc
),
7857 Parameter_Associations
=> New_List
(
7858 New_Occurrence_Of
(Request_Parameter
, Loc
),
7859 New_Occurrence_Of
(Arguments
, Loc
))));
7861 Append_List_To
(Statements
, Extra_Formal_Statements
);
7863 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
7865 -- The remote subprogram is a function. We build an inner block to
7866 -- be able to hold a potentially unconstrained result in a
7870 Etyp
: constant Entity_Id
:=
7871 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
7872 Result
: constant Node_Id
:=
7873 Make_Defining_Identifier
(Loc
,
7874 New_Internal_Name
('R'));
7876 Inner_Decls
:= New_List
(
7877 Make_Object_Declaration
(Loc
,
7878 Defining_Identifier
=> Result
,
7879 Constant_Present
=> True,
7880 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
7882 Make_Function_Call
(Loc
,
7883 Name
=> Called_Subprogram
,
7884 Parameter_Associations
=> Parameter_List
)));
7886 Set_Etype
(Result
, Etyp
);
7887 Append_To
(After_Statements
,
7888 Make_Procedure_Call_Statement
(Loc
,
7890 New_Occurrence_Of
(RTE
(RE_Set_Result
), Loc
),
7891 Parameter_Associations
=> New_List
(
7892 New_Occurrence_Of
(Request_Parameter
, Loc
),
7893 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7894 New_Occurrence_Of
(Result
, Loc
),
7896 -- A DSA function does not have out or inout arguments
7899 Append_To
(Statements
,
7900 Make_Block_Statement
(Loc
,
7901 Declarations
=> Inner_Decls
,
7902 Handled_Statement_Sequence
=>
7903 Make_Handled_Sequence_Of_Statements
(Loc
,
7904 Statements
=> After_Statements
)));
7907 -- The remote subprogram is a procedure. We do not need any inner
7908 -- block in this case. No specific processing is required here for
7909 -- the dynamically asynchronous case: the indication of whether
7910 -- call is asynchronous or not is managed by the Sync_Scope
7911 -- attibute of the request, and is handled entirely in the
7914 Append_To
(After_Statements
,
7915 Make_Procedure_Call_Statement
(Loc
,
7917 New_Occurrence_Of
(RTE
(RE_Request_Set_Out
), Loc
),
7918 Parameter_Associations
=> New_List
(
7919 New_Occurrence_Of
(Request_Parameter
, Loc
))));
7921 Append_To
(Statements
,
7922 Make_Procedure_Call_Statement
(Loc
,
7923 Name
=> Called_Subprogram
,
7924 Parameter_Associations
=> Parameter_List
));
7926 Append_List_To
(Statements
, After_Statements
);
7930 Make_Procedure_Specification
(Loc
,
7931 Defining_Unit_Name
=>
7932 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
7934 Parameter_Specifications
=> New_List
(
7935 Make_Parameter_Specification
(Loc
,
7936 Defining_Identifier
=> Request_Parameter
,
7938 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
7940 -- An exception raised during the execution of an incoming
7941 -- remote subprogram call and that needs to be sent back
7942 -- to the caller is propagated by the receiving stubs, and
7943 -- will be handled by the caller (the distribution runtime).
7945 if Asynchronous
and then not Dynamically_Asynchronous
then
7947 -- For an asynchronous procedure, add a null exception handler
7949 Excep_Handlers
:= New_List
(
7950 Make_Exception_Handler
(Loc
,
7951 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7952 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
7956 -- In the other cases, if an exception is raised, then the
7957 -- exception occurrence is propagated.
7962 Append_To
(Outer_Statements
,
7963 Make_Block_Statement
(Loc
,
7966 Handled_Statement_Sequence
=>
7967 Make_Handled_Sequence_Of_Statements
(Loc
,
7968 Statements
=> Statements
)));
7971 Make_Subprogram_Body
(Loc
,
7972 Specification
=> Subp_Spec
,
7973 Declarations
=> Outer_Decls
,
7974 Handled_Statement_Sequence
=>
7975 Make_Handled_Sequence_Of_Statements
(Loc
,
7976 Statements
=> Outer_Statements
,
7977 Exception_Handlers
=> Excep_Handlers
));
7978 end Build_Subprogram_Receiving_Stubs
;
7983 package body Helpers
is
7985 -----------------------
7986 -- Local Subprograms --
7987 -----------------------
7989 function Find_Numeric_Representation
7990 (Typ
: Entity_Id
) return Entity_Id
;
7991 -- Given a numeric type Typ, return the smallest integer or floarting
7992 -- point type from Standard, or the smallest unsigned (modular) type
7993 -- from System.Unsigned_Types, whose range encompasses that of Typ.
7995 function Make_Stream_Procedure_Function_Name
7998 Nam
: Name_Id
) return Entity_Id
;
7999 -- Return the name to be assigned for stream subprogram Nam of Typ.
8000 -- (copied from exp_strm.adb, should be shared???)
8002 ------------------------------------------------------------
8003 -- Common subprograms for building various tree fragments --
8004 ------------------------------------------------------------
8006 function Build_Get_Aggregate_Element
8010 Idx
: Node_Id
) return Node_Id
;
8011 -- Build a call to Get_Aggregate_Element on Any
8012 -- for typecode TC, returning the Idx'th element.
8015 Subprogram
: Entity_Id
;
8016 -- Reference location for constructed nodes
8019 -- For 'Range and Etype
8022 -- For the construction of the innermost element expression
8024 with procedure Add_Process_Element
8027 Counter
: Entity_Id
;
8030 procedure Append_Array_Traversal
8033 Counter
: Entity_Id
:= Empty
;
8035 -- Build nested loop statements that iterate over the elements of an
8036 -- array Arry. The statement(s) built by Add_Process_Element are
8037 -- executed for each element; Indices is the list of indices to be
8038 -- used in the construction of the indexed component that denotes the
8039 -- current element. Subprogram is the entity for the subprogram for
8040 -- which this iterator is generated. The generated statements are
8041 -- appended to Stmts.
8045 -- The record entity being dealt with
8047 with procedure Add_Process_Element
8049 Container
: Node_Or_Entity_Id
;
8050 Counter
: in out Int
;
8053 -- Rec is the instance of the record type, or Empty.
8054 -- Field is either the N_Defining_Identifier for a component,
8055 -- or an N_Variant_Part.
8057 procedure Append_Record_Traversal
8060 Container
: Node_Or_Entity_Id
;
8061 Counter
: in out Int
);
8062 -- Process component list Clist. Individual fields are passed
8063 -- to Field_Processing. Each variant part is also processed.
8064 -- Container is the outer Any (for From_Any/To_Any),
8065 -- the outer typecode (for TC) to which the operation applies.
8067 -----------------------------
8068 -- Append_Record_Traversal --
8069 -----------------------------
8071 procedure Append_Record_Traversal
8074 Container
: Node_Or_Entity_Id
;
8075 Counter
: in out Int
)
8077 CI
: constant List_Id
:= Component_Items
(Clist
);
8078 VP
: constant Node_Id
:= Variant_Part
(Clist
);
8080 Item
: Node_Id
:= First
(CI
);
8084 while Present
(Item
) loop
8085 Def
:= Defining_Identifier
(Item
);
8086 if not Is_Internal_Name
(Chars
(Def
)) then
8088 (Stmts
, Container
, Counter
, Rec
, Def
);
8093 if Present
(VP
) then
8094 Add_Process_Element
(Stmts
, Container
, Counter
, Rec
, VP
);
8096 end Append_Record_Traversal
;
8098 -------------------------
8099 -- Build_From_Any_Call --
8100 -------------------------
8102 function Build_From_Any_Call
8105 Decls
: List_Id
) return Node_Id
8107 Loc
: constant Source_Ptr
:= Sloc
(N
);
8109 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
8111 Fnam
: Entity_Id
:= Empty
;
8112 Lib_RE
: RE_Id
:= RE_Null
;
8116 -- First simple case where the From_Any function is present
8117 -- in the type's TSS.
8119 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_From_Any
);
8121 if Sloc
(U_Type
) <= Standard_Location
then
8122 U_Type
:= Base_Type
(U_Type
);
8125 -- Check first for Boolean and Character. These are enumeration
8126 -- types, but we treat them specially, since they may require
8127 -- special handling in the transfer protocol. However, this
8128 -- special handling only applies if they have standard
8129 -- representation, otherwise they are treated like any other
8130 -- enumeration type.
8132 if Present
(Fnam
) then
8135 elsif U_Type
= Standard_Boolean
then
8138 elsif U_Type
= Standard_Character
then
8141 elsif U_Type
= Standard_Wide_Character
then
8144 elsif U_Type
= Standard_Wide_Wide_Character
then
8145 Lib_RE
:= RE_FA_WWC
;
8147 -- Floating point types
8149 elsif U_Type
= Standard_Short_Float
then
8152 elsif U_Type
= Standard_Float
then
8155 elsif U_Type
= Standard_Long_Float
then
8158 elsif U_Type
= Standard_Long_Long_Float
then
8159 Lib_RE
:= RE_FA_LLF
;
8163 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
8164 Lib_RE
:= RE_FA_SSI
;
8166 elsif U_Type
= Etype
(Standard_Short_Integer
) then
8169 elsif U_Type
= Etype
(Standard_Integer
) then
8172 elsif U_Type
= Etype
(Standard_Long_Integer
) then
8175 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
8176 Lib_RE
:= RE_FA_LLI
;
8178 -- Unsigned integer types
8180 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
8181 Lib_RE
:= RE_FA_SSU
;
8183 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
8186 elsif U_Type
= RTE
(RE_Unsigned
) then
8189 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
8192 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
8193 Lib_RE
:= RE_FA_LLU
;
8195 elsif U_Type
= Standard_String
then
8196 Lib_RE
:= RE_FA_String
;
8198 -- Other (non-primitive) types
8204 Build_From_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
8205 Append_To
(Decls
, Decl
);
8209 -- Call the function
8211 if Lib_RE
/= RE_Null
then
8212 pragma Assert
(No
(Fnam
));
8213 Fnam
:= RTE
(Lib_RE
);
8217 Make_Function_Call
(Loc
,
8218 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
8219 Parameter_Associations
=> New_List
(N
));
8220 end Build_From_Any_Call
;
8222 -----------------------------
8223 -- Build_From_Any_Function --
8224 -----------------------------
8226 procedure Build_From_Any_Function
8230 Fnam
: out Entity_Id
)
8233 Decls
: constant List_Id
:= New_List
;
8234 Stms
: constant List_Id
:= New_List
;
8235 Any_Parameter
: constant Entity_Id
8236 := Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
8238 Fnam
:= Make_Stream_Procedure_Function_Name
(Loc
,
8239 Typ
, Name_uFrom_Any
);
8242 Make_Function_Specification
(Loc
,
8243 Defining_Unit_Name
=> Fnam
,
8244 Parameter_Specifications
=> New_List
(
8245 Make_Parameter_Specification
(Loc
,
8246 Defining_Identifier
=>
8249 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
8250 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
8252 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8255 (not (Is_Remote_Access_To_Class_Wide_Type
(Typ
)));
8257 if Is_Derived_Type
(Typ
)
8258 and then not Is_Tagged_Type
(Typ
)
8261 Make_Return_Statement
(Loc
,
8265 Build_From_Any_Call
(
8267 New_Occurrence_Of
(Any_Parameter
, Loc
),
8270 elsif Is_Record_Type
(Typ
)
8271 and then not Is_Derived_Type
(Typ
)
8272 and then not Is_Tagged_Type
(Typ
)
8274 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
8276 Make_Return_Statement
(Loc
,
8280 Build_From_Any_Call
(
8282 New_Occurrence_Of
(Any_Parameter
, Loc
),
8286 Disc
: Entity_Id
:= Empty
;
8287 Discriminant_Associations
: List_Id
;
8288 Rdef
: constant Node_Id
:=
8289 Type_Definition
(Declaration_Node
(Typ
));
8290 Component_Counter
: Int
:= 0;
8292 -- The returned object
8294 Res
: constant Entity_Id
:=
8295 Make_Defining_Identifier
(Loc
,
8296 New_Internal_Name
('R'));
8298 Res_Definition
: Node_Id
:= New_Occurrence_Of
(Typ
, Loc
);
8300 procedure FA_Rec_Add_Process_Element
8303 Counter
: in out Int
;
8307 procedure FA_Append_Record_Traversal
is
8308 new Append_Record_Traversal
8310 Add_Process_Element
=> FA_Rec_Add_Process_Element
);
8312 --------------------------------
8313 -- FA_Rec_Add_Process_Element --
8314 --------------------------------
8316 procedure FA_Rec_Add_Process_Element
8319 Counter
: in out Int
;
8324 if Nkind
(Field
) = N_Defining_Identifier
then
8326 -- A regular component
8329 Make_Assignment_Statement
(Loc
,
8330 Name
=> Make_Selected_Component
(Loc
,
8332 New_Occurrence_Of
(Rec
, Loc
),
8334 New_Occurrence_Of
(Field
, Loc
)),
8336 Build_From_Any_Call
(Etype
(Field
),
8337 Build_Get_Aggregate_Element
(Loc
,
8339 Tc
=> Build_TypeCode_Call
(Loc
,
8340 Etype
(Field
), Decls
),
8341 Idx
=> Make_Integer_Literal
(Loc
,
8350 Struct_Counter
: Int
:= 0;
8352 Block_Decls
: constant List_Id
:= New_List
;
8353 Block_Stmts
: constant List_Id
:= New_List
;
8356 Alt_List
: constant List_Id
:= New_List
;
8357 Choice_List
: List_Id
;
8359 Struct_Any
: constant Entity_Id
:=
8360 Make_Defining_Identifier
(Loc
,
8361 New_Internal_Name
('S'));
8365 Make_Object_Declaration
(Loc
,
8366 Defining_Identifier
=>
8370 Object_Definition
=>
8371 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8373 Make_Function_Call
(Loc
,
8374 Name
=> New_Occurrence_Of
(
8375 RTE
(RE_Extract_Union_Value
), Loc
),
8376 Parameter_Associations
=> New_List
(
8377 Build_Get_Aggregate_Element
(Loc
,
8379 Tc
=> Make_Function_Call
(Loc
,
8380 Name
=> New_Occurrence_Of
(
8381 RTE
(RE_Any_Member_Type
), Loc
),
8382 Parameter_Associations
=>
8384 New_Occurrence_Of
(Any
, Loc
),
8385 Make_Integer_Literal
(Loc
,
8387 Idx
=> Make_Integer_Literal
(Loc
,
8391 Make_Block_Statement
(Loc
,
8394 Handled_Statement_Sequence
=>
8395 Make_Handled_Sequence_Of_Statements
(Loc
,
8396 Statements
=> Block_Stmts
)));
8398 Append_To
(Block_Stmts
,
8399 Make_Case_Statement
(Loc
,
8401 Make_Selected_Component
(Loc
,
8404 Chars
(Name
(Field
))),
8408 Variant
:= First_Non_Pragma
(Variants
(Field
));
8410 while Present
(Variant
) loop
8411 Choice_List
:= New_Copy_List_Tree
8412 (Discrete_Choices
(Variant
));
8414 VP_Stmts
:= New_List
;
8415 FA_Append_Record_Traversal
(
8417 Clist
=> Component_List
(Variant
),
8418 Container
=> Struct_Any
,
8419 Counter
=> Struct_Counter
);
8421 Append_To
(Alt_List
,
8422 Make_Case_Statement_Alternative
(Loc
,
8423 Discrete_Choices
=> Choice_List
,
8426 Next_Non_Pragma
(Variant
);
8430 Counter
:= Counter
+ 1;
8431 end FA_Rec_Add_Process_Element
;
8434 -- First all discriminants
8436 if Has_Discriminants
(Typ
) then
8437 Disc
:= First_Discriminant
(Typ
);
8438 Discriminant_Associations
:= New_List
;
8440 while Present
(Disc
) loop
8442 Disc_Var_Name
: constant Entity_Id
:=
8443 Make_Defining_Identifier
(Loc
, Chars
(Disc
));
8444 Disc_Type
: constant Entity_Id
:=
8448 Make_Object_Declaration
(Loc
,
8449 Defining_Identifier
=>
8451 Constant_Present
=> True,
8452 Object_Definition
=>
8453 New_Occurrence_Of
(Disc_Type
, Loc
),
8455 Build_From_Any_Call
(Etype
(Disc
),
8456 Build_Get_Aggregate_Element
(Loc
,
8457 Any
=> Any_Parameter
,
8458 Tc
=> Build_TypeCode_Call
8459 (Loc
, Etype
(Disc
), Decls
),
8460 Idx
=> Make_Integer_Literal
8461 (Loc
, Component_Counter
)),
8463 Component_Counter
:= Component_Counter
+ 1;
8465 Append_To
(Discriminant_Associations
,
8466 Make_Discriminant_Association
(Loc
,
8467 Selector_Names
=> New_List
(
8468 New_Occurrence_Of
(Disc
, Loc
)),
8470 New_Occurrence_Of
(Disc_Var_Name
, Loc
)));
8472 Next_Discriminant
(Disc
);
8475 Res_Definition
:= Make_Subtype_Indication
(Loc
,
8476 Subtype_Mark
=> Res_Definition
,
8478 Make_Index_Or_Discriminant_Constraint
(Loc
,
8479 Discriminant_Associations
));
8482 -- Now we have all the discriminants in variables, we can
8483 -- declared a constrained object. Note that we are not
8484 -- initializing (non-discriminant) components directly in
8485 -- the object declarations, because which fields to
8486 -- initialize depends (at run time) on the discriminant
8490 Make_Object_Declaration
(Loc
,
8491 Defining_Identifier
=>
8493 Object_Definition
=>
8496 -- ... then all components
8498 FA_Append_Record_Traversal
(Stms
,
8499 Clist
=> Component_List
(Rdef
),
8500 Container
=> Any_Parameter
,
8501 Counter
=> Component_Counter
);
8504 Make_Return_Statement
(Loc
,
8505 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
8509 elsif Is_Array_Type
(Typ
) then
8511 Constrained
: constant Boolean := Is_Constrained
(Typ
);
8513 procedure FA_Ary_Add_Process_Element
8516 Counter
: Entity_Id
;
8518 -- Assign the current element (as identified by Counter) of
8519 -- Any to the variable denoted by name Datum, and advance
8520 -- Counter by 1. If Datum is not an Any, a call to From_Any
8521 -- for its type is inserted.
8523 --------------------------------
8524 -- FA_Ary_Add_Process_Element --
8525 --------------------------------
8527 procedure FA_Ary_Add_Process_Element
8530 Counter
: Entity_Id
;
8533 Assignment
: constant Node_Id
:=
8534 Make_Assignment_Statement
(Loc
,
8536 Expression
=> Empty
);
8538 Element_Any
: constant Node_Id
:=
8539 Build_Get_Aggregate_Element
(Loc
,
8541 Tc
=> Build_TypeCode_Call
(Loc
,
8542 Etype
(Datum
), Decls
),
8543 Idx
=> New_Occurrence_Of
(Counter
, Loc
));
8546 -- Note: here we *prepend* statements to Stmts, so
8547 -- we must do it in reverse order.
8550 Make_Assignment_Statement
(Loc
,
8552 New_Occurrence_Of
(Counter
, Loc
),
8556 New_Occurrence_Of
(Counter
, Loc
),
8558 Make_Integer_Literal
(Loc
, 1))));
8560 if Nkind
(Datum
) /= N_Attribute_Reference
then
8562 -- We ignore the value of the length of each
8563 -- dimension, since the target array has already
8564 -- been constrained anyway.
8566 if Etype
(Datum
) /= RTE
(RE_Any
) then
8567 Set_Expression
(Assignment
,
8568 Build_From_Any_Call
(
8569 Component_Type
(Typ
),
8573 Set_Expression
(Assignment
, Element_Any
);
8575 Prepend_To
(Stmts
, Assignment
);
8577 end FA_Ary_Add_Process_Element
;
8579 Counter
: constant Entity_Id
:=
8580 Make_Defining_Identifier
(Loc
, Name_J
);
8582 Initial_Counter_Value
: Int
:= 0;
8584 Component_TC
: constant Entity_Id
:=
8585 Make_Defining_Identifier
(Loc
, Name_T
);
8587 Res
: constant Entity_Id
:=
8588 Make_Defining_Identifier
(Loc
, Name_R
);
8590 procedure Append_From_Any_Array_Iterator
is
8591 new Append_Array_Traversal
(
8594 Indices
=> New_List
,
8595 Add_Process_Element
=> FA_Ary_Add_Process_Element
);
8597 Res_Subtype_Indication
: Node_Id
:=
8598 New_Occurrence_Of
(Typ
, Loc
);
8601 if not Constrained
then
8603 Ndim
: constant Int
:= Number_Dimensions
(Typ
);
8606 Indx
: Node_Id
:= First_Index
(Typ
);
8609 Ranges
: constant List_Id
:= New_List
;
8612 for J
in 1 .. Ndim
loop
8613 Lnam
:= New_External_Name
('L', J
);
8614 Hnam
:= New_External_Name
('H', J
);
8615 Indt
:= Etype
(Indx
);
8618 Make_Object_Declaration
(Loc
,
8619 Defining_Identifier
=>
8620 Make_Defining_Identifier
(Loc
, Lnam
),
8623 Object_Definition
=>
8624 New_Occurrence_Of
(Indt
, Loc
),
8626 Build_From_Any_Call
(
8628 Build_Get_Aggregate_Element
(Loc
,
8629 Any
=> Any_Parameter
,
8630 Tc
=> Build_TypeCode_Call
(Loc
,
8632 Idx
=> Make_Integer_Literal
(Loc
, J
- 1)),
8636 Make_Object_Declaration
(Loc
,
8637 Defining_Identifier
=>
8638 Make_Defining_Identifier
(Loc
, Hnam
),
8641 Object_Definition
=>
8642 New_Occurrence_Of
(Indt
, Loc
),
8643 Expression
=> Make_Attribute_Reference
(Loc
,
8645 New_Occurrence_Of
(Indt
, Loc
),
8646 Attribute_Name
=> Name_Val
,
8647 Expressions
=> New_List
(
8648 Make_Op_Subtract
(Loc
,
8652 Make_Attribute_Reference
(Loc
,
8654 New_Occurrence_Of
(Indt
, Loc
),
8657 Expressions
=> New_List
(
8658 Make_Identifier
(Loc
, Lnam
))),
8660 Make_Function_Call
(Loc
,
8661 Name
=> New_Occurrence_Of
(RTE
(
8662 RE_Get_Nested_Sequence_Length
),
8664 Parameter_Associations
=>
8667 Any_Parameter
, Loc
),
8668 Make_Integer_Literal
(Loc
,
8671 Make_Integer_Literal
(Loc
, 1))))));
8675 Low_Bound
=> Make_Identifier
(Loc
, Lnam
),
8676 High_Bound
=> Make_Identifier
(Loc
, Hnam
)));
8681 -- Now we have all the necessary bound information:
8682 -- apply the set of range constraints to the
8683 -- (unconstrained) nominal subtype of Res.
8685 Initial_Counter_Value
:= Ndim
;
8686 Res_Subtype_Indication
:= Make_Subtype_Indication
(Loc
,
8688 Res_Subtype_Indication
,
8690 Make_Index_Or_Discriminant_Constraint
(Loc
,
8691 Constraints
=> Ranges
));
8696 Make_Object_Declaration
(Loc
,
8697 Defining_Identifier
=> Res
,
8698 Object_Definition
=> Res_Subtype_Indication
));
8699 Set_Etype
(Res
, Typ
);
8702 Make_Object_Declaration
(Loc
,
8703 Defining_Identifier
=> Counter
,
8704 Object_Definition
=>
8705 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
8707 Make_Integer_Literal
(Loc
, Initial_Counter_Value
)));
8710 Make_Object_Declaration
(Loc
,
8711 Defining_Identifier
=> Component_TC
,
8712 Constant_Present
=> True,
8713 Object_Definition
=>
8714 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
),
8716 Build_TypeCode_Call
(Loc
,
8717 Component_Type
(Typ
), Decls
)));
8719 Append_From_Any_Array_Iterator
(Stms
,
8720 Any_Parameter
, Counter
);
8723 Make_Return_Statement
(Loc
,
8724 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
8727 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
8729 Make_Return_Statement
(Loc
,
8731 Unchecked_Convert_To
(
8733 Build_From_Any_Call
(
8734 Find_Numeric_Representation
(Typ
),
8735 New_Occurrence_Of
(Any_Parameter
, Loc
),
8739 -- Default: type is represented as an opaque sequence of bytes
8742 Strm
: constant Entity_Id
:=
8743 Make_Defining_Identifier
(Loc
,
8744 Chars
=> New_Internal_Name
('S'));
8745 Res
: constant Entity_Id
:=
8746 Make_Defining_Identifier
(Loc
,
8747 Chars
=> New_Internal_Name
('R'));
8750 -- Strm : Buffer_Stream_Type;
8753 Make_Object_Declaration
(Loc
,
8754 Defining_Identifier
=>
8758 Object_Definition
=>
8759 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
8761 -- Any_To_BS (Strm, A);
8764 Make_Procedure_Call_Statement
(Loc
,
8766 New_Occurrence_Of
(RTE
(RE_Any_To_BS
), Loc
),
8767 Parameter_Associations
=> New_List
(
8768 New_Occurrence_Of
(Any_Parameter
, Loc
),
8769 New_Occurrence_Of
(Strm
, Loc
))));
8772 -- Res : constant T := T'Input (Strm);
8774 -- Release_Buffer (Strm);
8778 Append_To
(Stms
, Make_Block_Statement
(Loc
,
8779 Declarations
=> New_List
(
8780 Make_Object_Declaration
(Loc
,
8781 Defining_Identifier
=> Res
,
8782 Constant_Present
=> True,
8783 Object_Definition
=>
8784 New_Occurrence_Of
(Typ
, Loc
),
8786 Make_Attribute_Reference
(Loc
,
8787 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
8788 Attribute_Name
=> Name_Input
,
8789 Expressions
=> New_List
(
8790 Make_Attribute_Reference
(Loc
,
8791 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
8792 Attribute_Name
=> Name_Access
))))),
8794 Handled_Statement_Sequence
=>
8795 Make_Handled_Sequence_Of_Statements
(Loc
,
8796 Statements
=> New_List
(
8797 Make_Procedure_Call_Statement
(Loc
,
8799 New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
8800 Parameter_Associations
=>
8802 New_Occurrence_Of
(Strm
, Loc
))),
8803 Make_Return_Statement
(Loc
,
8804 Expression
=> New_Occurrence_Of
(Res
, Loc
))))));
8810 Make_Subprogram_Body
(Loc
,
8811 Specification
=> Spec
,
8812 Declarations
=> Decls
,
8813 Handled_Statement_Sequence
=>
8814 Make_Handled_Sequence_Of_Statements
(Loc
,
8815 Statements
=> Stms
));
8816 end Build_From_Any_Function
;
8818 ---------------------------------
8819 -- Build_Get_Aggregate_Element --
8820 ---------------------------------
8822 function Build_Get_Aggregate_Element
8826 Idx
: Node_Id
) return Node_Id
8829 return Make_Function_Call
(Loc
,
8832 RTE
(RE_Get_Aggregate_Element
), Loc
),
8833 Parameter_Associations
=> New_List
(
8834 New_Occurrence_Of
(Any
, Loc
),
8837 end Build_Get_Aggregate_Element
;
8839 -------------------------
8840 -- Build_Reposiroty_Id --
8841 -------------------------
8843 procedure Build_Name_And_Repository_Id
8845 Name_Str
: out String_Id
;
8846 Repo_Id_Str
: out String_Id
)
8850 Store_String_Chars
("DSA:");
8851 Get_Library_Unit_Name_String
(Scope
(E
));
8852 Store_String_Chars
(
8853 Name_Buffer
(Name_Buffer
'First
8854 .. Name_Buffer
'First + Name_Len
- 1));
8855 Store_String_Char
('.');
8856 Get_Name_String
(Chars
(E
));
8857 Store_String_Chars
(
8858 Name_Buffer
(Name_Buffer
'First
8859 .. Name_Buffer
'First + Name_Len
- 1));
8860 Store_String_Chars
(":1.0");
8861 Repo_Id_Str
:= End_String
;
8862 Name_Str
:= String_From_Name_Buffer
;
8863 end Build_Name_And_Repository_Id
;
8865 -----------------------
8866 -- Build_To_Any_Call --
8867 -----------------------
8869 function Build_To_Any_Call
8871 Decls
: List_Id
) return Node_Id
8873 Loc
: constant Source_Ptr
:= Sloc
(N
);
8875 Typ
: Entity_Id
:= Etype
(N
);
8878 Fnam
: Entity_Id
:= Empty
;
8879 Lib_RE
: RE_Id
:= RE_Null
;
8882 -- If N is a selected component, then maybe its Etype
8883 -- has not been set yet: try to use the Etype of the
8884 -- selector_name in that case.
8886 if No
(Typ
) and then Nkind
(N
) = N_Selected_Component
then
8887 Typ
:= Etype
(Selector_Name
(N
));
8889 pragma Assert
(Present
(Typ
));
8891 -- The full view, if Typ is private; the completion,
8892 -- if Typ is incomplete.
8894 U_Type
:= Underlying_Type
(Typ
);
8896 -- First simple case where the To_Any function is present
8897 -- in the type's TSS.
8899 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_To_Any
);
8901 -- Check first for Boolean and Character. These are enumeration
8902 -- types, but we treat them specially, since they may require
8903 -- special handling in the transfer protocol. However, this
8904 -- special handling only applies if they have standard
8905 -- representation, otherwise they are treated like any other
8906 -- enumeration type.
8908 if Sloc
(U_Type
) <= Standard_Location
then
8909 U_Type
:= Base_Type
(U_Type
);
8912 if Present
(Fnam
) then
8915 elsif U_Type
= Standard_Boolean
then
8918 elsif U_Type
= Standard_Character
then
8921 elsif U_Type
= Standard_Wide_Character
then
8924 elsif U_Type
= Standard_Wide_Wide_Character
then
8925 Lib_RE
:= RE_TA_WWC
;
8927 -- Floating point types
8929 elsif U_Type
= Standard_Short_Float
then
8932 elsif U_Type
= Standard_Float
then
8935 elsif U_Type
= Standard_Long_Float
then
8938 elsif U_Type
= Standard_Long_Long_Float
then
8939 Lib_RE
:= RE_TA_LLF
;
8943 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
8944 Lib_RE
:= RE_TA_SSI
;
8946 elsif U_Type
= Etype
(Standard_Short_Integer
) then
8949 elsif U_Type
= Etype
(Standard_Integer
) then
8952 elsif U_Type
= Etype
(Standard_Long_Integer
) then
8955 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
8956 Lib_RE
:= RE_TA_LLI
;
8958 -- Unsigned integer types
8960 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
8961 Lib_RE
:= RE_TA_SSU
;
8963 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
8966 elsif U_Type
= RTE
(RE_Unsigned
) then
8969 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
8972 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
8973 Lib_RE
:= RE_TA_LLU
;
8975 elsif U_Type
= Standard_String
then
8976 Lib_RE
:= RE_TA_String
;
8978 elsif U_Type
= Underlying_Type
(RTE
(RE_TypeCode
)) then
8981 -- Other (non-primitive) types
8987 Build_To_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
8988 Append_To
(Decls
, Decl
);
8992 -- Call the function
8994 if Lib_RE
/= RE_Null
then
8995 pragma Assert
(No
(Fnam
));
8996 Fnam
:= RTE
(Lib_RE
);
9000 Make_Function_Call
(Loc
,
9001 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
9002 Parameter_Associations
=> New_List
(N
));
9003 end Build_To_Any_Call
;
9005 ---------------------------
9006 -- Build_To_Any_Function --
9007 ---------------------------
9009 procedure Build_To_Any_Function
9013 Fnam
: out Entity_Id
)
9016 Decls
: constant List_Id
:= New_List
;
9017 Stms
: constant List_Id
:= New_List
;
9019 Expr_Parameter
: constant Entity_Id
:=
9020 Make_Defining_Identifier
(Loc
, Name_E
);
9022 Any
: constant Entity_Id
:=
9023 Make_Defining_Identifier
(Loc
, Name_A
);
9026 Result_TC
: Node_Id
:= Build_TypeCode_Call
(Loc
, Typ
, Decls
);
9029 Fnam
:= Make_Stream_Procedure_Function_Name
(Loc
,
9033 Make_Function_Specification
(Loc
,
9034 Defining_Unit_Name
=> Fnam
,
9035 Parameter_Specifications
=> New_List
(
9036 Make_Parameter_Specification
(Loc
,
9037 Defining_Identifier
=>
9040 New_Occurrence_Of
(Typ
, Loc
))),
9041 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9042 Set_Etype
(Expr_Parameter
, Typ
);
9045 Make_Object_Declaration
(Loc
,
9046 Defining_Identifier
=>
9048 Object_Definition
=>
9049 New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9051 if Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9053 Rt_Type
: constant Entity_Id
9055 Expr
: constant Node_Id
9058 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9060 Set_Expression
(Any_Decl
, Build_To_Any_Call
(Expr
, Decls
));
9063 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9064 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
9066 Rt_Type
: constant Entity_Id
9068 Expr
: constant Node_Id
9071 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9074 Set_Expression
(Any_Decl
,
9075 Build_To_Any_Call
(Expr
, Decls
));
9080 Disc
: Entity_Id
:= Empty
;
9081 Rdef
: constant Node_Id
:=
9082 Type_Definition
(Declaration_Node
(Typ
));
9084 Elements
: constant List_Id
:= New_List
;
9086 procedure TA_Rec_Add_Process_Element
9088 Container
: Node_Or_Entity_Id
;
9089 Counter
: in out Int
;
9093 procedure TA_Append_Record_Traversal
is
9094 new Append_Record_Traversal
9095 (Rec
=> Expr_Parameter
,
9096 Add_Process_Element
=> TA_Rec_Add_Process_Element
);
9098 --------------------------------
9099 -- TA_Rec_Add_Process_Element --
9100 --------------------------------
9102 procedure TA_Rec_Add_Process_Element
9104 Container
: Node_Or_Entity_Id
;
9105 Counter
: in out Int
;
9109 Field_Ref
: Node_Id
;
9112 if Nkind
(Field
) = N_Defining_Identifier
then
9114 -- A regular component
9116 Field_Ref
:= Make_Selected_Component
(Loc
,
9117 Prefix
=> New_Occurrence_Of
(Rec
, Loc
),
9118 Selector_Name
=> New_Occurrence_Of
(Field
, Loc
));
9119 Set_Etype
(Field_Ref
, Etype
(Field
));
9122 Make_Procedure_Call_Statement
(Loc
,
9125 RTE
(RE_Add_Aggregate_Element
), Loc
),
9126 Parameter_Associations
=> New_List
(
9127 New_Occurrence_Of
(Any
, Loc
),
9128 Build_To_Any_Call
(Field_Ref
, Decls
))));
9135 Struct_Counter
: Int
:= 0;
9137 Block_Decls
: constant List_Id
:= New_List
;
9138 Block_Stmts
: constant List_Id
:= New_List
;
9141 Alt_List
: constant List_Id
:= New_List
;
9142 Choice_List
: List_Id
;
9144 Union_Any
: constant Entity_Id
:=
9145 Make_Defining_Identifier
(Loc
,
9146 New_Internal_Name
('U'));
9148 Struct_Any
: constant Entity_Id
:=
9149 Make_Defining_Identifier
(Loc
,
9150 New_Internal_Name
('S'));
9152 function Make_Discriminant_Reference
9154 -- Build a selected component for the
9155 -- discriminant of this variant part.
9157 ---------------------------------
9158 -- Make_Discriminant_Reference --
9159 ---------------------------------
9161 function Make_Discriminant_Reference
9164 Nod
: constant Node_Id
:=
9165 Make_Selected_Component
(Loc
,
9168 Chars
(Name
(Field
)));
9170 Set_Etype
(Nod
, Name
(Field
));
9172 end Make_Discriminant_Reference
;
9176 Make_Block_Statement
(Loc
,
9179 Handled_Statement_Sequence
=>
9180 Make_Handled_Sequence_Of_Statements
(Loc
,
9181 Statements
=> Block_Stmts
)));
9183 Append_To
(Block_Decls
,
9184 Make_Object_Declaration
(Loc
,
9185 Defining_Identifier
=> Union_Any
,
9186 Object_Definition
=>
9187 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9189 Make_Function_Call
(Loc
,
9190 Name
=> New_Occurrence_Of
(
9191 RTE
(RE_Create_Any
), Loc
),
9192 Parameter_Associations
=> New_List
(
9193 Make_Function_Call
(Loc
,
9196 RTE
(RE_Any_Member_Type
), Loc
),
9197 Parameter_Associations
=> New_List
(
9198 New_Occurrence_Of
(Container
, Loc
),
9199 Make_Integer_Literal
(Loc
,
9202 Append_To
(Block_Decls
,
9203 Make_Object_Declaration
(Loc
,
9204 Defining_Identifier
=> Struct_Any
,
9205 Object_Definition
=>
9206 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9208 Make_Function_Call
(Loc
,
9209 Name
=> New_Occurrence_Of
(
9210 RTE
(RE_Create_Any
), Loc
),
9211 Parameter_Associations
=> New_List
(
9212 Make_Function_Call
(Loc
,
9215 RTE
(RE_Any_Member_Type
), Loc
),
9216 Parameter_Associations
=> New_List
(
9217 New_Occurrence_Of
(Union_Any
, Loc
),
9218 Make_Integer_Literal
(Loc
,
9221 Append_To
(Block_Stmts
,
9222 Make_Case_Statement
(Loc
,
9224 Make_Discriminant_Reference
,
9228 Variant
:= First_Non_Pragma
(Variants
(Field
));
9229 while Present
(Variant
) loop
9230 Choice_List
:= New_Copy_List_Tree
9231 (Discrete_Choices
(Variant
));
9233 VP_Stmts
:= New_List
;
9234 TA_Append_Record_Traversal
(
9236 Clist
=> Component_List
(Variant
),
9237 Container
=> Struct_Any
,
9238 Counter
=> Struct_Counter
);
9240 -- Append discriminant value and inner struct
9241 -- to union aggregate.
9243 Append_To
(VP_Stmts
,
9244 Make_Procedure_Call_Statement
(Loc
,
9247 RTE
(RE_Add_Aggregate_Element
), Loc
),
9248 Parameter_Associations
=> New_List
(
9249 New_Occurrence_Of
(Union_Any
, Loc
),
9251 Make_Discriminant_Reference
,
9254 Append_To
(VP_Stmts
,
9255 Make_Procedure_Call_Statement
(Loc
,
9258 RTE
(RE_Add_Aggregate_Element
), Loc
),
9259 Parameter_Associations
=> New_List
(
9260 New_Occurrence_Of
(Union_Any
, Loc
),
9261 New_Occurrence_Of
(Struct_Any
, Loc
))));
9263 -- Append union to outer aggregate
9265 Append_To
(VP_Stmts
,
9266 Make_Procedure_Call_Statement
(Loc
,
9269 RTE
(RE_Add_Aggregate_Element
), Loc
),
9270 Parameter_Associations
=> New_List
(
9271 New_Occurrence_Of
(Container
, Loc
),
9272 Make_Function_Call
(Loc
,
9273 Name
=> New_Occurrence_Of
(
9274 RTE
(RE_Any_Aggregate_Build
), Loc
),
9275 Parameter_Associations
=> New_List
(
9277 Union_Any
, Loc
))))));
9279 Append_To
(Alt_List
,
9280 Make_Case_Statement_Alternative
(Loc
,
9281 Discrete_Choices
=> Choice_List
,
9284 Next_Non_Pragma
(Variant
);
9288 end TA_Rec_Add_Process_Element
;
9291 -- First all discriminants
9293 if Has_Discriminants
(Typ
) then
9294 Disc
:= First_Discriminant
(Typ
);
9296 while Present
(Disc
) loop
9297 Append_To
(Elements
,
9298 Make_Component_Association
(Loc
,
9299 Choices
=> New_List
(
9300 Make_Integer_Literal
(Loc
, Counter
)),
9303 Make_Selected_Component
(Loc
,
9304 Prefix
=> Expr_Parameter
,
9305 Selector_Name
=> Chars
(Disc
)),
9307 Counter
:= Counter
+ 1;
9308 Next_Discriminant
(Disc
);
9312 -- Make elements an empty array
9315 Dummy_Any
: constant Entity_Id
:=
9316 Make_Defining_Identifier
(Loc
,
9317 Chars
=> New_Internal_Name
('A'));
9321 Make_Object_Declaration
(Loc
,
9322 Defining_Identifier
=> Dummy_Any
,
9323 Object_Definition
=>
9324 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
9326 Append_To
(Elements
,
9327 Make_Component_Association
(Loc
,
9328 Choices
=> New_List
(
9331 Make_Integer_Literal
(Loc
, 1),
9333 Make_Integer_Literal
(Loc
, 0))),
9335 New_Occurrence_Of
(Dummy_Any
, Loc
)));
9339 Set_Expression
(Any_Decl
,
9340 Make_Function_Call
(Loc
,
9341 Name
=> New_Occurrence_Of
(
9342 RTE
(RE_Any_Aggregate_Build
), Loc
),
9343 Parameter_Associations
=> New_List
(
9345 Make_Aggregate
(Loc
,
9346 Component_Associations
=> Elements
))));
9349 -- ... then all components
9351 TA_Append_Record_Traversal
(Stms
,
9352 Clist
=> Component_List
(Rdef
),
9354 Counter
=> Counter
);
9358 elsif Is_Array_Type
(Typ
) then
9360 Constrained
: constant Boolean := Is_Constrained
(Typ
);
9362 procedure TA_Ary_Add_Process_Element
9365 Counter
: Entity_Id
;
9368 --------------------------------
9369 -- TA_Ary_Add_Process_Element --
9370 --------------------------------
9372 procedure TA_Ary_Add_Process_Element
9375 Counter
: Entity_Id
;
9378 pragma Warnings
(Off
);
9379 pragma Unreferenced
(Counter
);
9380 pragma Warnings
(On
);
9382 Element_Any
: Node_Id
;
9385 if Etype
(Datum
) = RTE
(RE_Any
) then
9386 Element_Any
:= Datum
;
9388 Element_Any
:= Build_To_Any_Call
(Datum
, Decls
);
9392 Make_Procedure_Call_Statement
(Loc
,
9393 Name
=> New_Occurrence_Of
(
9394 RTE
(RE_Add_Aggregate_Element
), Loc
),
9395 Parameter_Associations
=> New_List
(
9396 New_Occurrence_Of
(Any
, Loc
),
9398 end TA_Ary_Add_Process_Element
;
9400 procedure Append_To_Any_Array_Iterator
is
9401 new Append_Array_Traversal
(
9403 Arry
=> Expr_Parameter
,
9404 Indices
=> New_List
,
9405 Add_Process_Element
=> TA_Ary_Add_Process_Element
);
9410 Set_Expression
(Any_Decl
,
9411 Make_Function_Call
(Loc
,
9413 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
9414 Parameter_Associations
=> New_List
(Result_TC
)));
9417 if not Constrained
then
9418 Index
:= First_Index
(Typ
);
9419 for J
in 1 .. Number_Dimensions
(Typ
) loop
9421 Make_Procedure_Call_Statement
(Loc
,
9424 RTE
(RE_Add_Aggregate_Element
), Loc
),
9425 Parameter_Associations
=> New_List
(
9426 New_Occurrence_Of
(Any
, Loc
),
9428 OK_Convert_To
(Etype
(Index
),
9429 Make_Attribute_Reference
(Loc
,
9431 New_Occurrence_Of
(Expr_Parameter
, Loc
),
9432 Attribute_Name
=> Name_First
,
9433 Expressions
=> New_List
(
9434 Make_Integer_Literal
(Loc
, J
)))),
9440 Append_To_Any_Array_Iterator
(Stms
, Any
);
9443 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9444 Set_Expression
(Any_Decl
,
9447 Find_Numeric_Representation
(Typ
),
9448 New_Occurrence_Of
(Expr_Parameter
, Loc
)),
9452 -- Default: type is represented as an opaque sequence of bytes
9455 Strm
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
9456 New_Internal_Name
('S'));
9459 -- Strm : aliased Buffer_Stream_Type;
9462 Make_Object_Declaration
(Loc
,
9463 Defining_Identifier
=>
9467 Object_Definition
=>
9468 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
9470 -- Allocate_Buffer (Strm);
9473 Make_Procedure_Call_Statement
(Loc
,
9475 New_Occurrence_Of
(RTE
(RE_Allocate_Buffer
), Loc
),
9476 Parameter_Associations
=> New_List
(
9477 New_Occurrence_Of
(Strm
, Loc
))));
9479 -- T'Output (Strm'Access, E);
9482 Make_Attribute_Reference
(Loc
,
9483 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
9484 Attribute_Name
=> Name_Output
,
9485 Expressions
=> New_List
(
9486 Make_Attribute_Reference
(Loc
,
9487 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
9488 Attribute_Name
=> Name_Access
),
9489 New_Occurrence_Of
(Expr_Parameter
, Loc
))));
9491 -- BS_To_Any (Strm, A);
9494 Make_Procedure_Call_Statement
(Loc
,
9496 New_Occurrence_Of
(RTE
(RE_BS_To_Any
), Loc
),
9497 Parameter_Associations
=> New_List
(
9498 New_Occurrence_Of
(Strm
, Loc
),
9499 New_Occurrence_Of
(Any
, Loc
))));
9501 -- Release_Buffer (Strm);
9504 Make_Procedure_Call_Statement
(Loc
,
9506 New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
9507 Parameter_Associations
=> New_List
(
9508 New_Occurrence_Of
(Strm
, Loc
))));
9512 Append_To
(Decls
, Any_Decl
);
9514 if Present
(Result_TC
) then
9516 Make_Procedure_Call_Statement
(Loc
,
9517 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
9518 Parameter_Associations
=> New_List
(
9519 New_Occurrence_Of
(Any
, Loc
),
9524 Make_Return_Statement
(Loc
,
9525 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
9528 Make_Subprogram_Body
(Loc
,
9529 Specification
=> Spec
,
9530 Declarations
=> Decls
,
9531 Handled_Statement_Sequence
=>
9532 Make_Handled_Sequence_Of_Statements
(Loc
,
9533 Statements
=> Stms
));
9534 end Build_To_Any_Function
;
9536 -------------------------
9537 -- Build_TypeCode_Call --
9538 -------------------------
9540 function Build_TypeCode_Call
9543 Decls
: List_Id
) return Node_Id
9545 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
9546 -- The full view, if Typ is private; the completion,
9547 -- if Typ is incomplete.
9549 Fnam
: Entity_Id
:= Empty
;
9550 Lib_RE
: RE_Id
:= RE_Null
;
9555 -- Special case System.PolyORB.Interface.Any: its primitives have
9556 -- not been set yet, so can't call Find_Inherited_TSS.
9558 if Typ
= RTE
(RE_Any
) then
9559 Fnam
:= RTE
(RE_TC_Any
);
9562 -- First simple case where the TypeCode is present
9563 -- in the type's TSS.
9565 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_TypeCode
);
9569 if Sloc
(U_Type
) <= Standard_Location
then
9571 -- Do not try to build alias typecodes for subtypes from
9574 U_Type
:= Base_Type
(U_Type
);
9577 if U_Type
= Standard_Boolean
then
9580 elsif U_Type
= Standard_Character
then
9583 elsif U_Type
= Standard_Wide_Character
then
9586 elsif U_Type
= Standard_Wide_Wide_Character
then
9587 Lib_RE
:= RE_TC_WWC
;
9589 -- Floating point types
9591 elsif U_Type
= Standard_Short_Float
then
9594 elsif U_Type
= Standard_Float
then
9597 elsif U_Type
= Standard_Long_Float
then
9600 elsif U_Type
= Standard_Long_Long_Float
then
9601 Lib_RE
:= RE_TC_LLF
;
9603 -- Integer types (walk back to the base type)
9605 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
9606 Lib_RE
:= RE_TC_SSI
;
9608 elsif U_Type
= Etype
(Standard_Short_Integer
) then
9611 elsif U_Type
= Etype
(Standard_Integer
) then
9614 elsif U_Type
= Etype
(Standard_Long_Integer
) then
9617 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
9618 Lib_RE
:= RE_TC_LLI
;
9620 -- Unsigned integer types
9622 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
9623 Lib_RE
:= RE_TC_SSU
;
9625 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
9628 elsif U_Type
= RTE
(RE_Unsigned
) then
9631 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
9634 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
9635 Lib_RE
:= RE_TC_LLU
;
9637 elsif U_Type
= Standard_String
then
9638 Lib_RE
:= RE_TC_String
;
9640 -- Other (non-primitive) types
9646 Build_TypeCode_Function
(Loc
, U_Type
, Decl
, Fnam
);
9647 Append_To
(Decls
, Decl
);
9651 if Lib_RE
/= RE_Null
then
9652 Fnam
:= RTE
(Lib_RE
);
9656 -- Call the function
9659 Make_Function_Call
(Loc
, Name
=> New_Occurrence_Of
(Fnam
, Loc
));
9661 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
9663 Set_Etype
(Expr
, RTE
(RE_TypeCode
));
9666 end Build_TypeCode_Call
;
9668 -----------------------------
9669 -- Build_TypeCode_Function --
9670 -----------------------------
9672 procedure Build_TypeCode_Function
9676 Fnam
: out Entity_Id
)
9679 Decls
: constant List_Id
:= New_List
;
9680 Stms
: constant List_Id
:= New_List
;
9682 TCNam
: constant Entity_Id
:=
9683 Make_Stream_Procedure_Function_Name
(Loc
,
9684 Typ
, Name_uTypeCode
);
9686 Parameters
: List_Id
;
9688 procedure Add_String_Parameter
9690 Parameter_List
: List_Id
);
9691 -- Add a literal for S to Parameters
9693 procedure Add_TypeCode_Parameter
9695 Parameter_List
: List_Id
);
9696 -- Add the typecode for Typ to Parameters
9698 procedure Add_Long_Parameter
9699 (Expr_Node
: Node_Id
;
9700 Parameter_List
: List_Id
);
9701 -- Add a signed long integer expression to Parameters
9703 procedure Initialize_Parameter_List
9704 (Name_String
: String_Id
;
9705 Repo_Id_String
: String_Id
;
9706 Parameter_List
: out List_Id
);
9707 -- Return a list that contains the first two parameters
9708 -- for a parameterized typecode: name and repository id.
9710 function Make_Constructed_TypeCode
9712 Parameters
: List_Id
) return Node_Id
;
9713 -- Call TC_Build with the given kind and parameters
9715 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
);
9716 -- Make a return statement that calls TC_Build with the given
9717 -- typecode kind, and the constructed parameters list.
9719 procedure Return_Alias_TypeCode
(Base_TypeCode
: Node_Id
);
9720 -- Return a typecode that is a TC_Alias for the given typecode
9722 --------------------------
9723 -- Add_String_Parameter --
9724 --------------------------
9726 procedure Add_String_Parameter
9728 Parameter_List
: List_Id
)
9731 Append_To
(Parameter_List
,
9732 Make_Function_Call
(Loc
,
9734 New_Occurrence_Of
(RTE
(RE_TA_String
), Loc
),
9735 Parameter_Associations
=> New_List
(
9736 Make_String_Literal
(Loc
, S
))));
9737 end Add_String_Parameter
;
9739 ----------------------------
9740 -- Add_TypeCode_Parameter --
9741 ----------------------------
9743 procedure Add_TypeCode_Parameter
9745 Parameter_List
: List_Id
)
9748 Append_To
(Parameter_List
,
9749 Make_Function_Call
(Loc
,
9751 New_Occurrence_Of
(RTE
(RE_TA_TC
), Loc
),
9752 Parameter_Associations
=> New_List
(
9754 end Add_TypeCode_Parameter
;
9756 ------------------------
9757 -- Add_Long_Parameter --
9758 ------------------------
9760 procedure Add_Long_Parameter
9761 (Expr_Node
: Node_Id
;
9762 Parameter_List
: List_Id
)
9765 Append_To
(Parameter_List
,
9766 Make_Function_Call
(Loc
,
9768 New_Occurrence_Of
(RTE
(RE_TA_LI
), Loc
),
9769 Parameter_Associations
=> New_List
(Expr_Node
)));
9770 end Add_Long_Parameter
;
9772 -------------------------------
9773 -- Initialize_Parameter_List --
9774 -------------------------------
9776 procedure Initialize_Parameter_List
9777 (Name_String
: String_Id
;
9778 Repo_Id_String
: String_Id
;
9779 Parameter_List
: out List_Id
)
9782 Parameter_List
:= New_List
;
9783 Add_String_Parameter
(Name_String
, Parameter_List
);
9784 Add_String_Parameter
(Repo_Id_String
, Parameter_List
);
9785 end Initialize_Parameter_List
;
9787 ---------------------------
9788 -- Return_Alias_TypeCode --
9789 ---------------------------
9791 procedure Return_Alias_TypeCode
9792 (Base_TypeCode
: Node_Id
)
9795 Add_TypeCode_Parameter
(Base_TypeCode
, Parameters
);
9796 Return_Constructed_TypeCode
(RTE
(RE_TC_Alias
));
9797 end Return_Alias_TypeCode
;
9799 -------------------------------
9800 -- Make_Constructed_TypeCode --
9801 -------------------------------
9803 function Make_Constructed_TypeCode
9805 Parameters
: List_Id
) return Node_Id
9807 Constructed_TC
: constant Node_Id
:=
9808 Make_Function_Call
(Loc
,
9810 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
9811 Parameter_Associations
=> New_List
(
9812 New_Occurrence_Of
(Kind
, Loc
),
9813 Make_Aggregate
(Loc
,
9814 Expressions
=> Parameters
)));
9816 Set_Etype
(Constructed_TC
, RTE
(RE_TypeCode
));
9817 return Constructed_TC
;
9818 end Make_Constructed_TypeCode
;
9820 ---------------------------------
9821 -- Return_Constructed_TypeCode --
9822 ---------------------------------
9824 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
) is
9827 Make_Return_Statement
(Loc
,
9829 Make_Constructed_TypeCode
(Kind
, Parameters
)));
9830 end Return_Constructed_TypeCode
;
9836 procedure TC_Rec_Add_Process_Element
9839 Counter
: in out Int
;
9843 procedure TC_Append_Record_Traversal
is
9844 new Append_Record_Traversal
(
9846 Add_Process_Element
=> TC_Rec_Add_Process_Element
);
9848 --------------------------------
9849 -- TC_Rec_Add_Process_Element --
9850 --------------------------------
9852 procedure TC_Rec_Add_Process_Element
9855 Counter
: in out Int
;
9859 pragma Warnings
(Off
);
9860 pragma Unreferenced
(Any
, Counter
, Rec
);
9861 pragma Warnings
(On
);
9864 if Nkind
(Field
) = N_Defining_Identifier
then
9866 -- A regular component
9868 Add_TypeCode_Parameter
(
9869 Build_TypeCode_Call
(Loc
, Etype
(Field
), Decls
), Params
);
9870 Get_Name_String
(Chars
(Field
));
9871 Add_String_Parameter
(String_From_Name_Buffer
, Params
);
9878 Discriminant_Type
: constant Entity_Id
:=
9879 Etype
(Name
(Field
));
9881 Is_Enum
: constant Boolean :=
9882 Is_Enumeration_Type
(Discriminant_Type
);
9884 Union_TC_Params
: List_Id
;
9886 U_Name
: constant Name_Id
:=
9887 New_External_Name
(Chars
(Typ
), 'U', -1);
9889 Name_Str
: String_Id
;
9890 Struct_TC_Params
: List_Id
;
9894 Default
: constant Node_Id
:=
9895 Make_Integer_Literal
(Loc
, -1);
9897 Dummy_Counter
: Int
:= 0;
9899 procedure Add_Params_For_Variant_Components
;
9900 -- Add a struct TypeCode and a corresponding member name
9901 -- to the union parameter list.
9903 -- Ordering of declarations is a complete mess in this
9904 -- area, it is supposed to be types/varibles, then
9905 -- subprogram specs, then subprogram bodies ???
9907 ---------------------------------------
9908 -- Add_Params_For_Variant_Components --
9909 ---------------------------------------
9911 procedure Add_Params_For_Variant_Components
9913 S_Name
: constant Name_Id
:=
9914 New_External_Name
(U_Name
, 'S', -1);
9917 Get_Name_String
(S_Name
);
9918 Name_Str
:= String_From_Name_Buffer
;
9919 Initialize_Parameter_List
9920 (Name_Str
, Name_Str
, Struct_TC_Params
);
9922 -- Build struct parameters
9924 TC_Append_Record_Traversal
(Struct_TC_Params
,
9925 Component_List
(Variant
),
9929 Add_TypeCode_Parameter
9930 (Make_Constructed_TypeCode
9931 (RTE
(RE_TC_Struct
), Struct_TC_Params
),
9934 Add_String_Parameter
(Name_Str
, Union_TC_Params
);
9935 end Add_Params_For_Variant_Components
;
9938 Get_Name_String
(U_Name
);
9939 Name_Str
:= String_From_Name_Buffer
;
9941 Initialize_Parameter_List
9942 (Name_Str
, Name_Str
, Union_TC_Params
);
9944 Add_String_Parameter
(Name_Str
, Params
);
9946 -- Add union in enclosing parameter list
9948 Add_TypeCode_Parameter
9949 (Make_Constructed_TypeCode
9950 (RTE
(RE_TC_Union
), Union_TC_Params
),
9953 -- Build union parameters
9955 Add_TypeCode_Parameter
9956 (Discriminant_Type
, Union_TC_Params
);
9957 Add_Long_Parameter
(Default
, Union_TC_Params
);
9959 Variant
:= First_Non_Pragma
(Variants
(Field
));
9960 while Present
(Variant
) loop
9961 Choice
:= First
(Discrete_Choices
(Variant
));
9962 while Present
(Choice
) loop
9963 case Nkind
(Choice
) is
9966 L
: constant Uint
:=
9967 Expr_Value
(Low_Bound
(Choice
));
9968 H
: constant Uint
:=
9969 Expr_Value
(High_Bound
(Choice
));
9971 -- 3.8.1(8) guarantees that the bounds of
9972 -- this range are static.
9979 Expr
:= New_Occurrence_Of
(
9980 Get_Enum_Lit_From_Pos
(
9981 Discriminant_Type
, J
, Loc
), Loc
);
9984 Make_Integer_Literal
(Loc
, J
);
9986 Append_To
(Union_TC_Params
,
9987 Build_To_Any_Call
(Expr
, Decls
));
9988 Add_Params_For_Variant_Components
;
9993 when N_Others_Choice
=>
9994 Add_Long_Parameter
(
9995 Make_Integer_Literal
(Loc
, 0),
9997 Add_Params_For_Variant_Components
;
10000 Append_To
(Union_TC_Params
,
10001 Build_To_Any_Call
(Choice
, Decls
));
10002 Add_Params_For_Variant_Components
;
10008 Next_Non_Pragma
(Variant
);
10013 end TC_Rec_Add_Process_Element
;
10015 Type_Name_Str
: String_Id
;
10016 Type_Repo_Id_Str
: String_Id
;
10019 pragma Assert
(not Is_Itype
(Typ
));
10023 Make_Function_Specification
(Loc
,
10024 Defining_Unit_Name
=> Fnam
,
10025 Parameter_Specifications
=> Empty_List
,
10026 Result_Definition
=>
10027 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
10029 Build_Name_And_Repository_Id
(Typ
,
10030 Name_Str
=> Type_Name_Str
, Repo_Id_Str
=> Type_Repo_Id_Str
);
10031 Initialize_Parameter_List
10032 (Type_Name_Str
, Type_Repo_Id_Str
, Parameters
);
10034 if Is_Derived_Type
(Typ
)
10035 and then not Is_Tagged_Type
(Typ
)
10038 Parent_Type
: Entity_Id
:= Etype
(Typ
);
10041 if Is_Itype
(Parent_Type
) then
10043 -- Skip implicit base type
10045 Parent_Type
:= Etype
(Parent_Type
);
10048 Return_Alias_TypeCode
(
10049 Build_TypeCode_Call
(Loc
, Parent_Type
, Decls
));
10052 elsif Is_Integer_Type
(Typ
)
10053 or else Is_Unsigned_Type
(Typ
)
10055 Return_Alias_TypeCode
(
10056 Build_TypeCode_Call
(Loc
,
10057 Find_Numeric_Representation
(Typ
), Decls
));
10059 elsif Is_Record_Type
(Typ
)
10060 and then not Is_Tagged_Type
(Typ
)
10062 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
10063 Return_Alias_TypeCode
(
10064 Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10067 Disc
: Entity_Id
:= Empty
;
10068 Rdef
: constant Node_Id
:=
10069 Type_Definition
(Declaration_Node
(Typ
));
10070 Dummy_Counter
: Int
:= 0;
10072 -- First all discriminants
10074 if Has_Discriminants
(Typ
) then
10075 Disc
:= First_Discriminant
(Typ
);
10077 while Present
(Disc
) loop
10078 Add_TypeCode_Parameter
(
10079 Build_TypeCode_Call
(Loc
, Etype
(Disc
), Decls
),
10081 Get_Name_String
(Chars
(Disc
));
10082 Add_String_Parameter
(
10083 String_From_Name_Buffer
,
10085 Next_Discriminant
(Disc
);
10088 -- ... then all components
10090 TC_Append_Record_Traversal
10091 (Parameters
, Component_List
(Rdef
),
10092 Empty
, Dummy_Counter
);
10093 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10097 elsif Is_Array_Type
(Typ
) then
10099 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10100 Inner_TypeCode
: Node_Id
;
10101 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10102 Indx
: Node_Id
:= First_Index
(Typ
);
10105 Inner_TypeCode
:= Build_TypeCode_Call
(Loc
,
10106 Component_Type
(Typ
),
10109 for J
in 1 .. Ndim
loop
10110 if Constrained
then
10111 Inner_TypeCode
:= Make_Constructed_TypeCode
10112 (RTE
(RE_TC_Array
), New_List
(
10113 Build_To_Any_Call
(
10114 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10115 Make_Attribute_Reference
(Loc
,
10117 New_Occurrence_Of
(Typ
, Loc
),
10120 Expressions
=> New_List
(
10121 Make_Integer_Literal
(Loc
,
10124 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10127 -- Unconstrained case: add low bound for each
10130 Add_TypeCode_Parameter
10131 (Build_TypeCode_Call
(Loc
, Etype
(Indx
), Decls
),
10133 Get_Name_String
(New_External_Name
('L', J
));
10134 Add_String_Parameter
(
10135 String_From_Name_Buffer
,
10139 Inner_TypeCode
:= Make_Constructed_TypeCode
10140 (RTE
(RE_TC_Sequence
), New_List
(
10141 Build_To_Any_Call
(
10142 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10143 Make_Integer_Literal
(Loc
, 0)),
10145 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10149 if Constrained
then
10150 Return_Alias_TypeCode
(Inner_TypeCode
);
10152 Add_TypeCode_Parameter
(Inner_TypeCode
, Parameters
);
10154 Store_String_Char
('V');
10155 Add_String_Parameter
(End_String
, Parameters
);
10156 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10161 -- Default: type is represented as an opaque sequence of bytes
10163 Return_Alias_TypeCode
10164 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10168 Make_Subprogram_Body
(Loc
,
10169 Specification
=> Spec
,
10170 Declarations
=> Decls
,
10171 Handled_Statement_Sequence
=>
10172 Make_Handled_Sequence_Of_Statements
(Loc
,
10173 Statements
=> Stms
));
10174 end Build_TypeCode_Function
;
10176 ---------------------------------
10177 -- Find_Numeric_Representation --
10178 ---------------------------------
10180 function Find_Numeric_Representation
(Typ
: Entity_Id
)
10183 FST
: constant Entity_Id
:= First_Subtype
(Typ
);
10184 P_Size
: constant Uint
:= Esize
(FST
);
10187 if Is_Unsigned_Type
(Typ
) then
10188 if P_Size
<= Standard_Short_Short_Integer_Size
then
10189 return RTE
(RE_Short_Short_Unsigned
);
10191 elsif P_Size
<= Standard_Short_Integer_Size
then
10192 return RTE
(RE_Short_Unsigned
);
10194 elsif P_Size
<= Standard_Integer_Size
then
10195 return RTE
(RE_Unsigned
);
10197 elsif P_Size
<= Standard_Long_Integer_Size
then
10198 return RTE
(RE_Long_Unsigned
);
10201 return RTE
(RE_Long_Long_Unsigned
);
10204 elsif Is_Integer_Type
(Typ
) then
10205 if P_Size
<= Standard_Short_Short_Integer_Size
then
10206 return Standard_Short_Short_Integer
;
10208 elsif P_Size
<= Standard_Short_Integer_Size
then
10209 return Standard_Short_Integer
;
10211 elsif P_Size
<= Standard_Integer_Size
then
10212 return Standard_Integer
;
10214 elsif P_Size
<= Standard_Long_Integer_Size
then
10215 return Standard_Long_Integer
;
10218 return Standard_Long_Long_Integer
;
10221 elsif Is_Floating_Point_Type
(Typ
) then
10222 if P_Size
<= Standard_Short_Float_Size
then
10223 return Standard_Short_Float
;
10225 elsif P_Size
<= Standard_Float_Size
then
10226 return Standard_Float
;
10228 elsif P_Size
<= Standard_Long_Float_Size
then
10229 return Standard_Long_Float
;
10232 return Standard_Long_Long_Float
;
10236 raise Program_Error
;
10239 -- TBD: fixed point types???
10240 -- TBverified numeric types with a biased representation???
10242 end Find_Numeric_Representation
;
10244 ---------------------------
10245 -- Append_Array_Traversal --
10246 ---------------------------
10248 procedure Append_Array_Traversal
10251 Counter
: Entity_Id
:= Empty
;
10254 Loc
: constant Source_Ptr
:= Sloc
(Subprogram
);
10255 Typ
: constant Entity_Id
:= Etype
(Arry
);
10256 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10257 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10259 Inner_Any
, Inner_Counter
: Entity_Id
;
10261 Loop_Stm
: Node_Id
;
10262 Inner_Stmts
: constant List_Id
:= New_List
;
10265 if Depth
> Ndim
then
10267 -- Processing for one element of an array
10270 Element_Expr
: constant Node_Id
:=
10271 Make_Indexed_Component
(Loc
,
10272 New_Occurrence_Of
(Arry
, Loc
),
10276 Set_Etype
(Element_Expr
, Component_Type
(Typ
));
10277 Add_Process_Element
(Stmts
,
10279 Counter
=> Counter
,
10280 Datum
=> Element_Expr
);
10286 Append_To
(Indices
,
10287 Make_Identifier
(Loc
, New_External_Name
('L', Depth
)));
10289 if Constrained
then
10291 Inner_Counter
:= Counter
;
10293 Inner_Any
:= Make_Defining_Identifier
(Loc
,
10294 New_External_Name
('A', Depth
));
10295 Set_Etype
(Inner_Any
, RTE
(RE_Any
));
10297 if Present
(Counter
) then
10298 Inner_Counter
:= Make_Defining_Identifier
(Loc
,
10299 New_External_Name
('J', Depth
));
10301 Inner_Counter
:= Empty
;
10305 Append_Array_Traversal
(Inner_Stmts
,
10307 Counter
=> Inner_Counter
,
10308 Depth
=> Depth
+ 1);
10311 Make_Implicit_Loop_Statement
(Subprogram
,
10312 Iteration_Scheme
=>
10313 Make_Iteration_Scheme
(Loc
,
10314 Loop_Parameter_Specification
=>
10315 Make_Loop_Parameter_Specification
(Loc
,
10316 Defining_Identifier
=>
10317 Make_Defining_Identifier
(Loc
,
10318 Chars
=> New_External_Name
('L', Depth
)),
10320 Discrete_Subtype_Definition
=>
10321 Make_Attribute_Reference
(Loc
,
10322 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10323 Attribute_Name
=> Name_Range
,
10325 Expressions
=> New_List
(
10326 Make_Integer_Literal
(Loc
, Depth
))))),
10327 Statements
=> Inner_Stmts
);
10329 if Constrained
then
10330 Append_To
(Stmts
, Loop_Stm
);
10335 Decls
: constant List_Id
:= New_List
;
10336 Dimen_Stmts
: constant List_Id
:= New_List
;
10337 Length_Node
: Node_Id
;
10339 Inner_Any_TypeCode
: constant Entity_Id
:=
10340 Make_Defining_Identifier
(Loc
,
10341 New_External_Name
('T', Depth
));
10343 Inner_Any_TypeCode_Expr
: Node_Id
;
10347 Inner_Any_TypeCode_Expr
:=
10348 Make_Function_Call
(Loc
,
10350 New_Occurrence_Of
(RTE
(RE_Any_Member_Type
), Loc
),
10351 Parameter_Associations
=> New_List
(
10352 New_Occurrence_Of
(Any
, Loc
),
10353 Make_Integer_Literal
(Loc
, Ndim
)));
10355 Inner_Any_TypeCode_Expr
:=
10356 Make_Function_Call
(Loc
,
10358 New_Occurrence_Of
(RTE
(RE_Content_Type
), Loc
),
10359 Parameter_Associations
=> New_List
(
10360 Make_Identifier
(Loc
,
10361 New_External_Name
('T', Depth
- 1))));
10365 Make_Object_Declaration
(Loc
,
10366 Defining_Identifier
=> Inner_Any_TypeCode
,
10367 Constant_Present
=> True,
10368 Object_Definition
=> New_Occurrence_Of
(
10369 RTE
(RE_TypeCode
), Loc
),
10370 Expression
=> Inner_Any_TypeCode_Expr
));
10372 Make_Object_Declaration
(Loc
,
10373 Defining_Identifier
=> Inner_Any
,
10374 Object_Definition
=>
10375 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
10377 Make_Function_Call
(Loc
,
10379 New_Occurrence_Of
(
10380 RTE
(RE_Create_Any
), Loc
),
10381 Parameter_Associations
=> New_List
(
10382 New_Occurrence_Of
(Inner_Any_TypeCode
, Loc
)))));
10384 if Present
(Inner_Counter
) then
10386 Make_Object_Declaration
(Loc
,
10387 Defining_Identifier
=> Inner_Counter
,
10388 Object_Definition
=>
10389 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
10391 Make_Integer_Literal
(Loc
, 0)));
10394 Length_Node
:= Make_Attribute_Reference
(Loc
,
10395 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10396 Attribute_Name
=> Name_Length
,
10398 New_List
(Make_Integer_Literal
(Loc
, Depth
)));
10399 Set_Etype
(Length_Node
, RTE
(RE_Long_Unsigned
));
10401 Add_Process_Element
(Dimen_Stmts
,
10402 Datum
=> Length_Node
,
10404 Counter
=> Inner_Counter
);
10406 -- Loop_Stm does approrpriate processing for each element
10409 Append_To
(Dimen_Stmts
, Loop_Stm
);
10411 -- Link outer and inner any
10413 Add_Process_Element
(Dimen_Stmts
,
10415 Counter
=> Counter
,
10416 Datum
=> New_Occurrence_Of
(Inner_Any
, Loc
));
10419 Make_Block_Statement
(Loc
,
10422 Handled_Statement_Sequence
=>
10423 Make_Handled_Sequence_Of_Statements
(Loc
,
10424 Statements
=> Dimen_Stmts
)));
10426 end Append_Array_Traversal
;
10428 -----------------------------------------
10429 -- Make_Stream_Procedure_Function_Name --
10430 -----------------------------------------
10432 function Make_Stream_Procedure_Function_Name
10435 Nam
: Name_Id
) return Entity_Id
10438 -- For tagged types, we use a canonical name so that it matches
10439 -- the primitive spec. For all other cases, we use a serialized
10440 -- name so that multiple generations of the same procedure do not
10443 if Is_Tagged_Type
(Typ
) then
10444 return Make_Defining_Identifier
(Loc
, Nam
);
10446 return Make_Defining_Identifier
(Loc
,
10448 New_External_Name
(Nam
, ' ', Increment_Serial_Number
));
10450 end Make_Stream_Procedure_Function_Name
;
10453 -----------------------------------
10454 -- Reserve_NamingContext_Methods --
10455 -----------------------------------
10457 procedure Reserve_NamingContext_Methods
is
10458 Str_Resolve
: constant String := "resolve";
10460 Name_Buffer
(1 .. Str_Resolve
'Length) := Str_Resolve
;
10461 Name_Len
:= Str_Resolve
'Length;
10462 Overload_Counter_Table
.Set
(Name_Find
, 1);
10463 end Reserve_NamingContext_Methods
;
10465 end PolyORB_Support
;
10467 -------------------------------
10468 -- RACW_Type_Is_Asynchronous --
10469 -------------------------------
10471 procedure RACW_Type_Is_Asynchronous
(RACW_Type
: Entity_Id
) is
10472 Asynchronous_Flag
: constant Entity_Id
:=
10473 Asynchronous_Flags_Table
.Get
(RACW_Type
);
10475 Replace
(Expression
(Parent
(Asynchronous_Flag
)),
10476 New_Occurrence_Of
(Standard_True
, Sloc
(Asynchronous_Flag
)));
10477 end RACW_Type_Is_Asynchronous
;
10479 -------------------------
10480 -- RCI_Package_Locator --
10481 -------------------------
10483 function RCI_Package_Locator
10485 Package_Spec
: Node_Id
) return Node_Id
10488 Pkg_Name
: String_Id
;
10491 Get_Library_Unit_Name_String
(Package_Spec
);
10492 Pkg_Name
:= String_From_Name_Buffer
;
10494 Make_Package_Instantiation
(Loc
,
10495 Defining_Unit_Name
=>
10496 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
10498 New_Occurrence_Of
(RTE
(RE_RCI_Locator
), Loc
),
10499 Generic_Associations
=> New_List
(
10500 Make_Generic_Association
(Loc
,
10502 Make_Identifier
(Loc
, Name_RCI_Name
),
10503 Explicit_Generic_Actual_Parameter
=>
10504 Make_String_Literal
(Loc
,
10505 Strval
=> Pkg_Name
))));
10507 RCI_Locator_Table
.Set
(Defining_Unit_Name
(Package_Spec
),
10508 Defining_Unit_Name
(Inst
));
10510 end RCI_Package_Locator
;
10512 -----------------------------------------------
10513 -- Remote_Types_Tagged_Full_View_Encountered --
10514 -----------------------------------------------
10516 procedure Remote_Types_Tagged_Full_View_Encountered
10517 (Full_View
: Entity_Id
)
10519 Stub_Elements
: constant Stub_Structure
:=
10520 Stubs_Table
.Get
(Full_View
);
10522 if Stub_Elements
/= Empty_Stub_Structure
then
10523 Add_RACW_Primitive_Declarations_And_Bodies
10525 Stub_Elements
.RPC_Receiver_Decl
,
10526 List_Containing
(Declaration_Node
(Full_View
)));
10528 end Remote_Types_Tagged_Full_View_Encountered
;
10530 -------------------
10531 -- Scope_Of_Spec --
10532 -------------------
10534 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
is
10535 Unit_Name
: Node_Id
:= Defining_Unit_Name
(Spec
);
10538 while Nkind
(Unit_Name
) /= N_Defining_Identifier
loop
10539 Unit_Name
:= Defining_Identifier
(Unit_Name
);
10545 ----------------------
10546 -- Set_Renaming_TSS --
10547 ----------------------
10549 procedure Set_Renaming_TSS
10552 TSS_Nam
: TSS_Name_Type
)
10554 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
10555 Spec
: constant Node_Id
:= Parent
(Nam
);
10557 TSS_Node
: constant Node_Id
:=
10558 Make_Subprogram_Renaming_Declaration
(Loc
,
10560 Copy_Specification
(Loc
,
10562 New_Name
=> Make_TSS_Name
(Typ
, TSS_Nam
)),
10563 Name
=> New_Occurrence_Of
(Nam
, Loc
));
10565 Snam
: constant Entity_Id
:=
10566 Defining_Unit_Name
(Specification
(TSS_Node
));
10569 if Nkind
(Spec
) = N_Function_Specification
then
10570 Set_Ekind
(Snam
, E_Function
);
10571 Set_Etype
(Snam
, Entity
(Result_Definition
(Spec
)));
10573 Set_Ekind
(Snam
, E_Procedure
);
10574 Set_Etype
(Snam
, Standard_Void_Type
);
10577 Set_TSS
(Typ
, Snam
);
10578 end Set_Renaming_TSS
;
10580 ----------------------------------------------
10581 -- Specific_Add_Obj_RPC_Receiver_Completion --
10582 ----------------------------------------------
10584 procedure Specific_Add_Obj_RPC_Receiver_Completion
10587 RPC_Receiver
: Entity_Id
;
10588 Stub_Elements
: Stub_Structure
) is
10590 case Get_PCS_Name
is
10591 when Name_PolyORB_DSA
=>
10592 PolyORB_Support
.Add_Obj_RPC_Receiver_Completion
(Loc
,
10593 Decls
, RPC_Receiver
, Stub_Elements
);
10595 GARLIC_Support
.Add_Obj_RPC_Receiver_Completion
(Loc
,
10596 Decls
, RPC_Receiver
, Stub_Elements
);
10598 end Specific_Add_Obj_RPC_Receiver_Completion
;
10600 --------------------------------
10601 -- Specific_Add_RACW_Features --
10602 --------------------------------
10604 procedure Specific_Add_RACW_Features
10605 (RACW_Type
: Entity_Id
;
10607 Stub_Type
: Entity_Id
;
10608 Stub_Type_Access
: Entity_Id
;
10609 RPC_Receiver_Decl
: Node_Id
;
10610 Declarations
: List_Id
) is
10612 case Get_PCS_Name
is
10613 when Name_PolyORB_DSA
=>
10614 PolyORB_Support
.Add_RACW_Features
(
10623 GARLIC_Support
.Add_RACW_Features
(
10630 end Specific_Add_RACW_Features
;
10632 --------------------------------
10633 -- Specific_Add_RAST_Features --
10634 --------------------------------
10636 procedure Specific_Add_RAST_Features
10637 (Vis_Decl
: Node_Id
;
10638 RAS_Type
: Entity_Id
) is
10640 case Get_PCS_Name
is
10641 when Name_PolyORB_DSA
=>
10642 PolyORB_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
10644 GARLIC_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
10646 end Specific_Add_RAST_Features
;
10648 --------------------------------------------------
10649 -- Specific_Add_Receiving_Stubs_To_Declarations --
10650 --------------------------------------------------
10652 procedure Specific_Add_Receiving_Stubs_To_Declarations
10653 (Pkg_Spec
: Node_Id
;
10657 case Get_PCS_Name
is
10658 when Name_PolyORB_DSA
=>
10659 PolyORB_Support
.Add_Receiving_Stubs_To_Declarations
(
10662 GARLIC_Support
.Add_Receiving_Stubs_To_Declarations
(
10665 end Specific_Add_Receiving_Stubs_To_Declarations
;
10667 ------------------------------------------
10668 -- Specific_Build_General_Calling_Stubs --
10669 ------------------------------------------
10671 procedure Specific_Build_General_Calling_Stubs
10673 Statements
: List_Id
;
10674 Target
: RPC_Target
;
10675 Subprogram_Id
: Node_Id
;
10676 Asynchronous
: Node_Id
:= Empty
;
10677 Is_Known_Asynchronous
: Boolean := False;
10678 Is_Known_Non_Asynchronous
: Boolean := False;
10679 Is_Function
: Boolean;
10681 Stub_Type
: Entity_Id
:= Empty
;
10682 RACW_Type
: Entity_Id
:= Empty
;
10686 case Get_PCS_Name
is
10687 when Name_PolyORB_DSA
=>
10688 PolyORB_Support
.Build_General_Calling_Stubs
(
10694 Is_Known_Asynchronous
,
10695 Is_Known_Non_Asynchronous
,
10702 GARLIC_Support
.Build_General_Calling_Stubs
(
10706 Target
.RPC_Receiver
,
10709 Is_Known_Asynchronous
,
10710 Is_Known_Non_Asynchronous
,
10717 end Specific_Build_General_Calling_Stubs
;
10719 --------------------------------------
10720 -- Specific_Build_RPC_Receiver_Body --
10721 --------------------------------------
10723 procedure Specific_Build_RPC_Receiver_Body
10724 (RPC_Receiver
: Entity_Id
;
10725 Request
: out Entity_Id
;
10726 Subp_Id
: out Entity_Id
;
10727 Subp_Index
: out Entity_Id
;
10728 Stmts
: out List_Id
;
10729 Decl
: out Node_Id
)
10732 case Get_PCS_Name
is
10733 when Name_PolyORB_DSA
=>
10734 PolyORB_Support
.Build_RPC_Receiver_Body
10742 GARLIC_Support
.Build_RPC_Receiver_Body
10750 end Specific_Build_RPC_Receiver_Body
;
10752 --------------------------------
10753 -- Specific_Build_Stub_Target --
10754 --------------------------------
10756 function Specific_Build_Stub_Target
10759 RCI_Locator
: Entity_Id
;
10760 Controlling_Parameter
: Entity_Id
) return RPC_Target
is
10762 case Get_PCS_Name
is
10763 when Name_PolyORB_DSA
=>
10764 return PolyORB_Support
.Build_Stub_Target
(Loc
,
10765 Decls
, RCI_Locator
, Controlling_Parameter
);
10767 return GARLIC_Support
.Build_Stub_Target
(Loc
,
10768 Decls
, RCI_Locator
, Controlling_Parameter
);
10770 end Specific_Build_Stub_Target
;
10772 ------------------------------
10773 -- Specific_Build_Stub_Type --
10774 ------------------------------
10776 procedure Specific_Build_Stub_Type
10777 (RACW_Type
: Entity_Id
;
10778 Stub_Type
: Entity_Id
;
10779 Stub_Type_Decl
: out Node_Id
;
10780 RPC_Receiver_Decl
: out Node_Id
)
10783 case Get_PCS_Name
is
10784 when Name_PolyORB_DSA
=>
10785 PolyORB_Support
.Build_Stub_Type
(
10786 RACW_Type
, Stub_Type
,
10787 Stub_Type_Decl
, RPC_Receiver_Decl
);
10789 GARLIC_Support
.Build_Stub_Type
(
10790 RACW_Type
, Stub_Type
,
10791 Stub_Type_Decl
, RPC_Receiver_Decl
);
10793 end Specific_Build_Stub_Type
;
10795 function Specific_Build_Subprogram_Receiving_Stubs
10796 (Vis_Decl
: Node_Id
;
10797 Asynchronous
: Boolean;
10798 Dynamically_Asynchronous
: Boolean := False;
10799 Stub_Type
: Entity_Id
:= Empty
;
10800 RACW_Type
: Entity_Id
:= Empty
;
10801 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
is
10803 case Get_PCS_Name
is
10804 when Name_PolyORB_DSA
=>
10805 return PolyORB_Support
.Build_Subprogram_Receiving_Stubs
(
10808 Dynamically_Asynchronous
,
10813 return GARLIC_Support
.Build_Subprogram_Receiving_Stubs
(
10816 Dynamically_Asynchronous
,
10821 end Specific_Build_Subprogram_Receiving_Stubs
;
10823 --------------------------
10824 -- Underlying_RACW_Type --
10825 --------------------------
10827 function Underlying_RACW_Type
(RAS_Typ
: Entity_Id
) return Entity_Id
is
10828 Record_Type
: Entity_Id
;
10831 if Ekind
(RAS_Typ
) = E_Record_Type
then
10832 Record_Type
:= RAS_Typ
;
10834 pragma Assert
(Present
(Equivalent_Type
(RAS_Typ
)));
10835 Record_Type
:= Equivalent_Type
(RAS_Typ
);
10839 Etype
(Subtype_Indication
(
10840 Component_Definition
(
10841 First
(Component_Items
(Component_List
(
10842 Type_Definition
(Declaration_Node
(Record_Type
))))))));
10843 end Underlying_RACW_Type
;