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
;
274 Stub_Type
: Entity_Id
) return Boolean;
275 -- Return True if the current parameter is a controlling formal argument
276 -- of type Stub_Type or access to Stub_Type.
278 procedure Declare_Create_NVList
283 -- Append the declaration of NVList to Decls, and its
284 -- initialization to Stmts.
286 function Add_Parameter_To_NVList
289 Parameter
: Entity_Id
;
290 Constrained
: Boolean;
291 RACW_Ctrl
: Boolean := False;
292 Any
: Entity_Id
) return Node_Id
;
293 -- Return a call to Add_Item to add the Any corresponding
294 -- to the designated formal Parameter (with the indicated
295 -- Constrained status) to NVList. RACW_Ctrl must be set to
296 -- True for controlling formals of distributed object primitive
299 type Stub_Structure
is record
300 Stub_Type
: Entity_Id
;
301 Stub_Type_Access
: Entity_Id
;
302 RPC_Receiver_Decl
: Node_Id
;
303 RACW_Type
: Entity_Id
;
305 -- This structure is necessary because of the two phases analysis of
306 -- a RACW declaration occurring in the same Remote_Types package as the
307 -- designated type. RACW_Type is any of the RACW types pointing on this
308 -- designated type, it is used here to save an anonymous type creation
309 -- for each primitive operation.
311 -- For a RACW that implements a RAS, no object RPC receiver is generated.
312 -- Instead, RPC_Receiver_Decl is the declaration after which the
313 -- RPC receiver would have been inserted.
315 Empty_Stub_Structure
: constant Stub_Structure
:=
316 (Empty
, Empty
, Empty
, Empty
);
318 package Stubs_Table
is
319 new Simple_HTable
(Header_Num
=> Hash_Index
,
320 Element
=> Stub_Structure
,
321 No_Element
=> Empty_Stub_Structure
,
325 -- Mapping between a RACW designated type and its stub type
327 package Asynchronous_Flags_Table
is
328 new Simple_HTable
(Header_Num
=> Hash_Index
,
329 Element
=> Entity_Id
,
334 -- Mapping between a RACW type and a constant having the value True
335 -- if the RACW is asynchronous and False otherwise.
337 package RCI_Locator_Table
is
338 new Simple_HTable
(Header_Num
=> Hash_Index
,
339 Element
=> Entity_Id
,
344 -- Mapping between a RCI package on which All_Calls_Remote applies and
345 -- the generic instantiation of RCI_Locator for this package.
347 package RCI_Calling_Stubs_Table
is
348 new Simple_HTable
(Header_Num
=> Hash_Index
,
349 Element
=> Entity_Id
,
354 -- Mapping between a RCI subprogram and the corresponding calling stubs
356 procedure Add_Stub_Type
357 (Designated_Type
: Entity_Id
;
358 RACW_Type
: Entity_Id
;
360 Stub_Type
: out Entity_Id
;
361 Stub_Type_Access
: out Entity_Id
;
362 RPC_Receiver_Decl
: out Node_Id
;
363 Existing
: out Boolean);
364 -- Add the declaration of the stub type, the access to stub type and the
365 -- object RPC receiver at the end of Decls. If these already exist,
366 -- then nothing is added in the tree but the right values are returned
367 -- anyhow and Existing is set to True.
369 procedure Add_RACW_Asynchronous_Flag
370 (Declarations
: List_Id
;
371 RACW_Type
: Entity_Id
);
372 -- Declare a boolean constant associated with RACW_Type whose value
373 -- indicates at run time whether a pragma Asynchronous applies to it.
375 procedure Assign_Subprogram_Identifier
379 -- Determine the distribution subprogram identifier to
380 -- be used for remote subprogram Def, return it in Id and
381 -- store it in a hash table for later retrieval by
382 -- Get_Subprogram_Id. Spn is the subprogram number.
384 function RCI_Package_Locator
386 Package_Spec
: Node_Id
) return Node_Id
;
387 -- Instantiate the generic package RCI_Locator in order to locate the
388 -- RCI package whose spec is given as argument.
390 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
;
391 -- Surround a node N by a tag check, as in:
395 -- when E : Ada.Tags.Tag_Error =>
396 -- Raise_Exception (Program_Error'Identity,
397 -- Exception_Message (E));
400 function Input_With_Tag_Check
402 Var_Type
: Entity_Id
;
403 Stream
: Node_Id
) return Node_Id
;
404 -- Return a function with the following form:
405 -- function R return Var_Type is
407 -- return Var_Type'Input (S);
409 -- when E : Ada.Tags.Tag_Error =>
410 -- Raise_Exception (Program_Error'Identity,
411 -- Exception_Message (E));
414 --------------------------------------------
415 -- Hooks for PCS-specific code generation --
416 --------------------------------------------
418 -- Part of the code generation circuitry for distribution needs to be
419 -- tailored for each implementation of the PCS. For each routine that
420 -- needs to be specialized, a Specific_<routine> wrapper is created,
421 -- which calls the corresponding <routine> in package
422 -- <pcs_implementation>_Support.
424 procedure Specific_Add_RACW_Features
425 (RACW_Type
: Entity_Id
;
427 Stub_Type
: Entity_Id
;
428 Stub_Type_Access
: Entity_Id
;
429 RPC_Receiver_Decl
: Node_Id
;
430 Declarations
: List_Id
);
431 -- Add declaration for TSSs for a given RACW type. The declarations are
432 -- added just after the declaration of the RACW type itself, while the
433 -- bodies are inserted at the end of Decls. Runtime-specific ancillary
434 -- subprogram for Add_RACW_Features.
436 procedure Specific_Add_RAST_Features
438 RAS_Type
: Entity_Id
);
439 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
440 -- subprogram for Add_RAST_Features.
442 -- An RPC_Target record is used during construction of calling stubs
443 -- to pass PCS-specific tree fragments corresponding to the information
444 -- necessary to locate the target of a remote subprogram call.
446 type RPC_Target
(PCS_Kind
: PCS_Names
) is record
448 when Name_PolyORB_DSA
=>
450 -- An expression whose value is a PolyORB reference to the target
453 Partition
: Entity_Id
;
454 -- A variable containing the Partition_ID of the target parition
456 RPC_Receiver
: Node_Id
;
457 -- An expression whose value is the address of the target RPC
462 procedure Specific_Build_General_Calling_Stubs
464 Statements
: List_Id
;
466 Subprogram_Id
: Node_Id
;
467 Asynchronous
: Node_Id
:= Empty
;
468 Is_Known_Asynchronous
: Boolean := False;
469 Is_Known_Non_Asynchronous
: Boolean := False;
470 Is_Function
: Boolean;
472 Stub_Type
: Entity_Id
:= Empty
;
473 RACW_Type
: Entity_Id
:= Empty
;
475 -- Build calling stubs for general purpose. The parameters are:
476 -- Decls : a place to put declarations
477 -- Statements : a place to put statements
478 -- Target : PCS-specific target information (see details
479 -- in RPC_Target declaration).
480 -- Subprogram_Id : a node containing the subprogram ID
481 -- Asynchronous : True if an APC must be made instead of an RPC.
482 -- The value needs not be supplied if one of the
483 -- Is_Known_... is True.
484 -- Is_Known_Async... : True if we know that this is asynchronous
485 -- Is_Known_Non_A... : True if we know that this is not asynchronous
486 -- Spec : a node with a Parameter_Specifications and
487 -- a Result_Definition if applicable
488 -- Stub_Type : in case of RACW stubs, parameters of type access
489 -- to Stub_Type will be marshalled using the
490 -- address of the object (the addr field) rather
491 -- than using the 'Write on the stub itself
492 -- Nod : used to provide sloc for generated code
494 function Specific_Build_Stub_Target
497 RCI_Locator
: Entity_Id
;
498 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
499 -- Build call target information nodes for use within calling stubs. In the
500 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
501 -- for an RACW, Controlling_Parameter is the entity for the controlling
502 -- formal parameter used to determine the location of the target of the
503 -- call. Decls provides a location where variable declarations can be
504 -- appended to construct the necessary values.
506 procedure Specific_Build_Stub_Type
507 (RACW_Type
: Entity_Id
;
508 Stub_Type
: Entity_Id
;
509 Stub_Type_Decl
: out Node_Id
;
510 RPC_Receiver_Decl
: out Node_Id
);
511 -- Build a type declaration for the stub type associated with an RACW
512 -- type, and the necessary RPC receiver, if applicable. PCS-specific
513 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
514 -- is generated, then RPC_Receiver_Decl is set to Empty.
516 procedure Specific_Build_RPC_Receiver_Body
517 (RPC_Receiver
: Entity_Id
;
518 Request
: out Entity_Id
;
519 Subp_Id
: out Entity_Id
;
520 Subp_Index
: out Entity_Id
;
523 -- Make a subprogram body for an RPC receiver, with the given
524 -- defining unit name. On return:
525 -- - Subp_Id is the subprogram identifier from the PCS.
526 -- - Subp_Index is the index in the list of subprograms
527 -- used for dispatching (a variable of type Subprogram_Id).
528 -- - Stmts is the place where the request dispatching
529 -- statements can occur,
530 -- - Decl is the subprogram body declaration.
532 function Specific_Build_Subprogram_Receiving_Stubs
534 Asynchronous
: Boolean;
535 Dynamically_Asynchronous
: Boolean := False;
536 Stub_Type
: Entity_Id
:= Empty
;
537 RACW_Type
: Entity_Id
:= Empty
;
538 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
539 -- Build the receiving stub for a given subprogram. The subprogram
540 -- declaration is also built by this procedure, and the value returned
541 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
542 -- found in the specification, then its address is read from the stream
543 -- instead of the object itself and converted into an access to
544 -- class-wide type before doing the real call using any of the RACW type
545 -- pointing on the designated type.
547 procedure Specific_Add_Obj_RPC_Receiver_Completion
550 RPC_Receiver
: Entity_Id
;
551 Stub_Elements
: Stub_Structure
);
552 -- Add the necessary code to Decls after the completion of generation
553 -- of the RACW RPC receiver described by Stub_Elements.
555 procedure Specific_Add_Receiving_Stubs_To_Declarations
558 -- Add receiving stubs to the declarative part of an RCI unit
560 package GARLIC_Support
is
562 -- Support for generating DSA code that uses the GARLIC PCS
564 -- The subprograms below provide the GARLIC versions of
565 -- the corresponding Specific_<subprogram> routine declared
568 procedure Add_RACW_Features
569 (RACW_Type
: Entity_Id
;
570 Stub_Type
: Entity_Id
;
571 Stub_Type_Access
: Entity_Id
;
572 RPC_Receiver_Decl
: Node_Id
;
573 Declarations
: List_Id
);
575 procedure Add_RAST_Features
577 RAS_Type
: Entity_Id
);
579 procedure Build_General_Calling_Stubs
581 Statements
: List_Id
;
582 Target_Partition
: Entity_Id
; -- From RPC_Target
583 Target_RPC_Receiver
: Node_Id
; -- From RPC_Target
584 Subprogram_Id
: Node_Id
;
585 Asynchronous
: Node_Id
:= Empty
;
586 Is_Known_Asynchronous
: Boolean := False;
587 Is_Known_Non_Asynchronous
: Boolean := False;
588 Is_Function
: Boolean;
590 Stub_Type
: Entity_Id
:= Empty
;
591 RACW_Type
: Entity_Id
:= Empty
;
594 function Build_Stub_Target
597 RCI_Locator
: Entity_Id
;
598 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
600 procedure Build_Stub_Type
601 (RACW_Type
: Entity_Id
;
602 Stub_Type
: Entity_Id
;
603 Stub_Type_Decl
: out Node_Id
;
604 RPC_Receiver_Decl
: out Node_Id
);
606 function Build_Subprogram_Receiving_Stubs
608 Asynchronous
: Boolean;
609 Dynamically_Asynchronous
: Boolean := False;
610 Stub_Type
: Entity_Id
:= Empty
;
611 RACW_Type
: Entity_Id
:= Empty
;
612 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
614 procedure Add_Obj_RPC_Receiver_Completion
617 RPC_Receiver
: Entity_Id
;
618 Stub_Elements
: Stub_Structure
);
620 procedure Add_Receiving_Stubs_To_Declarations
624 procedure Build_RPC_Receiver_Body
625 (RPC_Receiver
: Entity_Id
;
626 Request
: out Entity_Id
;
627 Subp_Id
: out Entity_Id
;
628 Subp_Index
: out Entity_Id
;
634 package PolyORB_Support
is
636 -- Support for generating DSA code that uses the PolyORB PCS
638 -- The subprograms below provide the PolyORB versions of
639 -- the corresponding Specific_<subprogram> routine declared
642 procedure Add_RACW_Features
643 (RACW_Type
: Entity_Id
;
645 Stub_Type
: Entity_Id
;
646 Stub_Type_Access
: Entity_Id
;
647 RPC_Receiver_Decl
: Node_Id
;
648 Declarations
: List_Id
);
650 procedure Add_RAST_Features
652 RAS_Type
: Entity_Id
);
654 procedure Build_General_Calling_Stubs
656 Statements
: List_Id
;
657 Target_Object
: Node_Id
; -- From RPC_Target
658 Subprogram_Id
: Node_Id
;
659 Asynchronous
: Node_Id
:= Empty
;
660 Is_Known_Asynchronous
: Boolean := False;
661 Is_Known_Non_Asynchronous
: Boolean := False;
662 Is_Function
: Boolean;
664 Stub_Type
: Entity_Id
:= Empty
;
665 RACW_Type
: Entity_Id
:= Empty
;
668 function Build_Stub_Target
671 RCI_Locator
: Entity_Id
;
672 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
674 procedure Build_Stub_Type
675 (RACW_Type
: Entity_Id
;
676 Stub_Type
: Entity_Id
;
677 Stub_Type_Decl
: out Node_Id
;
678 RPC_Receiver_Decl
: out Node_Id
);
680 function Build_Subprogram_Receiving_Stubs
682 Asynchronous
: Boolean;
683 Dynamically_Asynchronous
: Boolean := False;
684 Stub_Type
: Entity_Id
:= Empty
;
685 RACW_Type
: Entity_Id
:= Empty
;
686 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
688 procedure Add_Obj_RPC_Receiver_Completion
691 RPC_Receiver
: Entity_Id
;
692 Stub_Elements
: Stub_Structure
);
694 procedure Add_Receiving_Stubs_To_Declarations
698 procedure Build_RPC_Receiver_Body
699 (RPC_Receiver
: Entity_Id
;
700 Request
: out Entity_Id
;
701 Subp_Id
: out Entity_Id
;
702 Subp_Index
: out Entity_Id
;
706 procedure Reserve_NamingContext_Methods
;
707 -- Mark the method names for interface NamingContext as already used in
708 -- the overload table, so no clashes occur with user code (with the
709 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
710 -- their methods to be accessed as objects, for the implementation of
711 -- remote access-to-subprogram types).
715 -- Routines to build distribtion helper subprograms for user-defined
716 -- types. For implementation of the Distributed systems annex (DSA)
717 -- over the PolyORB generic middleware components, it is necessary to
718 -- generate several supporting subprograms for each application data
719 -- type used in inter-partition communication. These subprograms are:
720 -- * a Typecode function returning a high-level description of the
722 -- * two conversion functions allowing conversion of values of the
723 -- type from and to the generic data containers used by PolyORB.
724 -- These generic containers are called 'Any' type values after
725 -- the CORBA terminology, and hence the conversion subprograms
726 -- are named To_Any and From_Any.
728 function Build_From_Any_Call
731 Decls
: List_Id
) return Node_Id
;
732 -- Build call to From_Any attribute function of type Typ with
733 -- expression N as actual parameter. Decls is the declarations list
734 -- for an appropriate enclosing scope of the point where the call
735 -- will be inserted; if the From_Any attribute for Typ needs to be
736 -- generated at this point, its declaration is appended to Decls.
738 procedure Build_From_Any_Function
742 Fnam
: out Entity_Id
);
743 -- Build From_Any attribute function for Typ. Loc is the reference
744 -- location for generated nodes, Typ is the type for which the
745 -- conversion function is generated. On return, Decl and Fnam contain
746 -- the declaration and entity for the newly-created function.
748 function Build_To_Any_Call
750 Decls
: List_Id
) return Node_Id
;
751 -- Build call to To_Any attribute function with expression as actual
752 -- parameter. Decls is the declarations list for an appropriate
753 -- enclosing scope of the point where the call will be inserted; if
754 -- the To_Any attribute for Typ needs to be generated at this point,
755 -- its declaration is appended to Decls.
757 procedure Build_To_Any_Function
761 Fnam
: out Entity_Id
);
762 -- Build To_Any attribute function for Typ. Loc is the reference
763 -- location for generated nodes, Typ is the type for which the
764 -- conversion function is generated. On return, Decl and Fnam contain
765 -- the declaration and entity for the newly-created function.
767 function Build_TypeCode_Call
770 Decls
: List_Id
) return Node_Id
;
771 -- Build call to TypeCode attribute function for Typ. Decls is the
772 -- declarations list for an appropriate enclosing scope of the point
773 -- where the call will be inserted; if the To_Any attribute for Typ
774 -- needs to be generated at this point, its declaration is appended
777 procedure Build_TypeCode_Function
781 Fnam
: out Entity_Id
);
782 -- Build TypeCode attribute function for Typ. Loc is the reference
783 -- location for generated nodes, Typ is the type for which the
784 -- conversion function is generated. On return, Decl and Fnam contain
785 -- the declaration and entity for the newly-created function.
787 procedure Build_Name_And_Repository_Id
789 Name_Str
: out String_Id
;
790 Repo_Id_Str
: out String_Id
);
791 -- In the PolyORB distribution model, each distributed object type
792 -- and each distributed operation has a globally unique identifier,
793 -- its Repository Id. This subprogram builds and returns two strings
794 -- for entity E (a distributed object type or operation): one
795 -- containing the name of E, the second containing its repository id.
801 ------------------------------------
802 -- Local variables and structures --
803 ------------------------------------
806 -- Needs comments ???
808 Output_From_Constrained
: constant array (Boolean) of Name_Id
:=
809 (False => Name_Output
,
811 -- The attribute to choose depending on the fact that the parameter
812 -- is constrained or not. There is no such thing as Input_From_Constrained
813 -- since this require separate mechanisms ('Input is a function while
814 -- 'Read is a procedure).
816 ---------------------------------------
817 -- Add_Calling_Stubs_To_Declarations --
818 ---------------------------------------
820 procedure Add_Calling_Stubs_To_Declarations
824 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
825 -- Subprogram id 0 is reserved for calls received from
826 -- remote access-to-subprogram dereferences.
828 Current_Declaration
: Node_Id
;
829 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
830 RCI_Instantiation
: Node_Id
;
831 Subp_Stubs
: Node_Id
;
832 Subp_Str
: String_Id
;
835 -- The first thing added is an instantiation of the generic package
836 -- System.Partition_Interface.RCI_Locator with the name of this
837 -- remote package. This will act as an interface with the name server
838 -- to determine the Partition_ID and the RPC_Receiver for the
839 -- receiver of this package.
841 RCI_Instantiation
:= RCI_Package_Locator
(Loc
, Pkg_Spec
);
842 RCI_Cache
:= Defining_Unit_Name
(RCI_Instantiation
);
844 Append_To
(Decls
, RCI_Instantiation
);
845 Analyze
(RCI_Instantiation
);
847 -- For each subprogram declaration visible in the spec, we do
848 -- build a body. We also increment a counter to assign a different
849 -- Subprogram_Id to each subprograms. The receiving stubs processing
850 -- do use the same mechanism and will thus assign the same Id and
851 -- do the correct dispatching.
853 Overload_Counter_Table
.Reset
;
854 PolyORB_Support
.Reserve_NamingContext_Methods
;
856 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
858 while Present
(Current_Declaration
) loop
859 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
860 and then Comes_From_Source
(Current_Declaration
)
862 Assign_Subprogram_Identifier
(
863 Defining_Unit_Name
(Specification
(Current_Declaration
)),
864 Current_Subprogram_Number
,
868 Build_Subprogram_Calling_Stubs
(
869 Vis_Decl
=> Current_Declaration
,
871 Build_Subprogram_Id
(Loc
,
872 Defining_Unit_Name
(Specification
(Current_Declaration
))),
874 Nkind
(Specification
(Current_Declaration
)) =
875 N_Procedure_Specification
877 Is_Asynchronous
(Defining_Unit_Name
(Specification
878 (Current_Declaration
))));
880 Append_To
(Decls
, Subp_Stubs
);
881 Analyze
(Subp_Stubs
);
883 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
886 Next
(Current_Declaration
);
888 end Add_Calling_Stubs_To_Declarations
;
890 -----------------------------
891 -- Add_Parameter_To_NVList --
892 -----------------------------
894 function Add_Parameter_To_NVList
897 Parameter
: Entity_Id
;
898 Constrained
: Boolean;
899 RACW_Ctrl
: Boolean := False;
900 Any
: Entity_Id
) return Node_Id
902 Parameter_Name_String
: String_Id
;
903 Parameter_Mode
: Node_Id
;
905 function Parameter_Passing_Mode
907 Parameter
: Entity_Id
;
908 Constrained
: Boolean) return Node_Id
;
909 -- Return an expression that denotes the parameter passing
910 -- mode to be used for Parameter in distribution stubs,
911 -- where Constrained is Parameter's constrained status.
913 ----------------------------
914 -- Parameter_Passing_Mode --
915 ----------------------------
917 function Parameter_Passing_Mode
919 Parameter
: Entity_Id
;
920 Constrained
: Boolean) return Node_Id
925 if Out_Present
(Parameter
) then
926 if In_Present
(Parameter
)
927 or else not Constrained
929 -- Unconstrained formals must be translated
930 -- to 'in' or 'inout', not 'out', because
931 -- they need to be constrained by the actual.
933 Lib_RE
:= RE_Mode_Inout
;
935 Lib_RE
:= RE_Mode_Out
;
939 Lib_RE
:= RE_Mode_In
;
942 return New_Occurrence_Of
(RTE
(Lib_RE
), Loc
);
943 end Parameter_Passing_Mode
;
945 -- Start of processing for Add_Parameter_To_NVList
948 if Nkind
(Parameter
) = N_Defining_Identifier
then
949 Get_Name_String
(Chars
(Parameter
));
951 Get_Name_String
(Chars
(Defining_Identifier
955 Parameter_Name_String
:= String_From_Name_Buffer
;
958 Parameter_Mode
:= New_Occurrence_Of
959 (RTE
(RE_Mode_In
), Loc
);
961 Parameter_Mode
:= Parameter_Passing_Mode
(Loc
,
962 Parameter
, Constrained
);
966 Make_Procedure_Call_Statement
(Loc
,
969 (RTE
(RE_NVList_Add_Item
), Loc
),
970 Parameter_Associations
=> New_List
(
971 New_Occurrence_Of
(NVList
, Loc
),
972 Make_Function_Call
(Loc
,
975 (RTE
(RE_To_PolyORB_String
), Loc
),
976 Parameter_Associations
=> New_List
(
977 Make_String_Literal
(Loc
,
978 Strval
=> Parameter_Name_String
))),
979 New_Occurrence_Of
(Any
, Loc
),
981 end Add_Parameter_To_NVList
;
983 --------------------------------
984 -- Add_RACW_Asynchronous_Flag --
985 --------------------------------
987 procedure Add_RACW_Asynchronous_Flag
988 (Declarations
: List_Id
;
989 RACW_Type
: Entity_Id
)
991 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
993 Asynchronous_Flag
: constant Entity_Id
:=
994 Make_Defining_Identifier
(Loc
,
995 New_External_Name
(Chars
(RACW_Type
), 'A'));
998 -- Declare the asynchronous flag. This flag will be changed to True
999 -- whenever it is known that the RACW type is asynchronous.
1001 Append_To
(Declarations
,
1002 Make_Object_Declaration
(Loc
,
1003 Defining_Identifier
=> Asynchronous_Flag
,
1004 Constant_Present
=> True,
1005 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
1006 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
1008 Asynchronous_Flags_Table
.Set
(RACW_Type
, Asynchronous_Flag
);
1009 end Add_RACW_Asynchronous_Flag
;
1011 -----------------------
1012 -- Add_RACW_Features --
1013 -----------------------
1015 procedure Add_RACW_Features
(RACW_Type
: Entity_Id
)
1017 Desig
: constant Entity_Id
:=
1018 Etype
(Designated_Type
(RACW_Type
));
1020 List_Containing
(Declaration_Node
(RACW_Type
));
1022 Same_Scope
: constant Boolean :=
1023 Scope
(Desig
) = Scope
(RACW_Type
);
1025 Stub_Type
: Entity_Id
;
1026 Stub_Type_Access
: Entity_Id
;
1027 RPC_Receiver_Decl
: Node_Id
;
1031 if not Expander_Active
then
1037 -- We are declaring a RACW in the same package than its designated
1038 -- type, so the list to use for late declarations must be the
1039 -- private part of the package. We do know that this private part
1040 -- exists since the designated type has to be a private one.
1042 Decls
:= Private_Declarations
1043 (Package_Specification_Of_Scope
(Current_Scope
));
1045 elsif Nkind
(Parent
(Decls
)) = N_Package_Specification
1046 and then Present
(Private_Declarations
(Parent
(Decls
)))
1048 Decls
:= Private_Declarations
(Parent
(Decls
));
1051 -- If we were unable to find the declarations, that means that the
1052 -- completion of the type was missing. We can safely return and let
1053 -- the error be caught by the semantic analysis.
1060 (Designated_Type
=> Desig
,
1061 RACW_Type
=> RACW_Type
,
1063 Stub_Type
=> Stub_Type
,
1064 Stub_Type_Access
=> Stub_Type_Access
,
1065 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1066 Existing
=> Existing
);
1068 Add_RACW_Asynchronous_Flag
1069 (Declarations
=> Decls
,
1070 RACW_Type
=> RACW_Type
);
1072 Specific_Add_RACW_Features
1073 (RACW_Type
=> RACW_Type
,
1075 Stub_Type
=> Stub_Type
,
1076 Stub_Type_Access
=> Stub_Type_Access
,
1077 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1078 Declarations
=> Decls
);
1080 if not Same_Scope
and then not Existing
then
1082 -- The RACW has been declared in another scope than the designated
1083 -- type and has not been handled by another RACW in the same package
1084 -- as the first one, so add primitive for the stub type here.
1086 Add_RACW_Primitive_Declarations_And_Bodies
1087 (Designated_Type
=> Desig
,
1088 Insertion_Node
=> RPC_Receiver_Decl
,
1092 Add_Access_Type_To_Process
(E
=> Desig
, A
=> RACW_Type
);
1094 end Add_RACW_Features
;
1096 ------------------------------------------------
1097 -- Add_RACW_Primitive_Declarations_And_Bodies --
1098 ------------------------------------------------
1100 procedure Add_RACW_Primitive_Declarations_And_Bodies
1101 (Designated_Type
: Entity_Id
;
1102 Insertion_Node
: Node_Id
;
1105 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1106 -- the declarations are recognized as belonging to the current package.
1108 Loc
: constant Source_Ptr
:= Sloc
(Insertion_Node
);
1110 Stub_Elements
: constant Stub_Structure
:=
1111 Stubs_Table
.Get
(Designated_Type
);
1113 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
1114 Is_RAS
: constant Boolean :=
1115 not Comes_From_Source
(Stub_Elements
.RACW_Type
);
1117 Current_Insertion_Node
: Node_Id
:= Insertion_Node
;
1119 RPC_Receiver
: Entity_Id
;
1120 RPC_Receiver_Statements
: List_Id
;
1121 RPC_Receiver_Case_Alternatives
: constant List_Id
:= New_List
;
1122 RPC_Receiver_Elsif_Parts
: List_Id
;
1123 RPC_Receiver_Request
: Entity_Id
;
1124 RPC_Receiver_Subp_Id
: Entity_Id
;
1125 RPC_Receiver_Subp_Index
: Entity_Id
;
1127 Subp_Str
: String_Id
;
1129 Current_Primitive_Elmt
: Elmt_Id
;
1130 Current_Primitive
: Entity_Id
;
1131 Current_Primitive_Body
: Node_Id
;
1132 Current_Primitive_Spec
: Node_Id
;
1133 Current_Primitive_Decl
: Node_Id
;
1134 Current_Primitive_Number
: Int
:= 0;
1136 Current_Primitive_Alias
: Node_Id
;
1138 Current_Receiver
: Entity_Id
;
1139 Current_Receiver_Body
: Node_Id
;
1141 RPC_Receiver_Decl
: Node_Id
;
1143 Possibly_Asynchronous
: Boolean;
1146 if not Expander_Active
then
1151 RPC_Receiver
:= Make_Defining_Identifier
(Loc
,
1152 New_Internal_Name
('P'));
1153 Specific_Build_RPC_Receiver_Body
(
1154 RPC_Receiver
=> RPC_Receiver
,
1155 Request
=> RPC_Receiver_Request
,
1156 Subp_Id
=> RPC_Receiver_Subp_Id
,
1157 Subp_Index
=> RPC_Receiver_Subp_Index
,
1158 Stmts
=> RPC_Receiver_Statements
,
1159 Decl
=> RPC_Receiver_Decl
);
1161 if Get_PCS_Name
= Name_PolyORB_DSA
then
1163 -- For the case of PolyORB, we need to map a textual operation
1164 -- name into a primitive index. Currently we do so using a
1165 -- simple sequence of string comparisons.
1167 RPC_Receiver_Elsif_Parts
:= New_List
;
1171 -- Build callers, receivers for every primitive operations and a RPC
1172 -- receiver for this type.
1174 if Present
(Primitive_Operations
(Designated_Type
)) then
1175 Overload_Counter_Table
.Reset
;
1177 Current_Primitive_Elmt
:=
1178 First_Elmt
(Primitive_Operations
(Designated_Type
));
1179 while Current_Primitive_Elmt
/= No_Elmt
loop
1180 Current_Primitive
:= Node
(Current_Primitive_Elmt
);
1182 -- Copy the primitive of all the parents, except predefined
1183 -- ones that are not remotely dispatching.
1185 if Chars
(Current_Primitive
) /= Name_uSize
1186 and then Chars
(Current_Primitive
) /= Name_uAlignment
1187 and then not Is_TSS
(Current_Primitive
, TSS_Deep_Finalize
)
1189 -- The first thing to do is build an up-to-date copy of
1190 -- the spec with all the formals referencing Designated_Type
1191 -- transformed into formals referencing Stub_Type. Since this
1192 -- primitive may have been inherited, go back the alias chain
1193 -- until the real primitive has been found.
1195 Current_Primitive_Alias
:= Current_Primitive
;
1196 while Present
(Alias
(Current_Primitive_Alias
)) loop
1198 (Current_Primitive_Alias
1199 /= Alias
(Current_Primitive_Alias
));
1200 Current_Primitive_Alias
:= Alias
(Current_Primitive_Alias
);
1203 Current_Primitive_Spec
:=
1204 Copy_Specification
(Loc
,
1205 Spec
=> Parent
(Current_Primitive_Alias
),
1206 Object_Type
=> Designated_Type
,
1207 Stub_Type
=> Stub_Elements
.Stub_Type
);
1209 Current_Primitive_Decl
:=
1210 Make_Subprogram_Declaration
(Loc
,
1211 Specification
=> Current_Primitive_Spec
);
1213 Insert_After
(Current_Insertion_Node
, Current_Primitive_Decl
);
1214 Analyze
(Current_Primitive_Decl
);
1215 Current_Insertion_Node
:= Current_Primitive_Decl
;
1217 Possibly_Asynchronous
:=
1218 Nkind
(Current_Primitive_Spec
) = N_Procedure_Specification
1219 and then Could_Be_Asynchronous
(Current_Primitive_Spec
);
1221 Assign_Subprogram_Identifier
(
1222 Defining_Unit_Name
(Current_Primitive_Spec
),
1223 Current_Primitive_Number
,
1226 Current_Primitive_Body
:=
1227 Build_Subprogram_Calling_Stubs
1228 (Vis_Decl
=> Current_Primitive_Decl
,
1230 Build_Subprogram_Id
(Loc
,
1231 Defining_Unit_Name
(Current_Primitive_Spec
)),
1232 Asynchronous
=> Possibly_Asynchronous
,
1233 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1234 Stub_Type
=> Stub_Elements
.Stub_Type
,
1235 RACW_Type
=> Stub_Elements
.RACW_Type
);
1236 Append_To
(Decls
, Current_Primitive_Body
);
1238 -- Analyzing the body here would cause the Stub type to be
1239 -- frozen, thus preventing subsequent primitive declarations.
1240 -- For this reason, it will be analyzed later in the
1243 -- Build the receiver stubs
1246 Current_Receiver_Body
:=
1247 Specific_Build_Subprogram_Receiving_Stubs
1248 (Vis_Decl
=> Current_Primitive_Decl
,
1249 Asynchronous
=> Possibly_Asynchronous
,
1250 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1251 Stub_Type
=> Stub_Elements
.Stub_Type
,
1252 RACW_Type
=> Stub_Elements
.RACW_Type
,
1253 Parent_Primitive
=> Current_Primitive
);
1255 Current_Receiver
:= Defining_Unit_Name
(
1256 Specification
(Current_Receiver_Body
));
1258 Append_To
(Decls
, Current_Receiver_Body
);
1260 -- Add a case alternative to the receiver
1262 if Get_PCS_Name
= Name_PolyORB_DSA
then
1263 Append_To
(RPC_Receiver_Elsif_Parts
,
1264 Make_Elsif_Part
(Loc
,
1266 Make_Function_Call
(Loc
,
1269 RTE
(RE_Caseless_String_Eq
), Loc
),
1270 Parameter_Associations
=> New_List
(
1271 New_Occurrence_Of
(RPC_Receiver_Subp_Id
, Loc
),
1272 Make_String_Literal
(Loc
, Subp_Str
))),
1273 Then_Statements
=> New_List
(
1274 Make_Assignment_Statement
(Loc
,
1275 Name
=> New_Occurrence_Of
(
1276 RPC_Receiver_Subp_Index
, Loc
),
1278 Make_Integer_Literal
(Loc
,
1279 Current_Primitive_Number
)))));
1282 Append_To
(RPC_Receiver_Case_Alternatives
,
1283 Make_Case_Statement_Alternative
(Loc
,
1284 Discrete_Choices
=> New_List
(
1285 Make_Integer_Literal
(Loc
, Current_Primitive_Number
)),
1287 Statements
=> New_List
(
1288 Make_Procedure_Call_Statement
(Loc
,
1290 New_Occurrence_Of
(Current_Receiver
, Loc
),
1291 Parameter_Associations
=> New_List
(
1292 New_Occurrence_Of
(RPC_Receiver_Request
, Loc
))))));
1295 -- Increment the index of current primitive
1297 Current_Primitive_Number
:= Current_Primitive_Number
+ 1;
1300 Next_Elmt
(Current_Primitive_Elmt
);
1304 -- Build the case statement and the heart of the subprogram
1307 if Get_PCS_Name
= Name_PolyORB_DSA
1308 and then Present
(First
(RPC_Receiver_Elsif_Parts
))
1310 Append_To
(RPC_Receiver_Statements
,
1311 Make_Implicit_If_Statement
(Designated_Type
,
1312 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
1313 Then_Statements
=> New_List
,
1314 Elsif_Parts
=> RPC_Receiver_Elsif_Parts
));
1317 Append_To
(RPC_Receiver_Case_Alternatives
,
1318 Make_Case_Statement_Alternative
(Loc
,
1319 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1320 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
1322 Append_To
(RPC_Receiver_Statements
,
1323 Make_Case_Statement
(Loc
,
1325 New_Occurrence_Of
(RPC_Receiver_Subp_Index
, Loc
),
1326 Alternatives
=> RPC_Receiver_Case_Alternatives
));
1328 Append_To
(Decls
, RPC_Receiver_Decl
);
1329 Specific_Add_Obj_RPC_Receiver_Completion
(Loc
,
1330 Decls
, RPC_Receiver
, Stub_Elements
);
1333 -- Do not analyze RPC receiver at this stage since it will otherwise
1334 -- reference subprograms that have not been analyzed yet. It will
1335 -- be analyzed in the regular flow.
1337 end Add_RACW_Primitive_Declarations_And_Bodies
;
1339 -----------------------------
1340 -- Add_RAS_Dereference_TSS --
1341 -----------------------------
1343 procedure Add_RAS_Dereference_TSS
(N
: Node_Id
) is
1344 Loc
: constant Source_Ptr
:= Sloc
(N
);
1346 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
1348 RAS_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
1349 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(RAS_Type
);
1350 RACW_Type
: constant Entity_Id
:= Underlying_RACW_Type
(RAS_Type
);
1351 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
1353 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
1354 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
1356 RACW_Primitive_Name
: Node_Id
;
1358 Proc
: constant Entity_Id
:=
1359 Make_Defining_Identifier
(Loc
,
1360 Chars
=> Make_TSS_Name
(RAS_Type
, TSS_RAS_Dereference
));
1362 Proc_Spec
: Node_Id
;
1363 Param_Specs
: List_Id
;
1364 Param_Assoc
: constant List_Id
:= New_List
;
1365 Stmts
: constant List_Id
:= New_List
;
1367 RAS_Parameter
: constant Entity_Id
:=
1368 Make_Defining_Identifier
(Loc
,
1369 Chars
=> New_Internal_Name
('P'));
1371 Is_Function
: constant Boolean :=
1372 Nkind
(Type_Def
) = N_Access_Function_Definition
;
1374 Is_Degenerate
: Boolean;
1375 -- Set to True if the subprogram_specification for this RAS has
1376 -- an anonymous access parameter (see Process_Remote_AST_Declaration).
1378 Spec
: constant Node_Id
:= Type_Def
;
1380 Current_Parameter
: Node_Id
;
1382 -- Start of processing for Add_RAS_Dereference_TSS
1385 -- The Dereference TSS for a remote access-to-subprogram type
1388 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1391 -- This is called whenever a value of a RAS type is dereferenced
1393 -- First construct a list of parameter specifications:
1395 -- The first formal is the RAS values
1397 Param_Specs
:= New_List
(
1398 Make_Parameter_Specification
(Loc
,
1399 Defining_Identifier
=> RAS_Parameter
,
1402 New_Occurrence_Of
(Fat_Type
, Loc
)));
1404 -- The following formals are copied from the type declaration
1406 Is_Degenerate
:= False;
1407 Current_Parameter
:= First
(Parameter_Specifications
(Type_Def
));
1408 Parameters
: while Present
(Current_Parameter
) loop
1409 if Nkind
(Parameter_Type
(Current_Parameter
))
1410 = N_Access_Definition
1412 Is_Degenerate
:= True;
1414 Append_To
(Param_Specs
,
1415 Make_Parameter_Specification
(Loc
,
1416 Defining_Identifier
=>
1417 Make_Defining_Identifier
(Loc
,
1418 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))),
1419 In_Present
=> In_Present
(Current_Parameter
),
1420 Out_Present
=> Out_Present
(Current_Parameter
),
1422 New_Copy_Tree
(Parameter_Type
(Current_Parameter
)),
1424 New_Copy_Tree
(Expression
(Current_Parameter
))));
1426 Append_To
(Param_Assoc
,
1427 Make_Identifier
(Loc
,
1428 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))));
1430 Next
(Current_Parameter
);
1431 end loop Parameters
;
1433 if Is_Degenerate
then
1434 Prepend_To
(Param_Assoc
, New_Occurrence_Of
(RAS_Parameter
, Loc
));
1436 -- Generate a dummy body. This code will never actually be executed,
1437 -- because null is the only legal value for a degenerate RAS type.
1438 -- For legality's sake (in order to avoid generating a function
1439 -- that does not contain a return statement), we include a dummy
1440 -- recursive call on the TSS itself.
1443 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Explicit_Raise
));
1444 RACW_Primitive_Name
:= New_Occurrence_Of
(Proc
, Loc
);
1447 -- For a normal RAS type, we cast the RAS formal to the corresponding
1448 -- tagged type, and perform a dispatching call to its Call
1449 -- primitive operation.
1451 Prepend_To
(Param_Assoc
,
1452 Unchecked_Convert_To
(RACW_Type
,
1453 New_Occurrence_Of
(RAS_Parameter
, Loc
)));
1455 RACW_Primitive_Name
:= Make_Selected_Component
(Loc
,
1456 Prefix
=> Scope
(RACW_Type
),
1457 Selector_Name
=> Name_Call
);
1462 Make_Return_Statement
(Loc
,
1464 Make_Function_Call
(Loc
,
1466 RACW_Primitive_Name
,
1467 Parameter_Associations
=> Param_Assoc
)));
1471 Make_Procedure_Call_Statement
(Loc
,
1473 RACW_Primitive_Name
,
1474 Parameter_Associations
=> Param_Assoc
));
1477 -- Build the complete subprogram
1481 Make_Function_Specification
(Loc
,
1482 Defining_Unit_Name
=> Proc
,
1483 Parameter_Specifications
=> Param_Specs
,
1484 Result_Definition
=>
1486 Entity
(Result_Definition
(Spec
)), Loc
));
1488 Set_Ekind
(Proc
, E_Function
);
1490 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
1494 Make_Procedure_Specification
(Loc
,
1495 Defining_Unit_Name
=> Proc
,
1496 Parameter_Specifications
=> Param_Specs
);
1498 Set_Ekind
(Proc
, E_Procedure
);
1499 Set_Etype
(Proc
, Standard_Void_Type
);
1503 Make_Subprogram_Body
(Loc
,
1504 Specification
=> Proc_Spec
,
1505 Declarations
=> New_List
,
1506 Handled_Statement_Sequence
=>
1507 Make_Handled_Sequence_Of_Statements
(Loc
,
1508 Statements
=> Stmts
)));
1510 Set_TSS
(Fat_Type
, Proc
);
1511 end Add_RAS_Dereference_TSS
;
1513 -------------------------------
1514 -- Add_RAS_Proxy_And_Analyze --
1515 -------------------------------
1517 procedure Add_RAS_Proxy_And_Analyze
1520 All_Calls_Remote_E
: Entity_Id
;
1521 Proxy_Object_Addr
: out Entity_Id
)
1523 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
1525 Subp_Name
: constant Entity_Id
:=
1526 Defining_Unit_Name
(Specification
(Vis_Decl
));
1528 Pkg_Name
: constant Entity_Id
:=
1529 Make_Defining_Identifier
(Loc
,
1531 New_External_Name
(Chars
(Subp_Name
), 'P', -1));
1533 Proxy_Type
: constant Entity_Id
:=
1534 Make_Defining_Identifier
(Loc
,
1537 Related_Id
=> Chars
(Subp_Name
),
1540 Proxy_Type_Full_View
: constant Entity_Id
:=
1541 Make_Defining_Identifier
(Loc
,
1542 Chars
(Proxy_Type
));
1544 Subp_Decl_Spec
: constant Node_Id
:=
1545 Build_RAS_Primitive_Specification
1546 (Subp_Spec
=> Specification
(Vis_Decl
),
1547 Remote_Object_Type
=> Proxy_Type
);
1549 Subp_Body_Spec
: constant Node_Id
:=
1550 Build_RAS_Primitive_Specification
1551 (Subp_Spec
=> Specification
(Vis_Decl
),
1552 Remote_Object_Type
=> Proxy_Type
);
1554 Vis_Decls
: constant List_Id
:= New_List
;
1555 Pvt_Decls
: constant List_Id
:= New_List
;
1556 Actuals
: constant List_Id
:= New_List
;
1558 Perform_Call
: Node_Id
;
1561 -- type subpP is tagged limited private;
1563 Append_To
(Vis_Decls
,
1564 Make_Private_Type_Declaration
(Loc
,
1565 Defining_Identifier
=> Proxy_Type
,
1566 Tagged_Present
=> True,
1567 Limited_Present
=> True));
1569 -- [subprogram] Call
1570 -- (Self : access subpP;
1571 -- ...other-formals...)
1574 Append_To
(Vis_Decls
,
1575 Make_Subprogram_Declaration
(Loc
,
1576 Specification
=> Subp_Decl_Spec
));
1578 -- A : constant System.Address;
1580 Proxy_Object_Addr
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1582 Append_To
(Vis_Decls
,
1583 Make_Object_Declaration
(Loc
,
1584 Defining_Identifier
=>
1588 Object_Definition
=>
1589 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
1593 -- type subpP is tagged limited record
1594 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1598 Append_To
(Pvt_Decls
,
1599 Make_Full_Type_Declaration
(Loc
,
1600 Defining_Identifier
=>
1601 Proxy_Type_Full_View
,
1603 Build_Remote_Subprogram_Proxy_Type
(Loc
,
1604 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
))));
1606 -- Trick semantic analysis into swapping the public and
1607 -- full view when freezing the public view.
1609 Set_Comes_From_Source
(Proxy_Type_Full_View
, True);
1612 -- (Self : access O;
1613 -- ...other-formals...) is
1615 -- P (...other-formals...);
1619 -- (Self : access O;
1620 -- ...other-formals...)
1623 -- return F (...other-formals...);
1626 if Nkind
(Subp_Decl_Spec
) = N_Procedure_Specification
then
1628 Make_Procedure_Call_Statement
(Loc
,
1630 New_Occurrence_Of
(Subp_Name
, Loc
),
1631 Parameter_Associations
=>
1635 Make_Return_Statement
(Loc
,
1637 Make_Function_Call
(Loc
,
1639 New_Occurrence_Of
(Subp_Name
, Loc
),
1640 Parameter_Associations
=>
1644 Formal
:= First
(Parameter_Specifications
(Subp_Decl_Spec
));
1645 pragma Assert
(Present
(Formal
));
1648 exit when No
(Formal
);
1650 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1653 -- O : aliased subpP;
1655 Append_To
(Pvt_Decls
,
1656 Make_Object_Declaration
(Loc
,
1657 Defining_Identifier
=>
1658 Make_Defining_Identifier
(Loc
,
1662 Object_Definition
=>
1663 New_Occurrence_Of
(Proxy_Type
, Loc
)));
1665 -- A : constant System.Address := O'Address;
1667 Append_To
(Pvt_Decls
,
1668 Make_Object_Declaration
(Loc
,
1669 Defining_Identifier
=>
1670 Make_Defining_Identifier
(Loc
,
1671 Chars
(Proxy_Object_Addr
)),
1674 Object_Definition
=>
1675 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
1677 Make_Attribute_Reference
(Loc
,
1678 Prefix
=> New_Occurrence_Of
(
1679 Defining_Identifier
(Last
(Pvt_Decls
)), Loc
),
1684 Make_Package_Declaration
(Loc
,
1685 Specification
=> Make_Package_Specification
(Loc
,
1686 Defining_Unit_Name
=> Pkg_Name
,
1687 Visible_Declarations
=> Vis_Decls
,
1688 Private_Declarations
=> Pvt_Decls
,
1689 End_Label
=> Empty
)));
1690 Analyze
(Last
(Decls
));
1693 Make_Package_Body
(Loc
,
1694 Defining_Unit_Name
=>
1695 Make_Defining_Identifier
(Loc
,
1697 Declarations
=> New_List
(
1698 Make_Subprogram_Body
(Loc
,
1701 Declarations
=> New_List
,
1702 Handled_Statement_Sequence
=>
1703 Make_Handled_Sequence_Of_Statements
(Loc
,
1704 Statements
=> New_List
(Perform_Call
))))));
1705 Analyze
(Last
(Decls
));
1706 end Add_RAS_Proxy_And_Analyze
;
1708 -----------------------
1709 -- Add_RAST_Features --
1710 -----------------------
1712 procedure Add_RAST_Features
(Vis_Decl
: Node_Id
) is
1713 RAS_Type
: constant Entity_Id
:=
1714 Equivalent_Type
(Defining_Identifier
(Vis_Decl
));
1716 pragma Assert
(No
(TSS
(RAS_Type
, TSS_RAS_Access
)));
1717 Add_RAS_Dereference_TSS
(Vis_Decl
);
1718 Specific_Add_RAST_Features
(Vis_Decl
, RAS_Type
);
1719 end Add_RAST_Features
;
1725 procedure Add_Stub_Type
1726 (Designated_Type
: Entity_Id
;
1727 RACW_Type
: Entity_Id
;
1729 Stub_Type
: out Entity_Id
;
1730 Stub_Type_Access
: out Entity_Id
;
1731 RPC_Receiver_Decl
: out Node_Id
;
1732 Existing
: out Boolean)
1734 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1736 Stub_Elements
: constant Stub_Structure
:=
1737 Stubs_Table
.Get
(Designated_Type
);
1738 Stub_Type_Decl
: Node_Id
;
1739 Stub_Type_Access_Decl
: Node_Id
;
1742 if Stub_Elements
/= Empty_Stub_Structure
then
1743 Stub_Type
:= Stub_Elements
.Stub_Type
;
1744 Stub_Type_Access
:= Stub_Elements
.Stub_Type_Access
;
1745 RPC_Receiver_Decl
:= Stub_Elements
.RPC_Receiver_Decl
;
1752 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
1754 Make_Defining_Identifier
(Loc
,
1756 Related_Id
=> Chars
(Stub_Type
),
1759 Specific_Build_Stub_Type
(
1760 RACW_Type
, Stub_Type
,
1761 Stub_Type_Decl
, RPC_Receiver_Decl
);
1763 Stub_Type_Access_Decl
:=
1764 Make_Full_Type_Declaration
(Loc
,
1765 Defining_Identifier
=> Stub_Type_Access
,
1767 Make_Access_To_Object_Definition
(Loc
,
1768 All_Present
=> True,
1769 Subtype_Indication
=> New_Occurrence_Of
(Stub_Type
, Loc
)));
1771 Append_To
(Decls
, Stub_Type_Decl
);
1772 Analyze
(Last
(Decls
));
1773 Append_To
(Decls
, Stub_Type_Access_Decl
);
1774 Analyze
(Last
(Decls
));
1776 -- This is in no way a type derivation, but we fake it to make
1777 -- sure that the dispatching table gets built with the corresponding
1778 -- primitive operations at the right place.
1780 Derive_Subprograms
(Parent_Type
=> Designated_Type
,
1781 Derived_Type
=> Stub_Type
);
1783 if Present
(RPC_Receiver_Decl
) then
1784 Append_To
(Decls
, RPC_Receiver_Decl
);
1786 RPC_Receiver_Decl
:= Last
(Decls
);
1789 Stubs_Table
.Set
(Designated_Type
,
1790 (Stub_Type
=> Stub_Type
,
1791 Stub_Type_Access
=> Stub_Type_Access
,
1792 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1793 RACW_Type
=> RACW_Type
));
1796 ----------------------------------
1797 -- Assign_Subprogram_Identifier --
1798 ----------------------------------
1800 procedure Assign_Subprogram_Identifier
1805 N
: constant Name_Id
:= Chars
(Def
);
1807 Overload_Order
: constant Int
:=
1808 Overload_Counter_Table
.Get
(N
) + 1;
1811 Overload_Counter_Table
.Set
(N
, Overload_Order
);
1813 Get_Name_String
(N
);
1815 -- Homonym handling: as in Exp_Dbug, but much simpler,
1816 -- because the only entities for which we have to generate
1817 -- names here need only to be disambiguated within their
1820 if Overload_Order
> 1 then
1821 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 2) := "__";
1822 Name_Len
:= Name_Len
+ 2;
1823 Add_Nat_To_Name_Buffer
(Overload_Order
);
1826 Id
:= String_From_Name_Buffer
;
1827 Subprogram_Identifier_Table
.Set
(Def
,
1828 Subprogram_Identifiers
'(Str_Identifier => Id, Int_Identifier => Spn));
1829 end Assign_Subprogram_Identifier;
1831 ------------------------------
1832 -- Build_Get_Unique_RP_Call --
1833 ------------------------------
1835 function Build_Get_Unique_RP_Call
1837 Pointer : Entity_Id;
1838 Stub_Type : Entity_Id) return List_Id
1842 Make_Procedure_Call_Statement (Loc,
1844 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
1845 Parameter_Associations => New_List (
1846 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
1847 New_Occurrence_Of (Pointer, Loc)))),
1849 Make_Assignment_Statement (Loc,
1851 Make_Selected_Component (Loc,
1853 New_Occurrence_Of (Pointer, Loc),
1855 New_Occurrence_Of (First_Tag_Component
1856 (Designated_Type (Etype (Pointer))), Loc)),
1858 Make_Attribute_Reference (Loc,
1860 New_Occurrence_Of (Stub_Type, Loc),
1864 -- Note: The assignment to Pointer._Tag is safe here because
1865 -- we carefully ensured that Stub_Type has exactly the same layout
1866 -- as System.Partition_Interface.RACW_Stub_Type.
1868 end Build_Get_Unique_RP_Call;
1870 -----------------------------------
1871 -- Build_Ordered_Parameters_List --
1872 -----------------------------------
1874 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
1875 Constrained_List : List_Id;
1876 Unconstrained_List : List_Id;
1877 Current_Parameter : Node_Id;
1879 First_Parameter : Node_Id;
1880 For_RAS : Boolean := False;
1883 if not Present (Parameter_Specifications (Spec)) then
1887 Constrained_List := New_List;
1888 Unconstrained_List := New_List;
1889 First_Parameter := First (Parameter_Specifications (Spec));
1891 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
1892 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
1897 -- Loop through the parameters and add them to the right list
1899 Current_Parameter := First_Parameter;
1900 while Present (Current_Parameter) loop
1901 if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
1903 Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
1905 Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
1906 and then not (For_RAS and then Current_Parameter = First_Parameter)
1908 Append_To (Constrained_List, New_Copy (Current_Parameter));
1910 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
1913 Next (Current_Parameter);
1916 -- Unconstrained parameters are returned first
1918 Append_List_To (Unconstrained_List, Constrained_List);
1920 return Unconstrained_List;
1921 end Build_Ordered_Parameters_List;
1923 ----------------------------------
1924 -- Build_Passive_Partition_Stub --
1925 ----------------------------------
1927 procedure Build_Passive_Partition_Stub (U : Node_Id) is
1929 Pkg_Name : String_Id;
1932 Loc : constant Source_Ptr := Sloc (U);
1935 -- Verify that the implementation supports distribution, by accessing
1936 -- a type defined in the proper version of system.rpc
1939 Dist_OK : Entity_Id;
1940 pragma Warnings (Off, Dist_OK);
1942 Dist_OK := RTE (RE_Params_Stream_Type);
1945 -- Use body if present, spec otherwise
1947 if Nkind (U) = N_Package_Declaration then
1948 Pkg_Spec := Specification (U);
1949 L := Visible_Declarations (Pkg_Spec);
1951 Pkg_Spec := Parent (Corresponding_Spec (U));
1952 L := Declarations (U);
1955 Get_Library_Unit_Name_String (Pkg_Spec);
1956 Pkg_Name := String_From_Name_Buffer;
1958 Make_Procedure_Call_Statement (Loc,
1960 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
1961 Parameter_Associations => New_List (
1962 Make_String_Literal (Loc, Pkg_Name),
1963 Make_Attribute_Reference (Loc,
1965 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
1970 end Build_Passive_Partition_Stub;
1972 --------------------------------------
1973 -- Build_RPC_Receiver_Specification --
1974 --------------------------------------
1976 function Build_RPC_Receiver_Specification
1977 (RPC_Receiver : Entity_Id;
1978 Request_Parameter : Entity_Id) return Node_Id
1980 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
1983 Make_Procedure_Specification (Loc,
1984 Defining_Unit_Name => RPC_Receiver,
1985 Parameter_Specifications => New_List (
1986 Make_Parameter_Specification (Loc,
1987 Defining_Identifier => Request_Parameter,
1989 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
1990 end Build_RPC_Receiver_Specification;
1992 ----------------------------------------
1993 -- Build_Remote_Subprogram_Proxy_Type --
1994 ----------------------------------------
1996 function Build_Remote_Subprogram_Proxy_Type
1998 ACR_Expression : Node_Id) return Node_Id
2002 Make_Record_Definition (Loc,
2003 Tagged_Present => True,
2004 Limited_Present => True,
2006 Make_Component_List (Loc,
2008 Component_Items => New_List (
2009 Make_Component_Declaration (Loc,
2010 Defining_Identifier =>
2011 Make_Defining_Identifier (Loc,
2012 Name_All_Calls_Remote),
2013 Component_Definition =>
2014 Make_Component_Definition (Loc,
2015 Subtype_Indication =>
2016 New_Occurrence_Of (Standard_Boolean, Loc)),
2020 Make_Component_Declaration (Loc,
2021 Defining_Identifier =>
2022 Make_Defining_Identifier (Loc,
2024 Component_Definition =>
2025 Make_Component_Definition (Loc,
2026 Subtype_Indication =>
2027 New_Occurrence_Of (RTE (RE_Address), Loc)),
2029 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2031 Make_Component_Declaration (Loc,
2032 Defining_Identifier =>
2033 Make_Defining_Identifier (Loc,
2035 Component_Definition =>
2036 Make_Component_Definition (Loc,
2037 Subtype_Indication =>
2038 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2039 end Build_Remote_Subprogram_Proxy_Type;
2041 ------------------------------------
2042 -- Build_Subprogram_Calling_Stubs --
2043 ------------------------------------
2045 function Build_Subprogram_Calling_Stubs
2046 (Vis_Decl : Node_Id;
2048 Asynchronous : Boolean;
2049 Dynamically_Asynchronous : Boolean := False;
2050 Stub_Type : Entity_Id := Empty;
2051 RACW_Type : Entity_Id := Empty;
2052 Locator : Entity_Id := Empty;
2053 New_Name : Name_Id := No_Name) return Node_Id
2055 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2057 Decls : constant List_Id := New_List;
2058 Statements : constant List_Id := New_List;
2060 Subp_Spec : Node_Id;
2061 -- The specification of the body
2063 Controlling_Parameter : Entity_Id := Empty;
2065 Asynchronous_Expr : Node_Id := Empty;
2067 RCI_Locator : Entity_Id;
2069 Spec_To_Use : Node_Id;
2071 procedure Insert_Partition_Check (Parameter : Node_Id);
2072 -- Check that the parameter has been elaborated on the same partition
2073 -- than the controlling parameter (E.4(19)).
2075 ----------------------------
2076 -- Insert_Partition_Check --
2077 ----------------------------
2079 procedure Insert_Partition_Check (Parameter : Node_Id) is
2080 Parameter_Entity : constant Entity_Id :=
2081 Defining_Identifier (Parameter);
2083 -- The expression that will be built is of the form:
2085 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2086 -- raise Constraint_Error;
2089 -- We do not check that Parameter is in Stub_Type since such a check
2090 -- has been inserted at the point of call already (a tag check since
2091 -- we have multiple controlling operands).
2094 Make_Raise_Constraint_Error (Loc,
2098 Make_Function_Call (Loc,
2100 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2101 Parameter_Associations =>
2103 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2104 New_Occurrence_Of (Parameter_Entity, Loc)),
2105 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2106 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2107 Reason => CE_Partition_Check_Failed));
2108 end Insert_Partition_Check;
2110 -- Start of processing for Build_Subprogram_Calling_Stubs
2113 Subp_Spec := Copy_Specification (Loc,
2114 Spec => Specification (Vis_Decl),
2115 New_Name => New_Name);
2117 if Locator = Empty then
2118 RCI_Locator := RCI_Cache;
2119 Spec_To_Use := Specification (Vis_Decl);
2121 RCI_Locator := Locator;
2122 Spec_To_Use := Subp_Spec;
2125 -- Find a controlling argument if we have a stub type. Also check
2126 -- if this subprogram can be made asynchronous.
2128 if Present (Stub_Type)
2129 and then Present (Parameter_Specifications (Spec_To_Use))
2132 Current_Parameter : Node_Id :=
2133 First (Parameter_Specifications
2136 while Present (Current_Parameter) loop
2138 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2140 if Controlling_Parameter = Empty then
2141 Controlling_Parameter :=
2142 Defining_Identifier (Current_Parameter);
2144 Insert_Partition_Check (Current_Parameter);
2148 Next (Current_Parameter);
2153 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2155 if Dynamically_Asynchronous then
2156 Asynchronous_Expr := Make_Selected_Component (Loc,
2157 Prefix => Controlling_Parameter,
2158 Selector_Name => Name_Asynchronous);
2161 Specific_Build_General_Calling_Stubs
2163 Statements => Statements,
2164 Target => Specific_Build_Stub_Target (Loc,
2165 Decls, RCI_Locator, Controlling_Parameter),
2166 Subprogram_Id => Subp_Id,
2167 Asynchronous => Asynchronous_Expr,
2168 Is_Known_Asynchronous => Asynchronous
2169 and then not Dynamically_Asynchronous,
2170 Is_Known_Non_Asynchronous
2172 and then not Dynamically_Asynchronous,
2173 Is_Function => Nkind (Spec_To_Use) =
2174 N_Function_Specification,
2175 Spec => Spec_To_Use,
2176 Stub_Type => Stub_Type,
2177 RACW_Type => RACW_Type,
2180 RCI_Calling_Stubs_Table.Set
2181 (Defining_Unit_Name (Specification (Vis_Decl)),
2182 Defining_Unit_Name (Spec_To_Use));
2185 Make_Subprogram_Body (Loc,
2186 Specification => Subp_Spec,
2187 Declarations => Decls,
2188 Handled_Statement_Sequence =>
2189 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2190 end Build_Subprogram_Calling_Stubs;
2192 -------------------------
2193 -- Build_Subprogram_Id --
2194 -------------------------
2196 function Build_Subprogram_Id
2198 E : Entity_Id) return Node_Id
2201 case Get_PCS_Name is
2202 when Name_PolyORB_DSA =>
2203 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2205 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2207 end Build_Subprogram_Id;
2209 ------------------------
2210 -- Copy_Specification --
2211 ------------------------
2213 function Copy_Specification
2216 Object_Type : Entity_Id := Empty;
2217 Stub_Type : Entity_Id := Empty;
2218 New_Name : Name_Id := No_Name) return Node_Id
2220 Parameters : List_Id := No_List;
2222 Current_Parameter : Node_Id;
2223 Current_Identifier : Entity_Id;
2224 Current_Type : Node_Id;
2225 Current_Etype : Entity_Id;
2227 Name_For_New_Spec : Name_Id;
2229 New_Identifier : Entity_Id;
2231 -- Comments needed in body below ???
2234 if New_Name = No_Name then
2235 pragma Assert (Nkind (Spec) = N_Function_Specification
2236 or else Nkind (Spec) = N_Procedure_Specification);
2238 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2240 Name_For_New_Spec := New_Name;
2243 if Present (Parameter_Specifications (Spec)) then
2244 Parameters := New_List;
2245 Current_Parameter := First (Parameter_Specifications (Spec));
2246 while Present (Current_Parameter) loop
2247 Current_Identifier := Defining_Identifier (Current_Parameter);
2248 Current_Type := Parameter_Type (Current_Parameter);
2250 if Nkind (Current_Type) = N_Access_Definition then
2251 Current_Etype := Entity (Subtype_Mark (Current_Type));
2253 if Present (Object_Type) then
2255 Root_Type (Current_Etype) = Root_Type (Object_Type));
2257 Make_Access_Definition (Loc,
2258 Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
2261 Make_Access_Definition (Loc,
2263 New_Occurrence_Of (Current_Etype, Loc));
2267 Current_Etype := Entity (Current_Type);
2269 if Present (Object_Type)
2270 and then Current_Etype = Object_Type
2272 Current_Type := New_Occurrence_Of (Stub_Type, Loc);
2274 Current_Type := New_Occurrence_Of (Current_Etype, Loc);
2278 New_Identifier := Make_Defining_Identifier (Loc,
2279 Chars (Current_Identifier));
2281 Append_To (Parameters,
2282 Make_Parameter_Specification (Loc,
2283 Defining_Identifier => New_Identifier,
2284 Parameter_Type => Current_Type,
2285 In_Present => In_Present (Current_Parameter),
2286 Out_Present => Out_Present (Current_Parameter),
2288 New_Copy_Tree (Expression (Current_Parameter))));
2290 -- For a regular formal parameter (that needs to be marshalled
2291 -- in the context of remote calls), set the Etype now, because
2292 -- marshalling processing might need it.
2294 if Is_Entity_Name (Current_Type) then
2295 Set_Etype (New_Identifier, Entity (Current_Type));
2297 -- Current_Type is an access definition, special processing
2298 -- (not requiring etype) will occur for marshalling.
2304 Next (Current_Parameter);
2308 case Nkind (Spec) is
2310 when N_Function_Specification | N_Access_Function_Definition =>
2312 Make_Function_Specification (Loc,
2313 Defining_Unit_Name =>
2314 Make_Defining_Identifier (Loc,
2315 Chars => Name_For_New_Spec),
2316 Parameter_Specifications => Parameters,
2317 Result_Definition =>
2318 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2320 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2322 Make_Procedure_Specification (Loc,
2323 Defining_Unit_Name =>
2324 Make_Defining_Identifier (Loc,
2325 Chars => Name_For_New_Spec),
2326 Parameter_Specifications => Parameters);
2329 raise Program_Error;
2331 end Copy_Specification;
2333 ---------------------------
2334 -- Could_Be_Asynchronous --
2335 ---------------------------
2337 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2338 Current_Parameter : Node_Id;
2341 if Present (Parameter_Specifications (Spec)) then
2342 Current_Parameter := First (Parameter_Specifications (Spec));
2343 while Present (Current_Parameter) loop
2344 if Out_Present (Current_Parameter) then
2348 Next (Current_Parameter);
2353 end Could_Be_Asynchronous;
2355 ---------------------------
2356 -- Declare_Create_NVList --
2357 ---------------------------
2359 procedure Declare_Create_NVList
2367 Make_Object_Declaration (Loc,
2368 Defining_Identifier => NVList,
2369 Aliased_Present => False,
2370 Object_Definition =>
2371 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2374 Make_Procedure_Call_Statement (Loc,
2376 New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2377 Parameter_Associations => New_List (
2378 New_Occurrence_Of (NVList, Loc))));
2379 end Declare_Create_NVList;
2381 ---------------------------------------------
2382 -- Expand_All_Calls_Remote_Subprogram_Call --
2383 ---------------------------------------------
2385 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2386 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2387 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2388 Loc : constant Source_Ptr := Sloc (N);
2389 RCI_Locator : Node_Id;
2390 RCI_Cache : Entity_Id;
2391 Calling_Stubs : Node_Id;
2392 E_Calling_Stubs : Entity_Id;
2395 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2397 if E_Calling_Stubs = Empty then
2398 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
2400 if RCI_Cache = Empty then
2403 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2404 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
2406 -- The RCI_Locator package is inserted at the top level in the
2407 -- current unit, and must appear in the proper scope, so that it
2408 -- is not prematurely removed by the GCC back-end.
2411 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2414 if Ekind (Scop) = E_Package_Body then
2415 New_Scope (Spec_Entity (Scop));
2417 elsif Ekind (Scop) = E_Subprogram_Body then
2419 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2425 Analyze (RCI_Locator);
2429 RCI_Cache := Defining_Unit_Name (RCI_Locator);
2432 RCI_Locator := Parent (RCI_Cache);
2435 Calling_Stubs := Build_Subprogram_Calling_Stubs
2436 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2438 Build_Subprogram_Id (Loc, Called_Subprogram),
2439 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2441 Is_Asynchronous (Called_Subprogram),
2442 Locator => RCI_Cache,
2443 New_Name => New_Internal_Name ('S
'));
2444 Insert_After (RCI_Locator, Calling_Stubs);
2445 Analyze (Calling_Stubs);
2446 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2449 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2450 end Expand_All_Calls_Remote_Subprogram_Call;
2452 ---------------------------------
2453 -- Expand_Calling_Stubs_Bodies --
2454 ---------------------------------
2456 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2457 Spec : constant Node_Id := Specification (Unit_Node);
2458 Decls : constant List_Id := Visible_Declarations (Spec);
2460 New_Scope (Scope_Of_Spec (Spec));
2461 Add_Calling_Stubs_To_Declarations
2462 (Specification (Unit_Node), Decls);
2464 end Expand_Calling_Stubs_Bodies;
2466 -----------------------------------
2467 -- Expand_Receiving_Stubs_Bodies --
2468 -----------------------------------
2470 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2476 if Nkind (Unit_Node) = N_Package_Declaration then
2477 Spec := Specification (Unit_Node);
2478 Decls := Private_Declarations (Spec);
2481 Decls := Visible_Declarations (Spec);
2484 New_Scope (Scope_Of_Spec (Spec));
2485 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls);
2489 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2490 Decls := Declarations (Unit_Node);
2491 New_Scope (Scope_Of_Spec (Unit_Node));
2493 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Temp);
2494 Insert_List_Before (First (Decls), Temp);
2498 end Expand_Receiving_Stubs_Bodies;
2500 --------------------
2501 -- GARLIC_Support --
2502 --------------------
2504 package body GARLIC_Support is
2506 -- Local subprograms
2508 procedure Add_RACW_Read_Attribute
2509 (RACW_Type : Entity_Id;
2510 Stub_Type : Entity_Id;
2511 Stub_Type_Access : Entity_Id;
2512 Declarations : List_Id);
2513 -- Add Read attribute in Decls for the RACW type. The Read attribute
2514 -- is added right after the RACW_Type declaration while the body is
2515 -- inserted after Declarations.
2517 procedure Add_RACW_Write_Attribute
2518 (RACW_Type : Entity_Id;
2519 Stub_Type : Entity_Id;
2520 Stub_Type_Access : Entity_Id;
2521 RPC_Receiver : Node_Id;
2522 Declarations : List_Id);
2523 -- Same thing for the Write attribute
2525 function Stream_Parameter return Node_Id;
2526 function Result return Node_Id;
2527 function Object return Node_Id renames Result;
2528 -- Functions to create occurrences of the formal parameter names of
2529 -- the 'Read
and 'Write attributes.
2532 -- Shared source location used by Add_{Read,Write}_Read_Attribute
2533 -- and their ancillary subroutines (set on entry by Add_RACW_Features).
2535 procedure Add_RAS_Access_TSS (N : Node_Id);
2536 -- Add a subprogram body for RAS Access TSS
2538 -------------------------------------
2539 -- Add_Obj_RPC_Receiver_Completion --
2540 -------------------------------------
2542 procedure Add_Obj_RPC_Receiver_Completion
2545 RPC_Receiver : Entity_Id;
2546 Stub_Elements : Stub_Structure) is
2548 -- The RPC receiver body should not be the completion of the
2549 -- declaration recorded in the stub structure, because then the
2550 -- occurrences of the formal parameters within the body should
2551 -- refer to the entities from the declaration, not from the
2552 -- completion, to which we do not have easy access. Instead, the
2553 -- RPC receiver body acts as its own declaration, and the RPC
2554 -- receiver declaration is completed by a renaming-as-body.
2557 Make_Subprogram_Renaming_Declaration (Loc,
2559 Copy_Specification (Loc,
2560 Specification (Stub_Elements.RPC_Receiver_Decl)),
2561 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2562 end Add_Obj_RPC_Receiver_Completion;
2564 -----------------------
2565 -- Add_RACW_Features --
2566 -----------------------
2568 procedure Add_RACW_Features
2569 (RACW_Type : Entity_Id;
2570 Stub_Type : Entity_Id;
2571 Stub_Type_Access : Entity_Id;
2572 RPC_Receiver_Decl : Node_Id;
2573 Declarations : List_Id)
2575 RPC_Receiver : Node_Id;
2576 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2579 Loc := Sloc (RACW_Type);
2583 -- For a RAS, the RPC receiver is that of the RCI unit,
2584 -- not that of the corresponding distributed object type.
2585 -- We retrieve its address from the local proxy object.
2587 RPC_Receiver := Make_Selected_Component (Loc,
2589 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2590 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2593 RPC_Receiver := Make_Attribute_Reference (Loc,
2594 Prefix => New_Occurrence_Of (
2595 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2596 Attribute_Name => Name_Address);
2599 Add_RACW_Write_Attribute (
2606 Add_RACW_Read_Attribute (
2611 end Add_RACW_Features;
2613 -----------------------------
2614 -- Add_RACW_Read_Attribute --
2615 -----------------------------
2617 procedure Add_RACW_Read_Attribute
2618 (RACW_Type : Entity_Id;
2619 Stub_Type : Entity_Id;
2620 Stub_Type_Access : Entity_Id;
2621 Declarations : List_Id)
2623 Proc_Decl : Node_Id;
2624 Attr_Decl : Node_Id;
2626 Body_Node : Node_Id;
2629 Statements : List_Id;
2630 Local_Statements : List_Id;
2631 Remote_Statements : List_Id;
2632 -- Various parts of the procedure
2634 Procedure_Name : constant Name_Id :=
2635 New_Internal_Name ('R
');
2636 Source_Partition : constant Entity_Id :=
2637 Make_Defining_Identifier
2638 (Loc, New_Internal_Name ('P
'));
2639 Source_Receiver : constant Entity_Id :=
2640 Make_Defining_Identifier
2641 (Loc, New_Internal_Name ('S
'));
2642 Source_Address : constant Entity_Id :=
2643 Make_Defining_Identifier
2644 (Loc, New_Internal_Name ('P
'));
2645 Local_Stub : constant Entity_Id :=
2646 Make_Defining_Identifier
2647 (Loc, New_Internal_Name ('L
'));
2648 Stubbed_Result : constant Entity_Id :=
2649 Make_Defining_Identifier
2650 (Loc, New_Internal_Name ('S
'));
2651 Asynchronous_Flag : constant Entity_Id :=
2652 Asynchronous_Flags_Table.Get (RACW_Type);
2653 pragma Assert (Present (Asynchronous_Flag));
2655 -- Start of processing for Add_RACW_Read_Attribute
2658 -- Generate object declarations
2661 Make_Object_Declaration (Loc,
2662 Defining_Identifier => Source_Partition,
2663 Object_Definition =>
2664 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
2666 Make_Object_Declaration (Loc,
2667 Defining_Identifier => Source_Receiver,
2668 Object_Definition =>
2669 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2671 Make_Object_Declaration (Loc,
2672 Defining_Identifier => Source_Address,
2673 Object_Definition =>
2674 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2676 Make_Object_Declaration (Loc,
2677 Defining_Identifier => Local_Stub,
2678 Aliased_Present => True,
2679 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
2681 Make_Object_Declaration (Loc,
2682 Defining_Identifier => Stubbed_Result,
2683 Object_Definition =>
2684 New_Occurrence_Of (Stub_Type_Access, Loc),
2686 Make_Attribute_Reference (Loc,
2688 New_Occurrence_Of (Local_Stub, Loc),
2690 Name_Unchecked_Access)));
2692 -- Read the source Partition_ID and RPC_Receiver from incoming stream
2694 Statements := New_List (
2695 Make_Attribute_Reference (Loc,
2697 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
2698 Attribute_Name => Name_Read,
2699 Expressions => New_List (
2701 New_Occurrence_Of (Source_Partition, Loc))),
2703 Make_Attribute_Reference (Loc,
2705 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2708 Expressions => New_List (
2710 New_Occurrence_Of (Source_Receiver, Loc))),
2712 Make_Attribute_Reference (Loc,
2714 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2717 Expressions => New_List (
2719 New_Occurrence_Of (Source_Address, Loc))));
2721 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
2723 Set_Etype (Stubbed_Result, Stub_Type_Access);
2725 -- If the Address is Null_Address, then return a null object
2727 Append_To (Statements,
2728 Make_Implicit_If_Statement (RACW_Type,
2731 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
2732 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
2733 Then_Statements => New_List (
2734 Make_Assignment_Statement (Loc,
2736 Expression => Make_Null (Loc)),
2737 Make_Return_Statement (Loc))));
2739 -- If the RACW denotes an object created on the current partition,
2740 -- Local_Statements will be executed. The real object will be used.
2742 Local_Statements := New_List (
2743 Make_Assignment_Statement (Loc,
2746 Unchecked_Convert_To (RACW_Type,
2747 OK_Convert_To (RTE (RE_Address),
2748 New_Occurrence_Of (Source_Address, Loc)))));
2750 -- If the object is located on another partition, then a stub object
2751 -- will be created with all the information needed to rebuild the
2752 -- real object at the other end.
2754 Remote_Statements := New_List (
2756 Make_Assignment_Statement (Loc,
2757 Name => Make_Selected_Component (Loc,
2758 Prefix => Stubbed_Result,
2759 Selector_Name => Name_Origin),
2761 New_Occurrence_Of (Source_Partition, Loc)),
2763 Make_Assignment_Statement (Loc,
2764 Name => Make_Selected_Component (Loc,
2765 Prefix => Stubbed_Result,
2766 Selector_Name => Name_Receiver),
2768 New_Occurrence_Of (Source_Receiver, Loc)),
2770 Make_Assignment_Statement (Loc,
2771 Name => Make_Selected_Component (Loc,
2772 Prefix => Stubbed_Result,
2773 Selector_Name => Name_Addr),
2775 New_Occurrence_Of (Source_Address, Loc)));
2777 Append_To (Remote_Statements,
2778 Make_Assignment_Statement (Loc,
2779 Name => Make_Selected_Component (Loc,
2780 Prefix => Stubbed_Result,
2781 Selector_Name => Name_Asynchronous),
2783 New_Occurrence_Of (Asynchronous_Flag, Loc)));
2785 Append_List_To (Remote_Statements,
2786 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
2787 -- ??? Issue with asynchronous calls here: the Asynchronous
2788 -- flag is set on the stub type if, and only if, the RACW type
2789 -- has a pragma Asynchronous. This is incorrect for RACWs that
2790 -- implement RAS types, because in that case the /designated
2791 -- subprogram/ (not the type) might be asynchronous, and
2792 -- that causes the stub to need to be asynchronous too.
2793 -- A solution is to transport a RAS as a struct containing
2794 -- a RACW and an asynchronous flag, and to properly alter
2795 -- the Asynchronous component in the stub type in the RAS's
2798 Append_To (Remote_Statements,
2799 Make_Assignment_Statement (Loc,
2801 Expression => Unchecked_Convert_To (RACW_Type,
2802 New_Occurrence_Of (Stubbed_Result, Loc))));
2804 -- Distinguish between the local and remote cases, and execute the
2805 -- appropriate piece of code.
2807 Append_To (Statements,
2808 Make_Implicit_If_Statement (RACW_Type,
2812 Make_Function_Call (Loc,
2813 Name => New_Occurrence_Of (
2814 RTE (RE_Get_Local_Partition_Id), Loc)),
2815 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
2816 Then_Statements => Local_Statements,
2817 Else_Statements => Remote_Statements));
2819 Build_Stream_Procedure
2820 (Loc, RACW_Type, Body_Node,
2821 Make_Defining_Identifier (Loc, Procedure_Name),
2822 Statements, Outp => True);
2823 Set_Declarations (Body_Node, Decls);
2825 Proc_Decl := Make_Subprogram_Declaration (Loc,
2826 Copy_Specification (Loc, Specification (Body_Node)));
2829 Make_Attribute_Definition_Clause (Loc,
2830 Name => New_Occurrence_Of (RACW_Type, Loc),
2834 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
2836 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
2837 Insert_After (Proc_Decl, Attr_Decl);
2838 Append_To (Declarations, Body_Node);
2839 end Add_RACW_Read_Attribute;
2841 ------------------------------
2842 -- Add_RACW_Write_Attribute --
2843 ------------------------------
2845 procedure Add_RACW_Write_Attribute
2846 (RACW_Type : Entity_Id;
2847 Stub_Type : Entity_Id;
2848 Stub_Type_Access : Entity_Id;
2849 RPC_Receiver : Node_Id;
2850 Declarations : List_Id)
2852 Body_Node : Node_Id;
2853 Proc_Decl : Node_Id;
2854 Attr_Decl : Node_Id;
2856 Statements : List_Id;
2857 Local_Statements : List_Id;
2858 Remote_Statements : List_Id;
2859 Null_Statements : List_Id;
2861 Procedure_Name : constant Name_Id := New_Internal_Name ('R
');
2864 -- Build the code fragment corresponding to the marshalling of a
2867 Local_Statements := New_List (
2869 Pack_Entity_Into_Stream_Access (Loc,
2870 Stream => Stream_Parameter,
2871 Object => RTE (RE_Get_Local_Partition_Id)),
2873 Pack_Node_Into_Stream_Access (Loc,
2874 Stream => Stream_Parameter,
2875 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
2876 Etyp => RTE (RE_Unsigned_64)),
2878 Pack_Node_Into_Stream_Access (Loc,
2879 Stream => Stream_Parameter,
2880 Object => OK_Convert_To (RTE (RE_Unsigned_64),
2881 Make_Attribute_Reference (Loc,
2883 Make_Explicit_Dereference (Loc,
2885 Attribute_Name => Name_Address)),
2886 Etyp => RTE (RE_Unsigned_64)));
2888 -- Build the code fragment corresponding to the marshalling of
2891 Remote_Statements := New_List (
2893 Pack_Node_Into_Stream_Access (Loc,
2894 Stream => Stream_Parameter,
2896 Make_Selected_Component (Loc,
2897 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2900 Make_Identifier (Loc, Name_Origin)),
2901 Etyp => RTE (RE_Partition_ID)),
2903 Pack_Node_Into_Stream_Access (Loc,
2904 Stream => Stream_Parameter,
2906 Make_Selected_Component (Loc,
2907 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2910 Make_Identifier (Loc, Name_Receiver)),
2911 Etyp => RTE (RE_Unsigned_64)),
2913 Pack_Node_Into_Stream_Access (Loc,
2914 Stream => Stream_Parameter,
2916 Make_Selected_Component (Loc,
2917 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2920 Make_Identifier (Loc, Name_Addr)),
2921 Etyp => RTE (RE_Unsigned_64)));
2923 -- Build code fragment corresponding to marshalling of a null object
2925 Null_Statements := New_List (
2927 Pack_Entity_Into_Stream_Access (Loc,
2928 Stream => Stream_Parameter,
2929 Object => RTE (RE_Get_Local_Partition_Id)),
2931 Pack_Node_Into_Stream_Access (Loc,
2932 Stream => Stream_Parameter,
2933 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
2934 Etyp => RTE (RE_Unsigned_64)),
2936 Pack_Node_Into_Stream_Access (Loc,
2937 Stream => Stream_Parameter,
2938 Object => Make_Integer_Literal (Loc, Uint_0),
2939 Etyp => RTE (RE_Unsigned_64)));
2941 Statements := New_List (
2942 Make_Implicit_If_Statement (RACW_Type,
2945 Left_Opnd => Object,
2946 Right_Opnd => Make_Null (Loc)),
2947 Then_Statements => Null_Statements,
2948 Elsif_Parts => New_List (
2949 Make_Elsif_Part (Loc,
2953 Make_Attribute_Reference (Loc,
2955 Attribute_Name => Name_Tag),
2957 Make_Attribute_Reference (Loc,
2958 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2959 Attribute_Name => Name_Tag)),
2960 Then_Statements => Remote_Statements)),
2961 Else_Statements => Local_Statements));
2963 Build_Stream_Procedure
2964 (Loc, RACW_Type, Body_Node,
2965 Make_Defining_Identifier (Loc, Procedure_Name),
2966 Statements, Outp => False);
2968 Proc_Decl := Make_Subprogram_Declaration (Loc,
2969 Copy_Specification (Loc, Specification (Body_Node)));
2972 Make_Attribute_Definition_Clause (Loc,
2973 Name => New_Occurrence_Of (RACW_Type, Loc),
2974 Chars => Name_Write,
2977 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
2979 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
2980 Insert_After (Proc_Decl, Attr_Decl);
2981 Append_To (Declarations, Body_Node);
2982 end Add_RACW_Write_Attribute;
2984 ------------------------
2985 -- Add_RAS_Access_TSS --
2986 ------------------------
2988 procedure Add_RAS_Access_TSS (N : Node_Id) is
2989 Loc : constant Source_Ptr := Sloc (N);
2991 Ras_Type : constant Entity_Id := Defining_Identifier (N);
2992 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
2993 -- Ras_Type is the access to subprogram type while Fat_Type is the
2994 -- corresponding record type.
2996 RACW_Type : constant Entity_Id :=
2997 Underlying_RACW_Type (Ras_Type);
2998 Desig : constant Entity_Id :=
2999 Etype (Designated_Type (RACW_Type));
3001 Stub_Elements : constant Stub_Structure :=
3002 Stubs_Table.Get (Desig);
3003 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3005 Proc : constant Entity_Id :=
3006 Make_Defining_Identifier (Loc,
3007 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3009 Proc_Spec : Node_Id;
3011 -- Formal parameters
3013 Package_Name : constant Entity_Id :=
3014 Make_Defining_Identifier (Loc,
3018 Subp_Id : constant Entity_Id :=
3019 Make_Defining_Identifier (Loc,
3021 -- Target subprogram
3023 Asynch_P : constant Entity_Id :=
3024 Make_Defining_Identifier (Loc,
3025 Chars => Name_Asynchronous);
3026 -- Is the procedure to which the 'Access applies asynchronous?
3028 All_Calls_Remote
: constant Entity_Id
:=
3029 Make_Defining_Identifier
(Loc
,
3030 Chars
=> Name_All_Calls_Remote
);
3031 -- True if an All_Calls_Remote pragma applies to the RCI unit
3032 -- that contains the subprogram.
3034 -- Common local variables
3036 Proc_Decls
: List_Id
;
3037 Proc_Statements
: List_Id
;
3039 Origin
: constant Entity_Id
:=
3040 Make_Defining_Identifier
(Loc
,
3041 Chars
=> New_Internal_Name
('P'));
3043 -- Additional local variables for the local case
3045 Proxy_Addr
: constant Entity_Id
:=
3046 Make_Defining_Identifier
(Loc
,
3047 Chars
=> New_Internal_Name
('P'));
3049 -- Additional local variables for the remote case
3051 Local_Stub
: constant Entity_Id
:=
3052 Make_Defining_Identifier
(Loc
,
3053 Chars
=> New_Internal_Name
('L'));
3055 Stub_Ptr
: constant Entity_Id
:=
3056 Make_Defining_Identifier
(Loc
,
3057 Chars
=> New_Internal_Name
('S'));
3060 (Field_Name
: Name_Id
;
3061 Value
: Node_Id
) return Node_Id
;
3062 -- Construct an assignment that sets the named component in the
3070 (Field_Name
: Name_Id
;
3071 Value
: Node_Id
) return Node_Id
3075 Make_Assignment_Statement
(Loc
,
3077 Make_Selected_Component
(Loc
,
3079 Selector_Name
=> Field_Name
),
3080 Expression
=> Value
);
3083 -- Start of processing for Add_RAS_Access_TSS
3086 Proc_Decls
:= New_List
(
3088 -- Common declarations
3090 Make_Object_Declaration
(Loc
,
3091 Defining_Identifier
=> Origin
,
3092 Constant_Present
=> True,
3093 Object_Definition
=>
3094 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3096 Make_Function_Call
(Loc
,
3098 New_Occurrence_Of
(RTE
(RE_Get_Active_Partition_Id
), Loc
),
3099 Parameter_Associations
=> New_List
(
3100 New_Occurrence_Of
(Package_Name
, Loc
)))),
3102 -- Declaration use only in the local case: proxy address
3104 Make_Object_Declaration
(Loc
,
3105 Defining_Identifier
=> Proxy_Addr
,
3106 Object_Definition
=>
3107 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3109 -- Declarations used only in the remote case: stub object and
3112 Make_Object_Declaration
(Loc
,
3113 Defining_Identifier
=> Local_Stub
,
3114 Aliased_Present
=> True,
3115 Object_Definition
=>
3116 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
3118 Make_Object_Declaration
(Loc
,
3119 Defining_Identifier
=>
3121 Object_Definition
=>
3122 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
3124 Make_Attribute_Reference
(Loc
,
3125 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
3126 Attribute_Name
=> Name_Unchecked_Access
)));
3128 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
3129 -- Build_Get_Unique_RP_Call needs this information
3131 -- Note: Here we assume that the Fat_Type is a record
3132 -- containing just a pointer to a proxy or stub object.
3134 Proc_Statements
:= New_List
(
3138 -- Get_RAS_Info (Pkg, Subp, PA);
3139 -- if Origin = Local_Partition_Id
3140 -- and then not All_Calls_Remote
3142 -- return Fat_Type!(PA);
3145 Make_Procedure_Call_Statement
(Loc
,
3147 New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
3148 Parameter_Associations
=> New_List
(
3149 New_Occurrence_Of
(Package_Name
, Loc
),
3150 New_Occurrence_Of
(Subp_Id
, Loc
),
3151 New_Occurrence_Of
(Proxy_Addr
, Loc
))),
3153 Make_Implicit_If_Statement
(N
,
3159 New_Occurrence_Of
(Origin
, Loc
),
3161 Make_Function_Call
(Loc
,
3163 RTE
(RE_Get_Local_Partition_Id
), Loc
))),
3166 New_Occurrence_Of
(All_Calls_Remote
, Loc
))),
3167 Then_Statements
=> New_List
(
3168 Make_Return_Statement
(Loc
,
3169 Unchecked_Convert_To
(Fat_Type
,
3170 OK_Convert_To
(RTE
(RE_Address
),
3171 New_Occurrence_Of
(Proxy_Addr
, Loc
)))))),
3173 Set_Field
(Name_Origin
,
3174 New_Occurrence_Of
(Origin
, Loc
)),
3176 Set_Field
(Name_Receiver
,
3177 Make_Function_Call
(Loc
,
3179 New_Occurrence_Of
(RTE
(RE_Get_RCI_Package_Receiver
), Loc
),
3180 Parameter_Associations
=> New_List
(
3181 New_Occurrence_Of
(Package_Name
, Loc
)))),
3183 Set_Field
(Name_Addr
, New_Occurrence_Of
(Proxy_Addr
, Loc
)),
3185 -- E.4.1(9) A remote call is asynchronous if it is a call to
3186 -- a procedure, or a call through a value of an access-to-procedure
3187 -- type, to which a pragma Asynchronous applies.
3189 -- Parameter Asynch_P is true when the procedure is asynchronous;
3190 -- Expression Asynch_T is true when the type is asynchronous.
3192 Set_Field
(Name_Asynchronous
,
3194 New_Occurrence_Of
(Asynch_P
, Loc
),
3195 New_Occurrence_Of
(Boolean_Literals
(
3196 Is_Asynchronous
(Ras_Type
)), Loc
))));
3198 Append_List_To
(Proc_Statements
,
3199 Build_Get_Unique_RP_Call
3200 (Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
3202 -- Return the newly created value
3204 Append_To
(Proc_Statements
,
3205 Make_Return_Statement
(Loc
,
3207 Unchecked_Convert_To
(Fat_Type
,
3208 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
3211 Make_Function_Specification
(Loc
,
3212 Defining_Unit_Name
=> Proc
,
3213 Parameter_Specifications
=> New_List
(
3214 Make_Parameter_Specification
(Loc
,
3215 Defining_Identifier
=> Package_Name
,
3217 New_Occurrence_Of
(Standard_String
, Loc
)),
3219 Make_Parameter_Specification
(Loc
,
3220 Defining_Identifier
=> Subp_Id
,
3222 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
)),
3224 Make_Parameter_Specification
(Loc
,
3225 Defining_Identifier
=> Asynch_P
,
3227 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3229 Make_Parameter_Specification
(Loc
,
3230 Defining_Identifier
=> All_Calls_Remote
,
3232 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
3234 Result_Definition
=>
3235 New_Occurrence_Of
(Fat_Type
, Loc
));
3237 -- Set the kind and return type of the function to prevent
3238 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3240 Set_Ekind
(Proc
, E_Function
);
3241 Set_Etype
(Proc
, Fat_Type
);
3244 Make_Subprogram_Body
(Loc
,
3245 Specification
=> Proc_Spec
,
3246 Declarations
=> Proc_Decls
,
3247 Handled_Statement_Sequence
=>
3248 Make_Handled_Sequence_Of_Statements
(Loc
,
3249 Statements
=> Proc_Statements
)));
3251 Set_TSS
(Fat_Type
, Proc
);
3252 end Add_RAS_Access_TSS
;
3254 -----------------------
3255 -- Add_RAST_Features --
3256 -----------------------
3258 procedure Add_RAST_Features
3259 (Vis_Decl
: Node_Id
;
3260 RAS_Type
: Entity_Id
)
3262 pragma Warnings
(Off
);
3263 pragma Unreferenced
(RAS_Type
);
3264 pragma Warnings
(On
);
3266 Add_RAS_Access_TSS
(Vis_Decl
);
3267 end Add_RAST_Features
;
3269 -----------------------------------------
3270 -- Add_Receiving_Stubs_To_Declarations --
3271 -----------------------------------------
3273 procedure Add_Receiving_Stubs_To_Declarations
3274 (Pkg_Spec
: Node_Id
;
3277 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
3279 Request_Parameter
: Node_Id
;
3281 Pkg_RPC_Receiver
: constant Entity_Id
:=
3282 Make_Defining_Identifier
(Loc
,
3283 New_Internal_Name
('H'));
3284 Pkg_RPC_Receiver_Statements
: List_Id
;
3285 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
3286 Pkg_RPC_Receiver_Body
: Node_Id
;
3287 -- A Pkg_RPC_Receiver is built to decode the request
3289 Lookup_RAS_Info
: constant Entity_Id
:=
3290 Make_Defining_Identifier
(Loc
,
3291 Chars
=> New_Internal_Name
('R'));
3292 -- A remote subprogram is created to allow peers to look up
3293 -- RAS information using subprogram ids.
3295 Subp_Id
: Entity_Id
;
3296 Subp_Index
: Entity_Id
;
3297 -- Subprogram_Id as read from the incoming stream
3299 Current_Declaration
: Node_Id
;
3300 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
3301 Current_Stubs
: Node_Id
;
3303 Subp_Info_Array
: constant Entity_Id
:=
3304 Make_Defining_Identifier
(Loc
,
3305 Chars
=> New_Internal_Name
('I'));
3307 Subp_Info_List
: constant List_Id
:= New_List
;
3309 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
3311 All_Calls_Remote_E
: Entity_Id
;
3312 Proxy_Object_Addr
: Entity_Id
;
3314 procedure Append_Stubs_To
3315 (RPC_Receiver_Cases
: List_Id
;
3317 Subprogram_Number
: Int
);
3318 -- Add one case to the specified RPC receiver case list
3319 -- associating Subprogram_Number with the subprogram declared
3320 -- by Declaration, for which we have receiving stubs in Stubs.
3322 ---------------------
3323 -- Append_Stubs_To --
3324 ---------------------
3326 procedure Append_Stubs_To
3327 (RPC_Receiver_Cases
: List_Id
;
3329 Subprogram_Number
: Int
)
3332 Append_To
(RPC_Receiver_Cases
,
3333 Make_Case_Statement_Alternative
(Loc
,
3335 New_List
(Make_Integer_Literal
(Loc
, Subprogram_Number
)),
3338 Make_Procedure_Call_Statement
(Loc
,
3341 Defining_Entity
(Stubs
), Loc
),
3342 Parameter_Associations
=> New_List
(
3343 New_Occurrence_Of
(Request_Parameter
, Loc
))))));
3344 end Append_Stubs_To
;
3346 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3349 -- Building receiving stubs consist in several operations:
3351 -- - a package RPC receiver must be built. This subprogram
3352 -- will get a Subprogram_Id from the incoming stream
3353 -- and will dispatch the call to the right subprogram
3355 -- - a receiving stub for any subprogram visible in the package
3356 -- spec. This stub will read all the parameters from the stream,
3357 -- and put the result as well as the exception occurrence in the
3360 -- - a dummy package with an empty spec and a body made of an
3361 -- elaboration part, whose job is to register the receiving
3362 -- part of this RCI package on the name server. This is done
3363 -- by calling System.Partition_Interface.Register_Receiving_Stub
3365 Build_RPC_Receiver_Body
(
3366 RPC_Receiver
=> Pkg_RPC_Receiver
,
3367 Request
=> Request_Parameter
,
3369 Subp_Index
=> Subp_Index
,
3370 Stmts
=> Pkg_RPC_Receiver_Statements
,
3371 Decl
=> Pkg_RPC_Receiver_Body
);
3372 pragma Assert
(Subp_Id
= Subp_Index
);
3374 -- A null subp_id denotes a call through a RAS, in which case the
3375 -- next Uint_64 element in the stream is the address of the local
3376 -- proxy object, from which we can retrieve the actual subprogram id.
3378 Append_To
(Pkg_RPC_Receiver_Statements
,
3379 Make_Implicit_If_Statement
(Pkg_Spec
,
3382 New_Occurrence_Of
(Subp_Id
, Loc
),
3383 Make_Integer_Literal
(Loc
, 0)),
3384 Then_Statements
=> New_List
(
3385 Make_Assignment_Statement
(Loc
,
3387 New_Occurrence_Of
(Subp_Id
, Loc
),
3389 Make_Selected_Component
(Loc
,
3391 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
3392 OK_Convert_To
(RTE
(RE_Address
),
3393 Make_Attribute_Reference
(Loc
,
3395 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3398 Expressions
=> New_List
(
3399 Make_Selected_Component
(Loc
,
3400 Prefix
=> Request_Parameter
,
3401 Selector_Name
=> Name_Params
))))),
3403 Make_Identifier
(Loc
, Name_Subp_Id
))))));
3405 -- Build a subprogram for RAS information lookups
3407 Current_Declaration
:=
3408 Make_Subprogram_Declaration
(Loc
,
3410 Make_Function_Specification
(Loc
,
3411 Defining_Unit_Name
=>
3413 Parameter_Specifications
=> New_List
(
3414 Make_Parameter_Specification
(Loc
,
3415 Defining_Identifier
=>
3416 Make_Defining_Identifier
(Loc
, Name_Subp_Id
),
3420 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))),
3421 Result_Definition
=>
3422 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)));
3423 Append_To
(Decls
, Current_Declaration
);
3424 Analyze
(Current_Declaration
);
3426 Current_Stubs
:= Build_Subprogram_Receiving_Stubs
3427 (Vis_Decl
=> Current_Declaration
,
3428 Asynchronous
=> False);
3429 Append_To
(Decls
, Current_Stubs
);
3430 Analyze
(Current_Stubs
);
3432 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3435 Subprogram_Number
=> 1);
3437 -- For each subprogram, the receiving stub will be built and a
3438 -- case statement will be made on the Subprogram_Id to dispatch
3439 -- to the right subprogram.
3441 All_Calls_Remote_E
:= Boolean_Literals
(
3442 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
3444 Overload_Counter_Table
.Reset
;
3446 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
3447 while Present
(Current_Declaration
) loop
3448 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
3449 and then Comes_From_Source
(Current_Declaration
)
3452 Loc
: constant Source_Ptr
:=
3453 Sloc
(Current_Declaration
);
3454 -- While specifically processing Current_Declaration, use
3455 -- its Sloc as the location of all generated nodes.
3457 Subp_Def
: constant Entity_Id
:=
3459 (Specification
(Current_Declaration
));
3461 Subp_Val
: String_Id
;
3464 pragma Assert
(Current_Subprogram_Number
=
3465 Get_Subprogram_Id
(Subp_Def
));
3467 -- Build receiving stub
3470 Build_Subprogram_Receiving_Stubs
3471 (Vis_Decl
=> Current_Declaration
,
3473 Nkind
(Specification
(Current_Declaration
)) =
3474 N_Procedure_Specification
3475 and then Is_Asynchronous
(Subp_Def
));
3477 Append_To
(Decls
, Current_Stubs
);
3478 Analyze
(Current_Stubs
);
3482 Add_RAS_Proxy_And_Analyze
(Decls
,
3484 Current_Declaration
,
3485 All_Calls_Remote_E
=>
3487 Proxy_Object_Addr
=>
3490 -- Compute distribution identifier
3492 Assign_Subprogram_Identifier
(
3494 Current_Subprogram_Number
,
3497 -- Add subprogram descriptor (RCI_Subp_Info) to the
3498 -- subprograms table for this receiver. The aggregate
3499 -- below must be kept consistent with the declaration
3500 -- of type RCI_Subp_Info in System.Partition_Interface.
3502 Append_To
(Subp_Info_List
,
3503 Make_Component_Association
(Loc
,
3504 Choices
=> New_List
(
3505 Make_Integer_Literal
(Loc
,
3506 Current_Subprogram_Number
)),
3508 Make_Aggregate
(Loc
,
3509 Component_Associations
=> New_List
(
3510 Make_Component_Association
(Loc
,
3511 Choices
=> New_List
(
3512 Make_Identifier
(Loc
, Name_Addr
)),
3515 Proxy_Object_Addr
, Loc
))))));
3517 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3520 Subprogram_Number
=>
3521 Current_Subprogram_Number
);
3524 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
3527 Next
(Current_Declaration
);
3530 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3531 -- rather than raising an exception since we do not want someone
3532 -- to crash a remote partition by sending invalid subprogram ids.
3533 -- This is consistent with the other parts of the case statement
3534 -- since even in presence of incorrect parameters in the stream,
3535 -- every exception will be caught and (if the subprogram is not an
3536 -- APC) put into the result stream and sent away.
3538 Append_To
(Pkg_RPC_Receiver_Cases
,
3539 Make_Case_Statement_Alternative
(Loc
,
3541 New_List
(Make_Others_Choice
(Loc
)),
3543 New_List
(Make_Null_Statement
(Loc
))));
3545 Append_To
(Pkg_RPC_Receiver_Statements
,
3546 Make_Case_Statement
(Loc
,
3548 New_Occurrence_Of
(Subp_Id
, Loc
),
3549 Alternatives
=> Pkg_RPC_Receiver_Cases
));
3552 Make_Object_Declaration
(Loc
,
3553 Defining_Identifier
=> Subp_Info_Array
,
3554 Constant_Present
=> True,
3555 Aliased_Present
=> True,
3556 Object_Definition
=>
3557 Make_Subtype_Indication
(Loc
,
3559 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
3561 Make_Index_Or_Discriminant_Constraint
(Loc
,
3564 Low_Bound
=> Make_Integer_Literal
(Loc
,
3565 First_RCI_Subprogram_Id
),
3567 Make_Integer_Literal
(Loc
,
3568 First_RCI_Subprogram_Id
3569 + List_Length
(Subp_Info_List
) - 1))))),
3571 Make_Aggregate
(Loc
,
3572 Component_Associations
=> Subp_Info_List
)));
3573 Analyze
(Last
(Decls
));
3576 Make_Subprogram_Body
(Loc
,
3578 Copy_Specification
(Loc
, Parent
(Lookup_RAS_Info
)),
3581 Handled_Statement_Sequence
=>
3582 Make_Handled_Sequence_Of_Statements
(Loc
,
3583 Statements
=> New_List
(
3584 Make_Return_Statement
(Loc
,
3585 Expression
=> OK_Convert_To
(RTE
(RE_Unsigned_64
),
3586 Make_Selected_Component
(Loc
,
3588 Make_Indexed_Component
(Loc
,
3590 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3591 Expressions
=> New_List
(
3592 Convert_To
(Standard_Integer
,
3593 Make_Identifier
(Loc
, Name_Subp_Id
)))),
3595 Make_Identifier
(Loc
, Name_Addr
))))))));
3596 Analyze
(Last
(Decls
));
3598 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
3599 Analyze
(Last
(Decls
));
3601 Get_Library_Unit_Name_String
(Pkg_Spec
);
3602 Append_To
(Register_Pkg_Actuals
,
3604 Make_String_Literal
(Loc
,
3605 Strval
=> String_From_Name_Buffer
));
3607 Append_To
(Register_Pkg_Actuals
,
3609 Make_Attribute_Reference
(Loc
,
3611 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
3613 Name_Unrestricted_Access
));
3615 Append_To
(Register_Pkg_Actuals
,
3617 Make_Attribute_Reference
(Loc
,
3619 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
3623 Append_To
(Register_Pkg_Actuals
,
3625 Make_Attribute_Reference
(Loc
,
3627 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3631 Append_To
(Register_Pkg_Actuals
,
3633 Make_Attribute_Reference
(Loc
,
3635 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3640 Make_Procedure_Call_Statement
(Loc
,
3642 New_Occurrence_Of
(RTE
(RE_Register_Receiving_Stub
), Loc
),
3643 Parameter_Associations
=> Register_Pkg_Actuals
));
3644 Analyze
(Last
(Decls
));
3645 end Add_Receiving_Stubs_To_Declarations
;
3647 ---------------------------------
3648 -- Build_General_Calling_Stubs --
3649 ---------------------------------
3651 procedure Build_General_Calling_Stubs
3653 Statements
: List_Id
;
3654 Target_Partition
: Entity_Id
;
3655 Target_RPC_Receiver
: Node_Id
;
3656 Subprogram_Id
: Node_Id
;
3657 Asynchronous
: Node_Id
:= Empty
;
3658 Is_Known_Asynchronous
: Boolean := False;
3659 Is_Known_Non_Asynchronous
: Boolean := False;
3660 Is_Function
: Boolean;
3662 Stub_Type
: Entity_Id
:= Empty
;
3663 RACW_Type
: Entity_Id
:= Empty
;
3666 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
3668 Stream_Parameter
: Node_Id
;
3669 -- Name of the stream used to transmit parameters to the
3672 Result_Parameter
: Node_Id
;
3673 -- Name of the result parameter (in non-APC cases) which get the
3674 -- result of the remote subprogram.
3676 Exception_Return_Parameter
: Node_Id
;
3677 -- Name of the parameter which will hold the exception sent by the
3678 -- remote subprogram.
3680 Current_Parameter
: Node_Id
;
3681 -- Current parameter being handled
3683 Ordered_Parameters_List
: constant List_Id
:=
3684 Build_Ordered_Parameters_List
(Spec
);
3686 Asynchronous_Statements
: List_Id
:= No_List
;
3687 Non_Asynchronous_Statements
: List_Id
:= No_List
;
3688 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
3690 Extra_Formal_Statements
: constant List_Id
:= New_List
;
3691 -- List of statements for extra formal parameters. It will appear
3692 -- after the regular statements for writing out parameters.
3694 pragma Warnings
(Off
);
3695 pragma Unreferenced
(RACW_Type
);
3696 -- Used only for the PolyORB case
3697 pragma Warnings
(On
);
3700 -- The general form of a calling stub for a given subprogram is:
3702 -- procedure X (...) is P : constant Partition_ID :=
3703 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
3704 -- System.RPC.Params_Stream_Type (0); begin
3705 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
3706 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
3707 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
3708 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
3710 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
3712 -- There are some variations: Do_APC is called for an asynchronous
3713 -- procedure and the part after the call is completely ommitted as
3714 -- well as the declaration of Result. For a function call, 'Input is
3715 -- always used to read the result even if it is constrained.
3718 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
3721 Make_Object_Declaration
(Loc
,
3722 Defining_Identifier
=> Stream_Parameter
,
3723 Aliased_Present
=> True,
3724 Object_Definition
=>
3725 Make_Subtype_Indication
(Loc
,
3727 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
3729 Make_Index_Or_Discriminant_Constraint
(Loc
,
3731 New_List
(Make_Integer_Literal
(Loc
, 0))))));
3733 if not Is_Known_Asynchronous
then
3735 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
3738 Make_Object_Declaration
(Loc
,
3739 Defining_Identifier
=> Result_Parameter
,
3740 Aliased_Present
=> True,
3741 Object_Definition
=>
3742 Make_Subtype_Indication
(Loc
,
3744 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
3746 Make_Index_Or_Discriminant_Constraint
(Loc
,
3748 New_List
(Make_Integer_Literal
(Loc
, 0))))));
3750 Exception_Return_Parameter
:=
3751 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
3754 Make_Object_Declaration
(Loc
,
3755 Defining_Identifier
=> Exception_Return_Parameter
,
3756 Object_Definition
=>
3757 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
3760 Result_Parameter
:= Empty
;
3761 Exception_Return_Parameter
:= Empty
;
3764 -- Put first the RPC receiver corresponding to the remote package
3766 Append_To
(Statements
,
3767 Make_Attribute_Reference
(Loc
,
3769 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3770 Attribute_Name
=> Name_Write
,
3771 Expressions
=> New_List
(
3772 Make_Attribute_Reference
(Loc
,
3774 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3777 Target_RPC_Receiver
)));
3779 -- Then put the Subprogram_Id of the subprogram we want to call in
3782 Append_To
(Statements
,
3783 Make_Attribute_Reference
(Loc
,
3785 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
3788 Expressions
=> New_List
(
3789 Make_Attribute_Reference
(Loc
,
3791 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3792 Attribute_Name
=> Name_Access
),
3795 Current_Parameter
:= First
(Ordered_Parameters_List
);
3796 while Present
(Current_Parameter
) loop
3798 Typ
: constant Node_Id
:=
3799 Parameter_Type
(Current_Parameter
);
3801 Constrained
: Boolean;
3803 Extra_Parameter
: Entity_Id
;
3806 if Is_RACW_Controlling_Formal
3807 (Current_Parameter
, Stub_Type
)
3809 -- In the case of a controlling formal argument, we marshall
3810 -- its addr field rather than the local stub.
3812 Append_To
(Statements
,
3813 Pack_Node_Into_Stream
(Loc
,
3814 Stream
=> Stream_Parameter
,
3816 Make_Selected_Component
(Loc
,
3818 Defining_Identifier
(Current_Parameter
),
3819 Selector_Name
=> Name_Addr
),
3820 Etyp
=> RTE
(RE_Unsigned_64
)));
3823 Value
:= New_Occurrence_Of
3824 (Defining_Identifier
(Current_Parameter
), Loc
);
3826 -- Access type parameters are transmitted as in out
3827 -- parameters. However, a dereference is needed so that
3828 -- we marshall the designated object.
3830 if Nkind
(Typ
) = N_Access_Definition
then
3831 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
3832 Etyp
:= Etype
(Subtype_Mark
(Typ
));
3834 Etyp
:= Etype
(Typ
);
3838 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
3840 -- Any parameter but unconstrained out parameters are
3841 -- transmitted to the peer.
3843 if In_Present
(Current_Parameter
)
3844 or else not Out_Present
(Current_Parameter
)
3845 or else not Constrained
3847 Append_To
(Statements
,
3848 Make_Attribute_Reference
(Loc
,
3850 New_Occurrence_Of
(Etyp
, Loc
),
3852 Output_From_Constrained
(Constrained
),
3853 Expressions
=> New_List
(
3854 Make_Attribute_Reference
(Loc
,
3856 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3857 Attribute_Name
=> Name_Access
),
3862 -- If the current parameter has a dynamic constrained status,
3863 -- then this status is transmitted as well.
3864 -- This should be done for accessibility as well ???
3866 if Nkind
(Typ
) /= N_Access_Definition
3867 and then Need_Extra_Constrained
(Current_Parameter
)
3869 -- In this block, we do not use the extra formal that has
3870 -- been created because it does not exist at the time of
3871 -- expansion when building calling stubs for remote access
3872 -- to subprogram types. We create an extra variable of this
3873 -- type and push it in the stream after the regular
3876 Extra_Parameter
:= Make_Defining_Identifier
3877 (Loc
, New_Internal_Name
('P'));
3880 Make_Object_Declaration
(Loc
,
3881 Defining_Identifier
=> Extra_Parameter
,
3882 Constant_Present
=> True,
3883 Object_Definition
=>
3884 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3886 Make_Attribute_Reference
(Loc
,
3889 Defining_Identifier
(Current_Parameter
), Loc
),
3890 Attribute_Name
=> Name_Constrained
)));
3892 Append_To
(Extra_Formal_Statements
,
3893 Make_Attribute_Reference
(Loc
,
3895 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3898 Expressions
=> New_List
(
3899 Make_Attribute_Reference
(Loc
,
3901 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3904 New_Occurrence_Of
(Extra_Parameter
, Loc
))));
3907 Next
(Current_Parameter
);
3911 -- Append the formal statements list to the statements
3913 Append_List_To
(Statements
, Extra_Formal_Statements
);
3915 if not Is_Known_Non_Asynchronous
then
3917 -- Build the call to System.RPC.Do_APC
3919 Asynchronous_Statements
:= New_List
(
3920 Make_Procedure_Call_Statement
(Loc
,
3922 New_Occurrence_Of
(RTE
(RE_Do_Apc
), Loc
),
3923 Parameter_Associations
=> New_List
(
3924 New_Occurrence_Of
(Target_Partition
, Loc
),
3925 Make_Attribute_Reference
(Loc
,
3927 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3931 Asynchronous_Statements
:= No_List
;
3934 if not Is_Known_Asynchronous
then
3936 -- Build the call to System.RPC.Do_RPC
3938 Non_Asynchronous_Statements
:= New_List
(
3939 Make_Procedure_Call_Statement
(Loc
,
3941 New_Occurrence_Of
(RTE
(RE_Do_Rpc
), Loc
),
3942 Parameter_Associations
=> New_List
(
3943 New_Occurrence_Of
(Target_Partition
, Loc
),
3945 Make_Attribute_Reference
(Loc
,
3947 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3951 Make_Attribute_Reference
(Loc
,
3953 New_Occurrence_Of
(Result_Parameter
, Loc
),
3957 -- Read the exception occurrence from the result stream and
3958 -- reraise it. It does no harm if this is a Null_Occurrence since
3959 -- this does nothing.
3961 Append_To
(Non_Asynchronous_Statements
,
3962 Make_Attribute_Reference
(Loc
,
3964 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
3969 Expressions
=> New_List
(
3970 Make_Attribute_Reference
(Loc
,
3972 New_Occurrence_Of
(Result_Parameter
, Loc
),
3975 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
3977 Append_To
(Non_Asynchronous_Statements
,
3978 Make_Procedure_Call_Statement
(Loc
,
3980 New_Occurrence_Of
(RTE
(RE_Reraise_Occurrence
), Loc
),
3981 Parameter_Associations
=> New_List
(
3982 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
3986 -- If this is a function call, then read the value and return
3987 -- it. The return value is written/read using 'Output/'Input.
3989 Append_To
(Non_Asynchronous_Statements
,
3990 Make_Tag_Check
(Loc
,
3991 Make_Return_Statement
(Loc
,
3993 Make_Attribute_Reference
(Loc
,
3996 Etype
(Result_Definition
(Spec
)), Loc
),
3998 Attribute_Name
=> Name_Input
,
4000 Expressions
=> New_List
(
4001 Make_Attribute_Reference
(Loc
,
4003 New_Occurrence_Of
(Result_Parameter
, Loc
),
4004 Attribute_Name
=> Name_Access
))))));
4007 -- Loop around parameters and assign out (or in out)
4008 -- parameters. In the case of RACW, controlling arguments
4009 -- cannot possibly have changed since they are remote, so we do
4010 -- not read them from the stream.
4012 Current_Parameter
:= First
(Ordered_Parameters_List
);
4013 while Present
(Current_Parameter
) loop
4015 Typ
: constant Node_Id
:=
4016 Parameter_Type
(Current_Parameter
);
4023 (Defining_Identifier
(Current_Parameter
), Loc
);
4025 if Nkind
(Typ
) = N_Access_Definition
then
4026 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4027 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4029 Etyp
:= Etype
(Typ
);
4032 if (Out_Present
(Current_Parameter
)
4033 or else Nkind
(Typ
) = N_Access_Definition
)
4034 and then Etyp
/= Stub_Type
4036 Append_To
(Non_Asynchronous_Statements
,
4037 Make_Attribute_Reference
(Loc
,
4039 New_Occurrence_Of
(Etyp
, Loc
),
4041 Attribute_Name
=> Name_Read
,
4043 Expressions
=> New_List
(
4044 Make_Attribute_Reference
(Loc
,
4046 New_Occurrence_Of
(Result_Parameter
, Loc
),
4053 Next
(Current_Parameter
);
4058 if Is_Known_Asynchronous
then
4059 Append_List_To
(Statements
, Asynchronous_Statements
);
4061 elsif Is_Known_Non_Asynchronous
then
4062 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
4065 pragma Assert
(Present
(Asynchronous
));
4066 Prepend_To
(Asynchronous_Statements
,
4067 Make_Attribute_Reference
(Loc
,
4068 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4069 Attribute_Name
=> Name_Write
,
4070 Expressions
=> New_List
(
4071 Make_Attribute_Reference
(Loc
,
4073 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4074 Attribute_Name
=> Name_Access
),
4075 New_Occurrence_Of
(Standard_True
, Loc
))));
4077 Prepend_To
(Non_Asynchronous_Statements
,
4078 Make_Attribute_Reference
(Loc
,
4079 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4080 Attribute_Name
=> Name_Write
,
4081 Expressions
=> New_List
(
4082 Make_Attribute_Reference
(Loc
,
4084 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4085 Attribute_Name
=> Name_Access
),
4086 New_Occurrence_Of
(Standard_False
, Loc
))));
4088 Append_To
(Statements
,
4089 Make_Implicit_If_Statement
(Nod
,
4090 Condition
=> Asynchronous
,
4091 Then_Statements
=> Asynchronous_Statements
,
4092 Else_Statements
=> Non_Asynchronous_Statements
));
4094 end Build_General_Calling_Stubs
;
4096 -----------------------------
4097 -- Build_RPC_Receiver_Body --
4098 -----------------------------
4100 procedure Build_RPC_Receiver_Body
4101 (RPC_Receiver
: Entity_Id
;
4102 Request
: out Entity_Id
;
4103 Subp_Id
: out Entity_Id
;
4104 Subp_Index
: out Entity_Id
;
4105 Stmts
: out List_Id
;
4108 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
4110 RPC_Receiver_Spec
: Node_Id
;
4111 RPC_Receiver_Decls
: List_Id
;
4114 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
4116 RPC_Receiver_Spec
:=
4117 Build_RPC_Receiver_Specification
4118 (RPC_Receiver
=> RPC_Receiver
,
4119 Request_Parameter
=> Request
);
4121 Subp_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4122 Subp_Index
:= Subp_Id
;
4124 -- Subp_Id may not be a constant, because in the case of the RPC
4125 -- receiver for an RCI package, when a call is received from a RAS
4126 -- dereference, it will be assigned during subsequent processing.
4128 RPC_Receiver_Decls
:= New_List
(
4129 Make_Object_Declaration
(Loc
,
4130 Defining_Identifier
=> Subp_Id
,
4131 Object_Definition
=>
4132 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4134 Make_Attribute_Reference
(Loc
,
4136 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4137 Attribute_Name
=> Name_Input
,
4138 Expressions
=> New_List
(
4139 Make_Selected_Component
(Loc
,
4141 Selector_Name
=> Name_Params
)))));
4146 Make_Subprogram_Body
(Loc
,
4147 Specification
=> RPC_Receiver_Spec
,
4148 Declarations
=> RPC_Receiver_Decls
,
4149 Handled_Statement_Sequence
=>
4150 Make_Handled_Sequence_Of_Statements
(Loc
,
4151 Statements
=> Stmts
));
4152 end Build_RPC_Receiver_Body
;
4154 -----------------------
4155 -- Build_Stub_Target --
4156 -----------------------
4158 function Build_Stub_Target
4161 RCI_Locator
: Entity_Id
;
4162 Controlling_Parameter
: Entity_Id
) return RPC_Target
4164 Target_Info
: RPC_Target
(PCS_Kind
=> Name_GARLIC_DSA
);
4166 Target_Info
.Partition
:=
4167 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4168 if Present
(Controlling_Parameter
) then
4170 Make_Object_Declaration
(Loc
,
4171 Defining_Identifier
=> Target_Info
.Partition
,
4172 Constant_Present
=> True,
4173 Object_Definition
=>
4174 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4177 Make_Selected_Component
(Loc
,
4178 Prefix
=> Controlling_Parameter
,
4179 Selector_Name
=> Name_Origin
)));
4181 Target_Info
.RPC_Receiver
:=
4182 Make_Selected_Component
(Loc
,
4183 Prefix
=> Controlling_Parameter
,
4184 Selector_Name
=> Name_Receiver
);
4188 Make_Object_Declaration
(Loc
,
4189 Defining_Identifier
=> Target_Info
.Partition
,
4190 Constant_Present
=> True,
4191 Object_Definition
=>
4192 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4195 Make_Function_Call
(Loc
,
4196 Name
=> Make_Selected_Component
(Loc
,
4198 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4200 Make_Identifier
(Loc
,
4201 Name_Get_Active_Partition_ID
)))));
4203 Target_Info
.RPC_Receiver
:=
4204 Make_Selected_Component
(Loc
,
4206 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4208 Make_Identifier
(Loc
, Name_Get_RCI_Package_Receiver
));
4211 end Build_Stub_Target
;
4213 ---------------------
4214 -- Build_Stub_Type --
4215 ---------------------
4217 procedure Build_Stub_Type
4218 (RACW_Type
: Entity_Id
;
4219 Stub_Type
: Entity_Id
;
4220 Stub_Type_Decl
: out Node_Id
;
4221 RPC_Receiver_Decl
: out Node_Id
)
4223 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
4224 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
4228 Make_Full_Type_Declaration
(Loc
,
4229 Defining_Identifier
=> Stub_Type
,
4231 Make_Record_Definition
(Loc
,
4232 Tagged_Present
=> True,
4233 Limited_Present
=> True,
4235 Make_Component_List
(Loc
,
4236 Component_Items
=> New_List
(
4238 Make_Component_Declaration
(Loc
,
4239 Defining_Identifier
=>
4240 Make_Defining_Identifier
(Loc
, Name_Origin
),
4241 Component_Definition
=>
4242 Make_Component_Definition
(Loc
,
4243 Aliased_Present
=> False,
4244 Subtype_Indication
=>
4246 RTE
(RE_Partition_ID
), Loc
))),
4248 Make_Component_Declaration
(Loc
,
4249 Defining_Identifier
=>
4250 Make_Defining_Identifier
(Loc
, Name_Receiver
),
4251 Component_Definition
=>
4252 Make_Component_Definition
(Loc
,
4253 Aliased_Present
=> False,
4254 Subtype_Indication
=>
4255 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4257 Make_Component_Declaration
(Loc
,
4258 Defining_Identifier
=>
4259 Make_Defining_Identifier
(Loc
, Name_Addr
),
4260 Component_Definition
=>
4261 Make_Component_Definition
(Loc
,
4262 Aliased_Present
=> False,
4263 Subtype_Indication
=>
4264 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4266 Make_Component_Declaration
(Loc
,
4267 Defining_Identifier
=>
4268 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
4269 Component_Definition
=>
4270 Make_Component_Definition
(Loc
,
4271 Aliased_Present
=> False,
4272 Subtype_Indication
=>
4274 Standard_Boolean
, Loc
)))))));
4277 RPC_Receiver_Decl
:= Empty
;
4280 RPC_Receiver_Request
: constant Entity_Id
:=
4281 Make_Defining_Identifier
(Loc
, Name_R
);
4283 RPC_Receiver_Decl
:=
4284 Make_Subprogram_Declaration
(Loc
,
4285 Build_RPC_Receiver_Specification
(
4286 RPC_Receiver
=> Make_Defining_Identifier
(Loc
,
4287 New_Internal_Name
('R')),
4288 Request_Parameter
=> RPC_Receiver_Request
));
4291 end Build_Stub_Type
;
4293 --------------------------------------
4294 -- Build_Subprogram_Receiving_Stubs --
4295 --------------------------------------
4297 function Build_Subprogram_Receiving_Stubs
4298 (Vis_Decl
: Node_Id
;
4299 Asynchronous
: Boolean;
4300 Dynamically_Asynchronous
: Boolean := False;
4301 Stub_Type
: Entity_Id
:= Empty
;
4302 RACW_Type
: Entity_Id
:= Empty
;
4303 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
4305 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
4307 Request_Parameter
: Node_Id
;
4310 Decls
: constant List_Id
:= New_List
;
4311 -- All the parameters will get declared before calling the real
4312 -- subprograms. Also the out parameters will be declared.
4314 Statements
: constant List_Id
:= New_List
;
4316 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4317 -- Statements concerning extra formal parameters
4319 After_Statements
: constant List_Id
:= New_List
;
4320 -- Statements to be executed after the subprogram call
4322 Inner_Decls
: List_Id
:= No_List
;
4323 -- In case of a function, the inner declarations are needed since
4324 -- the result may be unconstrained.
4326 Excep_Handlers
: List_Id
:= No_List
;
4327 Excep_Choice
: Entity_Id
;
4328 Excep_Code
: List_Id
;
4330 Parameter_List
: constant List_Id
:= New_List
;
4331 -- List of parameters to be passed to the subprogram
4333 Current_Parameter
: Node_Id
;
4335 Ordered_Parameters_List
: constant List_Id
:=
4336 Build_Ordered_Parameters_List
4337 (Specification
(Vis_Decl
));
4339 Subp_Spec
: Node_Id
;
4340 -- Subprogram specification
4342 Called_Subprogram
: Node_Id
;
4343 -- The subprogram to call
4345 Null_Raise_Statement
: Node_Id
;
4347 Dynamic_Async
: Entity_Id
;
4350 if Present
(RACW_Type
) then
4351 Called_Subprogram
:=
4352 New_Occurrence_Of
(Parent_Primitive
, Loc
);
4354 Called_Subprogram
:=
4356 Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
4359 Request_Parameter
:=
4360 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4362 if Dynamically_Asynchronous
then
4364 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
4366 Dynamic_Async
:= Empty
;
4369 if not Asynchronous
or Dynamically_Asynchronous
then
4371 -- The first statement after the subprogram call is a statement to
4372 -- writes a Null_Occurrence into the result stream.
4374 Null_Raise_Statement
:=
4375 Make_Attribute_Reference
(Loc
,
4377 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4378 Attribute_Name
=> Name_Write
,
4379 Expressions
=> New_List
(
4380 Make_Selected_Component
(Loc
,
4381 Prefix
=> Request_Parameter
,
4382 Selector_Name
=> Name_Result
),
4383 New_Occurrence_Of
(RTE
(RE_Null_Occurrence
), Loc
)));
4385 if Dynamically_Asynchronous
then
4386 Null_Raise_Statement
:=
4387 Make_Implicit_If_Statement
(Vis_Decl
,
4389 Make_Op_Not
(Loc
, New_Occurrence_Of
(Dynamic_Async
, Loc
)),
4390 Then_Statements
=> New_List
(Null_Raise_Statement
));
4393 Append_To
(After_Statements
, Null_Raise_Statement
);
4396 -- Loop through every parameter and get its value from the stream. If
4397 -- the parameter is unconstrained, then the parameter is read using
4398 -- 'Input at the point of declaration.
4400 Current_Parameter
:= First
(Ordered_Parameters_List
);
4401 while Present
(Current_Parameter
) loop
4404 Constrained
: Boolean;
4406 Object
: constant Entity_Id
:=
4407 Make_Defining_Identifier
(Loc
,
4408 New_Internal_Name
('P'));
4410 Expr
: Node_Id
:= Empty
;
4412 Is_Controlling_Formal
: constant Boolean :=
4413 Is_RACW_Controlling_Formal
4414 (Current_Parameter
, Stub_Type
);
4417 Set_Ekind
(Object
, E_Variable
);
4419 if Is_Controlling_Formal
then
4421 -- We have a controlling formal parameter. Read its address
4422 -- rather than a real object. The address is in Unsigned_64
4425 Etyp
:= RTE
(RE_Unsigned_64
);
4427 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
4431 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
4433 if In_Present
(Current_Parameter
)
4434 or else not Out_Present
(Current_Parameter
)
4435 or else not Constrained
4436 or else Is_Controlling_Formal
4438 -- If an input parameter is contrained, then its reading is
4439 -- deferred until the beginning of the subprogram body. If
4440 -- it is unconstrained, then an expression is built for
4441 -- the object declaration and the variable is set using
4442 -- 'Input instead of 'Read.
4444 if Constrained
and then not Is_Controlling_Formal
then
4445 Append_To
(Statements
,
4446 Make_Attribute_Reference
(Loc
,
4447 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4448 Attribute_Name
=> Name_Read
,
4449 Expressions
=> New_List
(
4450 Make_Selected_Component
(Loc
,
4451 Prefix
=> Request_Parameter
,
4452 Selector_Name
=> Name_Params
),
4453 New_Occurrence_Of
(Object
, Loc
))));
4456 Expr
:= Input_With_Tag_Check
(Loc
,
4458 Stream
=> Make_Selected_Component
(Loc
,
4459 Prefix
=> Request_Parameter
,
4460 Selector_Name
=> Name_Params
));
4461 Append_To
(Decls
, Expr
);
4462 Expr
:= Make_Function_Call
(Loc
,
4463 New_Occurrence_Of
(Defining_Unit_Name
4464 (Specification
(Expr
)), Loc
));
4468 -- If we do not have to output the current parameter, then it
4469 -- can well be flagged as constant. This may allow further
4470 -- optimizations done by the back end.
4473 Make_Object_Declaration
(Loc
,
4474 Defining_Identifier
=> Object
,
4475 Constant_Present
=> not Constrained
4476 and then not Out_Present
(Current_Parameter
),
4477 Object_Definition
=>
4478 New_Occurrence_Of
(Etyp
, Loc
),
4479 Expression
=> Expr
));
4481 -- An out parameter may be written back using a 'Write
4482 -- attribute instead of a 'Output because it has been
4483 -- constrained by the parameter given to the caller. Note that
4484 -- out controlling arguments in the case of a RACW are not put
4485 -- back in the stream because the pointer on them has not
4488 if Out_Present
(Current_Parameter
)
4490 Etype
(Parameter_Type
(Current_Parameter
)) /= Stub_Type
4492 Append_To
(After_Statements
,
4493 Make_Attribute_Reference
(Loc
,
4494 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4495 Attribute_Name
=> Name_Write
,
4496 Expressions
=> New_List
(
4497 Make_Selected_Component
(Loc
,
4498 Prefix
=> Request_Parameter
,
4499 Selector_Name
=> Name_Result
),
4500 New_Occurrence_Of
(Object
, Loc
))));
4503 -- For RACW controlling formals, the Etyp of Object is always
4504 -- an RACW, even if the parameter is not of an anonymous access
4505 -- type. In such case, we need to dereference it at call time.
4507 if Is_Controlling_Formal
then
4508 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
4511 Append_To
(Parameter_List
,
4512 Make_Parameter_Association
(Loc
,
4515 Defining_Identifier
(Current_Parameter
), Loc
),
4516 Explicit_Actual_Parameter
=>
4517 Make_Explicit_Dereference
(Loc
,
4518 Unchecked_Convert_To
(RACW_Type
,
4519 OK_Convert_To
(RTE
(RE_Address
),
4520 New_Occurrence_Of
(Object
, Loc
))))));
4523 Append_To
(Parameter_List
,
4524 Make_Parameter_Association
(Loc
,
4527 Defining_Identifier
(Current_Parameter
), Loc
),
4528 Explicit_Actual_Parameter
=>
4529 Unchecked_Convert_To
(RACW_Type
,
4530 OK_Convert_To
(RTE
(RE_Address
),
4531 New_Occurrence_Of
(Object
, Loc
)))));
4535 Append_To
(Parameter_List
,
4536 Make_Parameter_Association
(Loc
,
4539 Defining_Identifier
(Current_Parameter
), Loc
),
4540 Explicit_Actual_Parameter
=>
4541 New_Occurrence_Of
(Object
, Loc
)));
4544 -- If the current parameter needs an extra formal, then read it
4545 -- from the stream and set the corresponding semantic field in
4546 -- the variable. If the kind of the parameter identifier is
4547 -- E_Void, then this is a compiler generated parameter that
4548 -- doesn't need an extra constrained status.
4550 -- The case of Extra_Accessibility should also be handled ???
4552 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
4555 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
4557 Present
(Extra_Constrained
4558 (Defining_Identifier
(Current_Parameter
)))
4561 Extra_Parameter
: constant Entity_Id
:=
4563 (Defining_Identifier
4564 (Current_Parameter
));
4566 Formal_Entity
: constant Entity_Id
:=
4567 Make_Defining_Identifier
4568 (Loc
, Chars
(Extra_Parameter
));
4570 Formal_Type
: constant Entity_Id
:=
4571 Etype
(Extra_Parameter
);
4575 Make_Object_Declaration
(Loc
,
4576 Defining_Identifier
=> Formal_Entity
,
4577 Object_Definition
=>
4578 New_Occurrence_Of
(Formal_Type
, Loc
)));
4580 Append_To
(Extra_Formal_Statements
,
4581 Make_Attribute_Reference
(Loc
,
4582 Prefix
=> New_Occurrence_Of
(
4584 Attribute_Name
=> Name_Read
,
4585 Expressions
=> New_List
(
4586 Make_Selected_Component
(Loc
,
4587 Prefix
=> Request_Parameter
,
4588 Selector_Name
=> Name_Params
),
4589 New_Occurrence_Of
(Formal_Entity
, Loc
))));
4590 Set_Extra_Constrained
(Object
, Formal_Entity
);
4595 Next
(Current_Parameter
);
4598 -- Append the formal statements list at the end of regular statements
4600 Append_List_To
(Statements
, Extra_Formal_Statements
);
4602 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
4604 -- The remote subprogram is a function. We build an inner block to
4605 -- be able to hold a potentially unconstrained result in a
4609 Etyp
: constant Entity_Id
:=
4610 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
4611 Result
: constant Node_Id
:=
4612 Make_Defining_Identifier
(Loc
,
4613 New_Internal_Name
('R'));
4615 Inner_Decls
:= New_List
(
4616 Make_Object_Declaration
(Loc
,
4617 Defining_Identifier
=> Result
,
4618 Constant_Present
=> True,
4619 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
4621 Make_Function_Call
(Loc
,
4622 Name
=> Called_Subprogram
,
4623 Parameter_Associations
=> Parameter_List
)));
4625 Append_To
(After_Statements
,
4626 Make_Attribute_Reference
(Loc
,
4627 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4628 Attribute_Name
=> Name_Output
,
4629 Expressions
=> New_List
(
4630 Make_Selected_Component
(Loc
,
4631 Prefix
=> Request_Parameter
,
4632 Selector_Name
=> Name_Result
),
4633 New_Occurrence_Of
(Result
, Loc
))));
4636 Append_To
(Statements
,
4637 Make_Block_Statement
(Loc
,
4638 Declarations
=> Inner_Decls
,
4639 Handled_Statement_Sequence
=>
4640 Make_Handled_Sequence_Of_Statements
(Loc
,
4641 Statements
=> After_Statements
)));
4644 -- The remote subprogram is a procedure. We do not need any inner
4645 -- block in this case.
4647 if Dynamically_Asynchronous
then
4649 Make_Object_Declaration
(Loc
,
4650 Defining_Identifier
=> Dynamic_Async
,
4651 Object_Definition
=>
4652 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
4654 Append_To
(Statements
,
4655 Make_Attribute_Reference
(Loc
,
4656 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4657 Attribute_Name
=> Name_Read
,
4658 Expressions
=> New_List
(
4659 Make_Selected_Component
(Loc
,
4660 Prefix
=> Request_Parameter
,
4661 Selector_Name
=> Name_Params
),
4662 New_Occurrence_Of
(Dynamic_Async
, Loc
))));
4665 Append_To
(Statements
,
4666 Make_Procedure_Call_Statement
(Loc
,
4667 Name
=> Called_Subprogram
,
4668 Parameter_Associations
=> Parameter_List
));
4670 Append_List_To
(Statements
, After_Statements
);
4673 if Asynchronous
and then not Dynamically_Asynchronous
then
4675 -- For an asynchronous procedure, add a null exception handler
4677 Excep_Handlers
:= New_List
(
4678 Make_Exception_Handler
(Loc
,
4679 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
4680 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
4683 -- In the other cases, if an exception is raised, then the
4684 -- exception occurrence is copied into the output stream and
4685 -- no other output parameter is written.
4688 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
4690 Excep_Code
:= New_List
(
4691 Make_Attribute_Reference
(Loc
,
4693 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4694 Attribute_Name
=> Name_Write
,
4695 Expressions
=> New_List
(
4696 Make_Selected_Component
(Loc
,
4697 Prefix
=> Request_Parameter
,
4698 Selector_Name
=> Name_Result
),
4699 New_Occurrence_Of
(Excep_Choice
, Loc
))));
4701 if Dynamically_Asynchronous
then
4702 Excep_Code
:= New_List
(
4703 Make_Implicit_If_Statement
(Vis_Decl
,
4704 Condition
=> Make_Op_Not
(Loc
,
4705 New_Occurrence_Of
(Dynamic_Async
, Loc
)),
4706 Then_Statements
=> Excep_Code
));
4709 Excep_Handlers
:= New_List
(
4710 Make_Exception_Handler
(Loc
,
4711 Choice_Parameter
=> Excep_Choice
,
4712 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
4713 Statements
=> Excep_Code
));
4718 Make_Procedure_Specification
(Loc
,
4719 Defining_Unit_Name
=>
4720 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
4722 Parameter_Specifications
=> New_List
(
4723 Make_Parameter_Specification
(Loc
,
4724 Defining_Identifier
=> Request_Parameter
,
4726 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
4729 Make_Subprogram_Body
(Loc
,
4730 Specification
=> Subp_Spec
,
4731 Declarations
=> Decls
,
4732 Handled_Statement_Sequence
=>
4733 Make_Handled_Sequence_Of_Statements
(Loc
,
4734 Statements
=> Statements
,
4735 Exception_Handlers
=> Excep_Handlers
));
4736 end Build_Subprogram_Receiving_Stubs
;
4742 function Result
return Node_Id
is
4744 return Make_Identifier
(Loc
, Name_V
);
4747 ----------------------
4748 -- Stream_Parameter --
4749 ----------------------
4751 function Stream_Parameter
return Node_Id
is
4753 return Make_Identifier
(Loc
, Name_S
);
4754 end Stream_Parameter
;
4758 -----------------------------
4759 -- Make_Selected_Component --
4760 -----------------------------
4762 function Make_Selected_Component
4765 Selector_Name
: Name_Id
) return Node_Id
4768 return Make_Selected_Component
(Loc
,
4769 Prefix
=> New_Occurrence_Of
(Prefix
, Loc
),
4770 Selector_Name
=> Make_Identifier
(Loc
, Selector_Name
));
4771 end Make_Selected_Component
;
4773 -----------------------
4774 -- Get_Subprogram_Id --
4775 -----------------------
4777 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
is
4779 return Get_Subprogram_Ids
(Def
).Str_Identifier
;
4780 end Get_Subprogram_Id
;
4782 -----------------------
4783 -- Get_Subprogram_Id --
4784 -----------------------
4786 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
is
4788 return Get_Subprogram_Ids
(Def
).Int_Identifier
;
4789 end Get_Subprogram_Id
;
4791 ------------------------
4792 -- Get_Subprogram_Ids --
4793 ------------------------
4795 function Get_Subprogram_Ids
4796 (Def
: Entity_Id
) return Subprogram_Identifiers
4798 Result
: Subprogram_Identifiers
:=
4799 Subprogram_Identifier_Table
.Get
(Def
);
4801 Current_Declaration
: Node_Id
;
4802 Current_Subp
: Entity_Id
;
4803 Current_Subp_Str
: String_Id
;
4804 Current_Subp_Number
: Int
:= First_RCI_Subprogram_Id
;
4807 if Result
.Str_Identifier
= No_String
then
4809 -- We are looking up this subprogram's identifier outside of the
4810 -- context of generating calling or receiving stubs. Hence we are
4811 -- processing an 'Access attribute_reference for an RCI subprogram,
4812 -- for the purpose of obtaining a RAS value.
4815 (Is_Remote_Call_Interface
(Scope
(Def
))
4817 (Nkind
(Parent
(Def
)) = N_Procedure_Specification
4819 Nkind
(Parent
(Def
)) = N_Function_Specification
));
4821 Current_Declaration
:=
4822 First
(Visible_Declarations
4823 (Package_Specification_Of_Scope
(Scope
(Def
))));
4824 while Present
(Current_Declaration
) loop
4825 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
4826 and then Comes_From_Source
(Current_Declaration
)
4828 Current_Subp
:= Defining_Unit_Name
(Specification
(
4829 Current_Declaration
));
4830 Assign_Subprogram_Identifier
4831 (Current_Subp
, Current_Subp_Number
, Current_Subp_Str
);
4833 if Current_Subp
= Def
then
4834 Result
:= (Current_Subp_Str
, Current_Subp_Number
);
4837 Current_Subp_Number
:= Current_Subp_Number
+ 1;
4840 Next
(Current_Declaration
);
4844 pragma Assert
(Result
.Str_Identifier
/= No_String
);
4846 end Get_Subprogram_Ids
;
4852 function Hash
(F
: Entity_Id
) return Hash_Index
is
4854 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
4857 function Hash
(F
: Name_Id
) return Hash_Index
is
4859 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
4862 --------------------------
4863 -- Input_With_Tag_Check --
4864 --------------------------
4866 function Input_With_Tag_Check
4868 Var_Type
: Entity_Id
;
4869 Stream
: Node_Id
) return Node_Id
4873 Make_Subprogram_Body
(Loc
,
4874 Specification
=> Make_Function_Specification
(Loc
,
4875 Defining_Unit_Name
=>
4876 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S')),
4877 Result_Definition
=> New_Occurrence_Of
(Var_Type
, Loc
)),
4878 Declarations
=> No_List
,
4879 Handled_Statement_Sequence
=>
4880 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
4881 Make_Tag_Check
(Loc
,
4882 Make_Return_Statement
(Loc
,
4883 Make_Attribute_Reference
(Loc
,
4884 Prefix
=> New_Occurrence_Of
(Var_Type
, Loc
),
4885 Attribute_Name
=> Name_Input
,
4887 New_List
(Stream
)))))));
4888 end Input_With_Tag_Check
;
4890 --------------------------------
4891 -- Is_RACW_Controlling_Formal --
4892 --------------------------------
4894 function Is_RACW_Controlling_Formal
4895 (Parameter
: Node_Id
;
4896 Stub_Type
: Entity_Id
) return Boolean
4901 -- If the kind of the parameter is E_Void, then it is not a
4902 -- controlling formal (this can happen in the context of RAS).
4904 if Ekind
(Defining_Identifier
(Parameter
)) = E_Void
then
4908 -- If the parameter is not a controlling formal, then it cannot
4909 -- be possibly a RACW_Controlling_Formal.
4911 if not Is_Controlling_Formal
(Defining_Identifier
(Parameter
)) then
4915 Typ
:= Parameter_Type
(Parameter
);
4916 return (Nkind
(Typ
) = N_Access_Definition
4917 and then Etype
(Subtype_Mark
(Typ
)) = Stub_Type
)
4918 or else Etype
(Typ
) = Stub_Type
;
4919 end Is_RACW_Controlling_Formal
;
4921 --------------------
4922 -- Make_Tag_Check --
4923 --------------------
4925 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
is
4926 Occ
: constant Entity_Id
:=
4927 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
4930 return Make_Block_Statement
(Loc
,
4931 Handled_Statement_Sequence
=>
4932 Make_Handled_Sequence_Of_Statements
(Loc
,
4933 Statements
=> New_List
(N
),
4935 Exception_Handlers
=> New_List
(
4936 Make_Exception_Handler
(Loc
,
4937 Choice_Parameter
=> Occ
,
4939 Exception_Choices
=>
4940 New_List
(New_Occurrence_Of
(RTE
(RE_Tag_Error
), Loc
)),
4943 New_List
(Make_Procedure_Call_Statement
(Loc
,
4945 (RTE
(RE_Raise_Program_Error_Unknown_Tag
), Loc
),
4946 New_List
(New_Occurrence_Of
(Occ
, Loc
))))))));
4949 ----------------------------
4950 -- Need_Extra_Constrained --
4951 ----------------------------
4953 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean is
4954 Etyp
: constant Entity_Id
:= Etype
(Parameter_Type
(Parameter
));
4956 return Out_Present
(Parameter
)
4957 and then Has_Discriminants
(Etyp
)
4958 and then not Is_Constrained
(Etyp
)
4959 and then not Is_Indefinite_Subtype
(Etyp
);
4960 end Need_Extra_Constrained
;
4962 ------------------------------------
4963 -- Pack_Entity_Into_Stream_Access --
4964 ------------------------------------
4966 function Pack_Entity_Into_Stream_Access
4970 Etyp
: Entity_Id
:= Empty
) return Node_Id
4975 if Present
(Etyp
) then
4978 Typ
:= Etype
(Object
);
4982 Pack_Node_Into_Stream_Access
(Loc
,
4984 Object
=> New_Occurrence_Of
(Object
, Loc
),
4986 end Pack_Entity_Into_Stream_Access
;
4988 ---------------------------
4989 -- Pack_Node_Into_Stream --
4990 ---------------------------
4992 function Pack_Node_Into_Stream
4996 Etyp
: Entity_Id
) return Node_Id
4998 Write_Attribute
: Name_Id
:= Name_Write
;
5001 if not Is_Constrained
(Etyp
) then
5002 Write_Attribute
:= Name_Output
;
5006 Make_Attribute_Reference
(Loc
,
5007 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5008 Attribute_Name
=> Write_Attribute
,
5009 Expressions
=> New_List
(
5010 Make_Attribute_Reference
(Loc
,
5011 Prefix
=> New_Occurrence_Of
(Stream
, Loc
),
5012 Attribute_Name
=> Name_Access
),
5014 end Pack_Node_Into_Stream
;
5016 ----------------------------------
5017 -- Pack_Node_Into_Stream_Access --
5018 ----------------------------------
5020 function Pack_Node_Into_Stream_Access
5024 Etyp
: Entity_Id
) return Node_Id
5026 Write_Attribute
: Name_Id
:= Name_Write
;
5029 if not Is_Constrained
(Etyp
) then
5030 Write_Attribute
:= Name_Output
;
5034 Make_Attribute_Reference
(Loc
,
5035 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5036 Attribute_Name
=> Write_Attribute
,
5037 Expressions
=> New_List
(
5040 end Pack_Node_Into_Stream_Access
;
5042 ---------------------
5043 -- PolyORB_Support --
5044 ---------------------
5046 package body PolyORB_Support
is
5048 -- Local subprograms
5050 procedure Add_RACW_Read_Attribute
5051 (RACW_Type
: Entity_Id
;
5052 Stub_Type
: Entity_Id
;
5053 Stub_Type_Access
: Entity_Id
;
5054 Declarations
: List_Id
);
5055 -- Add Read attribute in Decls for the RACW type. The Read attribute
5056 -- is added right after the RACW_Type declaration while the body is
5057 -- inserted after Declarations.
5059 procedure Add_RACW_Write_Attribute
5060 (RACW_Type
: Entity_Id
;
5061 Stub_Type
: Entity_Id
;
5062 Stub_Type_Access
: Entity_Id
;
5063 Declarations
: List_Id
);
5064 -- Same thing for the Write attribute
5066 procedure Add_RACW_From_Any
5067 (RACW_Type
: Entity_Id
;
5068 Stub_Type
: Entity_Id
;
5069 Stub_Type_Access
: Entity_Id
;
5070 Declarations
: List_Id
);
5071 -- Add the From_Any TSS for this RACW type
5073 procedure Add_RACW_To_Any
5074 (Designated_Type
: Entity_Id
;
5075 RACW_Type
: Entity_Id
;
5076 Stub_Type
: Entity_Id
;
5077 Stub_Type_Access
: Entity_Id
;
5078 Declarations
: List_Id
);
5079 -- Add the To_Any TSS for this RACW type
5081 procedure Add_RACW_TypeCode
5082 (Designated_Type
: Entity_Id
;
5083 RACW_Type
: Entity_Id
;
5084 Declarations
: List_Id
);
5085 -- Add the TypeCode TSS for this RACW type
5087 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
);
5088 -- Add the From_Any TSS for this RAS type
5090 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
);
5091 -- Add the To_Any TSS for this RAS type
5093 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
);
5094 -- Add the TypeCode TSS for this RAS type
5096 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
5097 -- Add a subprogram body for RAS Access TSS
5099 -------------------------------------
5100 -- Add_Obj_RPC_Receiver_Completion --
5101 -------------------------------------
5103 procedure Add_Obj_RPC_Receiver_Completion
5106 RPC_Receiver
: Entity_Id
;
5107 Stub_Elements
: Stub_Structure
)
5109 Desig
: constant Entity_Id
:=
5110 Etype
(Designated_Type
(Stub_Elements
.RACW_Type
));
5113 Make_Procedure_Call_Statement
(Loc
,
5116 RTE
(RE_Register_Obj_Receiving_Stub
), Loc
),
5118 Parameter_Associations
=> New_List
(
5122 Make_String_Literal
(Loc
,
5123 Full_Qualified_Name
(Desig
)),
5127 Make_Attribute_Reference
(Loc
,
5130 Defining_Unit_Name
(Parent
(RPC_Receiver
)), Loc
),
5136 Make_Attribute_Reference
(Loc
,
5139 Defining_Identifier
(
5140 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5143 end Add_Obj_RPC_Receiver_Completion
;
5145 -----------------------
5146 -- Add_RACW_Features --
5147 -----------------------
5149 procedure Add_RACW_Features
5150 (RACW_Type
: Entity_Id
;
5152 Stub_Type
: Entity_Id
;
5153 Stub_Type_Access
: Entity_Id
;
5154 RPC_Receiver_Decl
: Node_Id
;
5155 Declarations
: List_Id
)
5157 pragma Warnings
(Off
);
5158 pragma Unreferenced
(RPC_Receiver_Decl
);
5159 pragma Warnings
(On
);
5163 (RACW_Type
=> RACW_Type
,
5164 Stub_Type
=> Stub_Type
,
5165 Stub_Type_Access
=> Stub_Type_Access
,
5166 Declarations
=> Declarations
);
5169 (Designated_Type
=> Desig
,
5170 RACW_Type
=> RACW_Type
,
5171 Stub_Type
=> Stub_Type
,
5172 Stub_Type_Access
=> Stub_Type_Access
,
5173 Declarations
=> Declarations
);
5175 -- In the PolyORB case, the RACW 'Read and 'Write attributes
5176 -- are implemented in terms of the From_Any and To_Any TSSs,
5177 -- so these TSSs must be expanded before 'Read and 'Write.
5179 Add_RACW_Write_Attribute
5180 (RACW_Type
=> RACW_Type
,
5181 Stub_Type
=> Stub_Type
,
5182 Stub_Type_Access
=> Stub_Type_Access
,
5183 Declarations
=> Declarations
);
5185 Add_RACW_Read_Attribute
5186 (RACW_Type
=> RACW_Type
,
5187 Stub_Type
=> Stub_Type
,
5188 Stub_Type_Access
=> Stub_Type_Access
,
5189 Declarations
=> Declarations
);
5192 (Designated_Type
=> Desig
,
5193 RACW_Type
=> RACW_Type
,
5194 Declarations
=> Declarations
);
5195 end Add_RACW_Features
;
5197 -----------------------
5198 -- Add_RACW_From_Any --
5199 -----------------------
5201 procedure Add_RACW_From_Any
5202 (RACW_Type
: Entity_Id
;
5203 Stub_Type
: Entity_Id
;
5204 Stub_Type_Access
: Entity_Id
;
5205 Declarations
: List_Id
)
5207 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5208 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5210 Fnam
: constant Entity_Id
:=
5211 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F'));
5213 Func_Spec
: Node_Id
;
5214 Func_Decl
: Node_Id
;
5215 Func_Body
: Node_Id
;
5218 Statements
: List_Id
;
5219 Stub_Statements
: List_Id
;
5220 Local_Statements
: List_Id
;
5221 -- Various parts of the subprogram
5223 Any_Parameter
: constant Entity_Id
:=
5224 Make_Defining_Identifier
(Loc
, Name_A
);
5225 Reference
: constant Entity_Id
:=
5226 Make_Defining_Identifier
5227 (Loc
, New_Internal_Name
('R'));
5228 Is_Local
: constant Entity_Id
:=
5229 Make_Defining_Identifier
5230 (Loc
, New_Internal_Name
('L'));
5231 Addr
: constant Entity_Id
:=
5232 Make_Defining_Identifier
5233 (Loc
, New_Internal_Name
('A'));
5234 Local_Stub
: constant Entity_Id
:=
5235 Make_Defining_Identifier
5236 (Loc
, New_Internal_Name
('L'));
5237 Stubbed_Result
: constant Entity_Id
:=
5238 Make_Defining_Identifier
5239 (Loc
, New_Internal_Name
('S'));
5241 Stub_Condition
: Node_Id
;
5242 -- An expression that determines whether we create a stub for the
5243 -- newly-unpacked RACW. Normally we create a stub only for remote
5244 -- objects, but in the case of an RACW used to implement a RAS,
5245 -- we also create a stub for local subprograms if a pragma
5246 -- All_Calls_Remote applies.
5248 Asynchronous_Flag
: constant Entity_Id
:=
5249 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5250 -- The flag object declared in Add_RACW_Asynchronous_Flag
5253 -- Object declarations
5256 Make_Object_Declaration
(Loc
,
5257 Defining_Identifier
=>
5259 Object_Definition
=>
5260 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5262 Make_Function_Call
(Loc
,
5264 New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
5265 Parameter_Associations
=> New_List
(
5266 New_Occurrence_Of
(Any_Parameter
, Loc
)))),
5268 Make_Object_Declaration
(Loc
,
5269 Defining_Identifier
=> Local_Stub
,
5270 Aliased_Present
=> True,
5271 Object_Definition
=> New_Occurrence_Of
(Stub_Type
, Loc
)),
5273 Make_Object_Declaration
(Loc
,
5274 Defining_Identifier
=> Stubbed_Result
,
5275 Object_Definition
=>
5276 New_Occurrence_Of
(Stub_Type_Access
, Loc
),
5278 Make_Attribute_Reference
(Loc
,
5280 New_Occurrence_Of
(Local_Stub
, Loc
),
5282 Name_Unchecked_Access
)),
5284 Make_Object_Declaration
(Loc
,
5285 Defining_Identifier
=> Is_Local
,
5286 Object_Definition
=>
5287 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
5289 Make_Object_Declaration
(Loc
,
5290 Defining_Identifier
=> Addr
,
5291 Object_Definition
=>
5292 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
5294 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
5296 Set_Etype
(Stubbed_Result
, Stub_Type_Access
);
5298 -- If the ref Is_Nil, return a null pointer
5300 Statements
:= New_List
(
5301 Make_Implicit_If_Statement
(RACW_Type
,
5303 Make_Function_Call
(Loc
,
5305 New_Occurrence_Of
(RTE
(RE_Is_Nil
), Loc
),
5306 Parameter_Associations
=> New_List
(
5307 New_Occurrence_Of
(Reference
, Loc
))),
5308 Then_Statements
=> New_List
(
5309 Make_Return_Statement
(Loc
,
5311 Make_Null
(Loc
)))));
5313 Append_To
(Statements
,
5314 Make_Procedure_Call_Statement
(Loc
,
5316 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
5317 Parameter_Associations
=> New_List
(
5318 New_Occurrence_Of
(Reference
, Loc
),
5319 New_Occurrence_Of
(Is_Local
, Loc
),
5320 New_Occurrence_Of
(Addr
, Loc
))));
5322 -- If the object is located on another partition, then a stub object
5323 -- will be created with all the information needed to rebuild the
5324 -- real object at the other end. This stanza is always used in the
5325 -- case of RAS types, for which a stub is required even for local
5328 Stub_Statements
:= New_List
(
5329 Make_Assignment_Statement
(Loc
,
5330 Name
=> Make_Selected_Component
(Loc
,
5331 Prefix
=> Stubbed_Result
,
5332 Selector_Name
=> Name_Target
),
5334 Make_Function_Call
(Loc
,
5336 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
5337 Parameter_Associations
=> New_List
(
5338 New_Occurrence_Of
(Reference
, Loc
)))),
5340 Make_Procedure_Call_Statement
(Loc
,
5342 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
5343 Parameter_Associations
=> New_List
(
5344 Make_Selected_Component
(Loc
,
5345 Prefix
=> Stubbed_Result
,
5346 Selector_Name
=> Name_Target
))),
5348 Make_Assignment_Statement
(Loc
,
5349 Name
=> Make_Selected_Component
(Loc
,
5350 Prefix
=> Stubbed_Result
,
5351 Selector_Name
=> Name_Asynchronous
),
5353 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)));
5355 -- ??? Issue with asynchronous calls here: the Asynchronous
5356 -- flag is set on the stub type if, and only if, the RACW type
5357 -- has a pragma Asynchronous. This is incorrect for RACWs that
5358 -- implement RAS types, because in that case the /designated
5359 -- subprogram/ (not the type) might be asynchronous, and
5360 -- that causes the stub to need to be asynchronous too.
5361 -- A solution is to transport a RAS as a struct containing
5362 -- a RACW and an asynchronous flag, and to properly alter
5363 -- the Asynchronous component in the stub type in the RAS's
5366 Append_List_To
(Stub_Statements
,
5367 Build_Get_Unique_RP_Call
(Loc
, Stubbed_Result
, Stub_Type
));
5369 -- Distinguish between the local and remote cases, and execute the
5370 -- appropriate piece of code.
5372 Stub_Condition
:= New_Occurrence_Of
(Is_Local
, Loc
);
5375 Stub_Condition
:= Make_And_Then
(Loc
,
5379 Make_Selected_Component
(Loc
,
5381 Unchecked_Convert_To
(
5382 RTE
(RE_RAS_Proxy_Type_Access
),
5383 New_Occurrence_Of
(Addr
, Loc
)),
5385 Make_Identifier
(Loc
,
5386 Name_All_Calls_Remote
)));
5389 Local_Statements
:= New_List
(
5390 Make_Return_Statement
(Loc
,
5392 Unchecked_Convert_To
(RACW_Type
,
5393 New_Occurrence_Of
(Addr
, Loc
))));
5395 Append_To
(Statements
,
5396 Make_Implicit_If_Statement
(RACW_Type
,
5399 Then_Statements
=> Local_Statements
,
5400 Else_Statements
=> Stub_Statements
));
5402 Append_To
(Statements
,
5403 Make_Return_Statement
(Loc
,
5404 Expression
=> Unchecked_Convert_To
(RACW_Type
,
5405 New_Occurrence_Of
(Stubbed_Result
, Loc
))));
5408 Make_Function_Specification
(Loc
,
5409 Defining_Unit_Name
=>
5411 Parameter_Specifications
=> New_List
(
5412 Make_Parameter_Specification
(Loc
,
5413 Defining_Identifier
=>
5416 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
5417 Result_Definition
=> New_Occurrence_Of
(RACW_Type
, Loc
));
5419 -- NOTE: The usage occurrences of RACW_Parameter must
5420 -- refer to the entity in the declaration spec, not those
5421 -- of the body spec.
5423 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5426 Make_Subprogram_Body
(Loc
,
5428 Copy_Specification
(Loc
, Func_Spec
),
5429 Declarations
=> Decls
,
5430 Handled_Statement_Sequence
=>
5431 Make_Handled_Sequence_Of_Statements
(Loc
,
5432 Statements
=> Statements
));
5434 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5435 Append_To
(Declarations
, Func_Body
);
5437 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_From_Any
);
5438 end Add_RACW_From_Any
;
5440 -----------------------------
5441 -- Add_RACW_Read_Attribute --
5442 -----------------------------
5444 procedure Add_RACW_Read_Attribute
5445 (RACW_Type
: Entity_Id
;
5446 Stub_Type
: Entity_Id
;
5447 Stub_Type_Access
: Entity_Id
;
5448 Declarations
: List_Id
)
5450 pragma Warnings
(Off
);
5451 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
5452 pragma Warnings
(On
);
5453 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5455 Proc_Decl
: Node_Id
;
5456 Attr_Decl
: Node_Id
;
5458 Body_Node
: Node_Id
;
5461 Statements
: List_Id
;
5462 -- Various parts of the procedure
5464 Procedure_Name
: constant Name_Id
:=
5465 New_Internal_Name
('R');
5466 Source_Ref
: constant Entity_Id
:=
5467 Make_Defining_Identifier
5468 (Loc
, New_Internal_Name
('R'));
5469 Asynchronous_Flag
: constant Entity_Id
:=
5470 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5471 pragma Assert
(Present
(Asynchronous_Flag
));
5473 function Stream_Parameter
return Node_Id
;
5474 function Result
return Node_Id
;
5475 -- Functions to create occurrences of the formal parameter names
5481 function Result
return Node_Id
is
5483 return Make_Identifier
(Loc
, Name_V
);
5486 ----------------------
5487 -- Stream_Parameter --
5488 ----------------------
5490 function Stream_Parameter
return Node_Id
is
5492 return Make_Identifier
(Loc
, Name_S
);
5493 end Stream_Parameter
;
5495 -- Start of processing for Add_RACW_Read_Attribute
5498 -- Generate object declarations
5501 Make_Object_Declaration
(Loc
,
5502 Defining_Identifier
=> Source_Ref
,
5503 Object_Definition
=>
5504 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)));
5506 Statements
:= New_List
(
5507 Make_Attribute_Reference
(Loc
,
5509 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5510 Attribute_Name
=> Name_Read
,
5511 Expressions
=> New_List
(
5513 New_Occurrence_Of
(Source_Ref
, Loc
))),
5514 Make_Assignment_Statement
(Loc
,
5518 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
5520 Make_Function_Call
(Loc
,
5522 New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
5523 Parameter_Associations
=> New_List
(
5524 New_Occurrence_Of
(Source_Ref
, Loc
))),
5527 Build_Stream_Procedure
5528 (Loc
, RACW_Type
, Body_Node
,
5529 Make_Defining_Identifier
(Loc
, Procedure_Name
),
5530 Statements
, Outp
=> True);
5531 Set_Declarations
(Body_Node
, Decls
);
5533 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
5534 Copy_Specification
(Loc
, Specification
(Body_Node
)));
5537 Make_Attribute_Definition_Clause
(Loc
,
5538 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
5542 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
5544 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
5545 Insert_After
(Proc_Decl
, Attr_Decl
);
5546 Append_To
(Declarations
, Body_Node
);
5547 end Add_RACW_Read_Attribute
;
5549 ---------------------
5550 -- Add_RACW_To_Any --
5551 ---------------------
5553 procedure Add_RACW_To_Any
5554 (Designated_Type
: Entity_Id
;
5555 RACW_Type
: Entity_Id
;
5556 Stub_Type
: Entity_Id
;
5557 Stub_Type_Access
: Entity_Id
;
5558 Declarations
: List_Id
)
5560 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5562 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5566 Stub_Elements
: constant Stub_Structure
:=
5567 Stubs_Table
.Get
(Designated_Type
);
5568 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5570 Func_Spec
: Node_Id
;
5571 Func_Decl
: Node_Id
;
5572 Func_Body
: Node_Id
;
5575 Statements
: List_Id
;
5576 Null_Statements
: List_Id
;
5577 Local_Statements
: List_Id
:= No_List
;
5578 Stub_Statements
: List_Id
;
5580 -- Various parts of the subprogram
5582 RACW_Parameter
: constant Entity_Id
5583 := Make_Defining_Identifier
(Loc
, Name_R
);
5585 Reference
: constant Entity_Id
:=
5586 Make_Defining_Identifier
5587 (Loc
, New_Internal_Name
('R'));
5588 Any
: constant Entity_Id
:=
5589 Make_Defining_Identifier
5590 (Loc
, New_Internal_Name
('A'));
5593 -- Object declarations
5596 Make_Object_Declaration
(Loc
,
5597 Defining_Identifier
=>
5599 Object_Definition
=>
5600 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
5601 Make_Object_Declaration
(Loc
,
5602 Defining_Identifier
=>
5604 Object_Definition
=>
5605 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
5607 -- If the object is null, nothing to do (Reference is already
5610 Null_Statements
:= New_List
(Make_Null_Statement
(Loc
));
5614 -- If the object is a RAS designating a local subprogram,
5615 -- we already have a target reference.
5617 Local_Statements
:= New_List
(
5618 Make_Procedure_Call_Statement
(Loc
,
5620 New_Occurrence_Of
(RTE
(RE_Set_Ref
), Loc
),
5621 Parameter_Associations
=> New_List
(
5622 New_Occurrence_Of
(Reference
, Loc
),
5623 Make_Selected_Component
(Loc
,
5625 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
5626 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5627 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)))));
5630 -- If the object is a local RACW object, use Get_Reference now
5631 -- to obtain a reference.
5633 Local_Statements
:= New_List
(
5634 Make_Procedure_Call_Statement
(Loc
,
5636 New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
5637 Parameter_Associations
=> New_List
(
5638 Unchecked_Convert_To
(
5640 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5641 Make_String_Literal
(Loc
,
5642 Full_Qualified_Name
(Designated_Type
)),
5643 Make_Attribute_Reference
(Loc
,
5646 Defining_Identifier
(
5647 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5650 New_Occurrence_Of
(Reference
, Loc
))));
5653 -- If the object is located on another partition, use the target
5656 Stub_Statements
:= New_List
(
5657 Make_Procedure_Call_Statement
(Loc
,
5659 New_Occurrence_Of
(RTE
(RE_Set_Ref
), Loc
),
5660 Parameter_Associations
=> New_List
(
5661 New_Occurrence_Of
(Reference
, Loc
),
5662 Make_Selected_Component
(Loc
,
5663 Prefix
=> Unchecked_Convert_To
(Stub_Type_Access
,
5664 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5666 Make_Identifier
(Loc
, Name_Target
)))));
5668 -- Distinguish between the null, local and remote cases,
5669 -- and execute the appropriate piece of code.
5672 Make_Implicit_If_Statement
(RACW_Type
,
5675 Left_Opnd
=> New_Occurrence_Of
(RACW_Parameter
, Loc
),
5676 Right_Opnd
=> Make_Null
(Loc
)),
5677 Then_Statements
=> Null_Statements
,
5678 Elsif_Parts
=> New_List
(
5679 Make_Elsif_Part
(Loc
,
5683 Make_Attribute_Reference
(Loc
,
5685 New_Occurrence_Of
(RACW_Parameter
, Loc
),
5686 Attribute_Name
=> Name_Tag
),
5688 Make_Attribute_Reference
(Loc
,
5689 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
5690 Attribute_Name
=> Name_Tag
)),
5691 Then_Statements
=> Local_Statements
)),
5692 Else_Statements
=> Stub_Statements
);
5694 Statements
:= New_List
(
5696 Make_Assignment_Statement
(Loc
,
5698 New_Occurrence_Of
(Any
, Loc
),
5700 Make_Function_Call
(Loc
,
5701 Name
=> New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
5702 Parameter_Associations
=> New_List
(
5703 New_Occurrence_Of
(Reference
, Loc
)))),
5704 Make_Procedure_Call_Statement
(Loc
,
5706 New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
5707 Parameter_Associations
=> New_List
(
5708 New_Occurrence_Of
(Any
, Loc
),
5709 Make_Selected_Component
(Loc
,
5711 Defining_Identifier
(
5712 Stub_Elements
.RPC_Receiver_Decl
),
5713 Selector_Name
=> Name_Obj_TypeCode
))),
5714 Make_Return_Statement
(Loc
,
5716 New_Occurrence_Of
(Any
, Loc
)));
5718 Fnam
:= Make_Defining_Identifier
(
5719 Loc
, New_Internal_Name
('T'));
5722 Make_Function_Specification
(Loc
,
5723 Defining_Unit_Name
=>
5725 Parameter_Specifications
=> New_List
(
5726 Make_Parameter_Specification
(Loc
,
5727 Defining_Identifier
=>
5730 New_Occurrence_Of
(RACW_Type
, Loc
))),
5731 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
5733 -- NOTE: The usage occurrences of RACW_Parameter must
5734 -- refer to the entity in the declaration spec, not in
5737 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5740 Make_Subprogram_Body
(Loc
,
5742 Copy_Specification
(Loc
, Func_Spec
),
5743 Declarations
=> Decls
,
5744 Handled_Statement_Sequence
=>
5745 Make_Handled_Sequence_Of_Statements
(Loc
,
5746 Statements
=> Statements
));
5748 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5749 Append_To
(Declarations
, Func_Body
);
5751 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_To_Any
);
5752 end Add_RACW_To_Any
;
5754 -----------------------
5755 -- Add_RACW_TypeCode --
5756 -----------------------
5758 procedure Add_RACW_TypeCode
5759 (Designated_Type
: Entity_Id
;
5760 RACW_Type
: Entity_Id
;
5761 Declarations
: List_Id
)
5763 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5767 Stub_Elements
: constant Stub_Structure
:=
5768 Stubs_Table
.Get
(Designated_Type
);
5769 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5771 Func_Spec
: Node_Id
;
5772 Func_Decl
: Node_Id
;
5773 Func_Body
: Node_Id
;
5777 Make_Defining_Identifier
(Loc
,
5778 Chars
=> New_Internal_Name
('T'));
5780 -- The spec for this subprogram has a dummy 'access RACW'
5781 -- argument, which serves only for overloading purposes.
5784 Make_Function_Specification
(Loc
,
5785 Defining_Unit_Name
=>
5787 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
5789 -- NOTE: The usage occurrences of RACW_Parameter must
5790 -- refer to the entity in the declaration spec, not those
5791 -- of the body spec.
5793 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5796 Make_Subprogram_Body
(Loc
,
5798 Copy_Specification
(Loc
, Func_Spec
),
5799 Declarations
=> Empty_List
,
5800 Handled_Statement_Sequence
=>
5801 Make_Handled_Sequence_Of_Statements
(Loc
,
5802 Statements
=> New_List
(
5803 Make_Return_Statement
(Loc
,
5805 Make_Selected_Component
(Loc
,
5807 Defining_Identifier
(
5808 Stub_Elements
.RPC_Receiver_Decl
),
5809 Selector_Name
=> Name_Obj_TypeCode
)))));
5811 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5812 Append_To
(Declarations
, Func_Body
);
5814 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_TypeCode
);
5815 end Add_RACW_TypeCode
;
5817 ------------------------------
5818 -- Add_RACW_Write_Attribute --
5819 ------------------------------
5821 procedure Add_RACW_Write_Attribute
5822 (RACW_Type
: Entity_Id
;
5823 Stub_Type
: Entity_Id
;
5824 Stub_Type_Access
: Entity_Id
;
5825 Declarations
: List_Id
)
5827 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5828 pragma Warnings
(Off
);
5829 pragma Unreferenced
(
5833 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5834 pragma Unreferenced
(Is_RAS
);
5835 pragma Warnings
(On
);
5837 Body_Node
: Node_Id
;
5838 Proc_Decl
: Node_Id
;
5839 Attr_Decl
: Node_Id
;
5841 Statements
: List_Id
;
5842 Procedure_Name
: constant Name_Id
:= New_Internal_Name
('R');
5844 function Stream_Parameter
return Node_Id
;
5845 function Object
return Node_Id
;
5846 -- Functions to create occurrences of the formal parameter names
5852 function Object
return Node_Id
is
5853 Object_Ref
: constant Node_Id
:=
5854 Make_Identifier
(Loc
, Name_V
);
5857 -- Etype must be set for Build_To_Any_Call
5859 Set_Etype
(Object_Ref
, RACW_Type
);
5864 ----------------------
5865 -- Stream_Parameter --
5866 ----------------------
5868 function Stream_Parameter
return Node_Id
is
5870 return Make_Identifier
(Loc
, Name_S
);
5871 end Stream_Parameter
;
5873 -- Start of processing for Add_RACW_Write_Attribute
5876 Statements
:= New_List
(
5877 Pack_Node_Into_Stream_Access
(Loc
,
5878 Stream
=> Stream_Parameter
,
5880 Make_Function_Call
(Loc
,
5882 New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
5883 Parameter_Associations
=> New_List
(
5884 PolyORB_Support
.Helpers
.Build_To_Any_Call
5885 (Object
, Declarations
))),
5886 Etyp
=> RTE
(RE_Object_Ref
)));
5888 Build_Stream_Procedure
5889 (Loc
, RACW_Type
, Body_Node
,
5890 Make_Defining_Identifier
(Loc
, Procedure_Name
),
5891 Statements
, Outp
=> False);
5894 Make_Subprogram_Declaration
(Loc
,
5895 Copy_Specification
(Loc
, Specification
(Body_Node
)));
5898 Make_Attribute_Definition_Clause
(Loc
,
5899 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
5900 Chars
=> Name_Write
,
5903 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
5905 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
5906 Insert_After
(Proc_Decl
, Attr_Decl
);
5907 Append_To
(Declarations
, Body_Node
);
5908 end Add_RACW_Write_Attribute
;
5910 -----------------------
5911 -- Add_RAST_Features --
5912 -----------------------
5914 procedure Add_RAST_Features
5915 (Vis_Decl
: Node_Id
;
5916 RAS_Type
: Entity_Id
)
5919 Add_RAS_Access_TSS
(Vis_Decl
);
5921 Add_RAS_From_Any
(RAS_Type
);
5922 Add_RAS_TypeCode
(RAS_Type
);
5924 -- To_Any uses TypeCode, and therefore needs to be generated last
5926 Add_RAS_To_Any
(RAS_Type
);
5927 end Add_RAST_Features
;
5929 ------------------------
5930 -- Add_RAS_Access_TSS --
5931 ------------------------
5933 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
5934 Loc
: constant Source_Ptr
:= Sloc
(N
);
5936 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
5937 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
5938 -- Ras_Type is the access to subprogram type; Fat_Type is the
5939 -- corresponding record type.
5941 RACW_Type
: constant Entity_Id
:=
5942 Underlying_RACW_Type
(Ras_Type
);
5943 Desig
: constant Entity_Id
:=
5944 Etype
(Designated_Type
(RACW_Type
));
5946 Stub_Elements
: constant Stub_Structure
:=
5947 Stubs_Table
.Get
(Desig
);
5948 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5950 Proc
: constant Entity_Id
:=
5951 Make_Defining_Identifier
(Loc
,
5952 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
5954 Proc_Spec
: Node_Id
;
5956 -- Formal parameters
5958 Package_Name
: constant Entity_Id
:=
5959 Make_Defining_Identifier
(Loc
,
5964 Subp_Id
: constant Entity_Id
:=
5965 Make_Defining_Identifier
(Loc
,
5968 -- Target subprogram
5970 Asynch_P
: constant Entity_Id
:=
5971 Make_Defining_Identifier
(Loc
,
5972 Chars
=> Name_Asynchronous
);
5973 -- Is the procedure to which the 'Access applies asynchronous?
5975 All_Calls_Remote
: constant Entity_Id
:=
5976 Make_Defining_Identifier
(Loc
,
5977 Chars
=> Name_All_Calls_Remote
);
5978 -- True if an All_Calls_Remote pragma applies to the RCI unit
5979 -- that contains the subprogram.
5981 -- Common local variables
5983 Proc_Decls
: List_Id
;
5984 Proc_Statements
: List_Id
;
5986 Subp_Ref
: constant Entity_Id
:=
5987 Make_Defining_Identifier
(Loc
, Name_R
);
5988 -- Reference that designates the target subprogram (returned
5989 -- by Get_RAS_Info).
5991 Is_Local
: constant Entity_Id
:=
5992 Make_Defining_Identifier
(Loc
, Name_L
);
5993 Local_Addr
: constant Entity_Id
:=
5994 Make_Defining_Identifier
(Loc
, Name_A
);
5995 -- For the call to Get_Local_Address
5997 -- Additional local variables for the remote case
5999 Local_Stub
: constant Entity_Id
:=
6000 Make_Defining_Identifier
(Loc
,
6001 Chars
=> New_Internal_Name
('L'));
6003 Stub_Ptr
: constant Entity_Id
:=
6004 Make_Defining_Identifier
(Loc
,
6005 Chars
=> New_Internal_Name
('S'));
6008 (Field_Name
: Name_Id
;
6009 Value
: Node_Id
) return Node_Id
;
6010 -- Construct an assignment that sets the named component in the
6018 (Field_Name
: Name_Id
;
6019 Value
: Node_Id
) return Node_Id
6023 Make_Assignment_Statement
(Loc
,
6025 Make_Selected_Component
(Loc
,
6027 Selector_Name
=> Field_Name
),
6028 Expression
=> Value
);
6031 -- Start of processing for Add_RAS_Access_TSS
6034 Proc_Decls
:= New_List
(
6036 -- Common declarations
6038 Make_Object_Declaration
(Loc
,
6039 Defining_Identifier
=> Subp_Ref
,
6040 Object_Definition
=>
6041 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
6043 Make_Object_Declaration
(Loc
,
6044 Defining_Identifier
=> Is_Local
,
6045 Object_Definition
=>
6046 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6048 Make_Object_Declaration
(Loc
,
6049 Defining_Identifier
=> Local_Addr
,
6050 Object_Definition
=>
6051 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
6053 Make_Object_Declaration
(Loc
,
6054 Defining_Identifier
=> Local_Stub
,
6055 Aliased_Present
=> True,
6056 Object_Definition
=>
6057 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
6059 Make_Object_Declaration
(Loc
,
6060 Defining_Identifier
=>
6062 Object_Definition
=>
6063 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
6065 Make_Attribute_Reference
(Loc
,
6066 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
6067 Attribute_Name
=> Name_Unchecked_Access
)));
6069 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
6070 -- Build_Get_Unique_RP_Call needs this information
6072 -- Get_RAS_Info (Pkg, Subp, R);
6073 -- Obtain a reference to the target subprogram
6075 Proc_Statements
:= New_List
(
6076 Make_Procedure_Call_Statement
(Loc
,
6078 New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
6079 Parameter_Associations
=> New_List
(
6080 New_Occurrence_Of
(Package_Name
, Loc
),
6081 New_Occurrence_Of
(Subp_Id
, Loc
),
6082 New_Occurrence_Of
(Subp_Ref
, Loc
))),
6084 -- Get_Local_Address (R, L, A);
6085 -- Determine whether the subprogram is local (L), and if so
6086 -- obtain the local address of its proxy (A).
6088 Make_Procedure_Call_Statement
(Loc
,
6090 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6091 Parameter_Associations
=> New_List
(
6092 New_Occurrence_Of
(Subp_Ref
, Loc
),
6093 New_Occurrence_Of
(Is_Local
, Loc
),
6094 New_Occurrence_Of
(Local_Addr
, Loc
))));
6096 -- Note: Here we assume that the Fat_Type is a record containing just
6097 -- an access to a proxy or stub object.
6099 Append_To
(Proc_Statements
,
6103 Make_Implicit_If_Statement
(N
,
6105 New_Occurrence_Of
(Is_Local
, Loc
),
6107 Then_Statements
=> New_List
(
6109 -- if A.Target = null then
6111 Make_Implicit_If_Statement
(N
,
6114 Make_Selected_Component
(Loc
,
6116 Unchecked_Convert_To
(
6117 RTE
(RE_RAS_Proxy_Type_Access
),
6118 New_Occurrence_Of
(Local_Addr
, Loc
)),
6120 Make_Identifier
(Loc
, Name_Target
)),
6123 Then_Statements
=> New_List
(
6125 -- A.Target := Entity_Of (Ref);
6127 Make_Assignment_Statement
(Loc
,
6129 Make_Selected_Component
(Loc
,
6131 Unchecked_Convert_To
(
6132 RTE
(RE_RAS_Proxy_Type_Access
),
6133 New_Occurrence_Of
(Local_Addr
, Loc
)),
6135 Make_Identifier
(Loc
, Name_Target
)),
6137 Make_Function_Call
(Loc
,
6139 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6140 Parameter_Associations
=> New_List
(
6141 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6143 -- Inc_Usage (A.Target);
6145 Make_Procedure_Call_Statement
(Loc
,
6147 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6148 Parameter_Associations
=> New_List
(
6149 Make_Selected_Component
(Loc
,
6151 Unchecked_Convert_To
(
6152 RTE
(RE_RAS_Proxy_Type_Access
),
6153 New_Occurrence_Of
(Local_Addr
, Loc
)),
6154 Selector_Name
=> Make_Identifier
(Loc
,
6158 -- if not All_Calls_Remote then
6159 -- return Fat_Type!(A);
6162 Make_Implicit_If_Statement
(N
,
6165 New_Occurrence_Of
(All_Calls_Remote
, Loc
)),
6167 Then_Statements
=> New_List
(
6168 Make_Return_Statement
(Loc
,
6169 Unchecked_Convert_To
(Fat_Type
,
6170 New_Occurrence_Of
(Local_Addr
, Loc
))))))));
6172 Append_List_To
(Proc_Statements
, New_List
(
6174 -- Stub.Target := Entity_Of (Ref);
6176 Set_Field
(Name_Target
,
6177 Make_Function_Call
(Loc
,
6179 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6180 Parameter_Associations
=> New_List
(
6181 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6183 -- Inc_Usage (Stub.Target);
6185 Make_Procedure_Call_Statement
(Loc
,
6187 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6188 Parameter_Associations
=> New_List
(
6189 Make_Selected_Component
(Loc
,
6191 Selector_Name
=> Name_Target
))),
6193 -- E.4.1(9) A remote call is asynchronous if it is a call to
6194 -- a procedure, or a call through a value of an access-to-procedure
6195 -- type, to which a pragma Asynchronous applies.
6197 -- Parameter Asynch_P is true when the procedure is asynchronous;
6198 -- Expression Asynch_T is true when the type is asynchronous.
6200 Set_Field
(Name_Asynchronous
,
6202 New_Occurrence_Of
(Asynch_P
, Loc
),
6203 New_Occurrence_Of
(Boolean_Literals
(
6204 Is_Asynchronous
(Ras_Type
)), Loc
)))));
6206 Append_List_To
(Proc_Statements
,
6207 Build_Get_Unique_RP_Call
(Loc
,
6208 Stub_Ptr
, Stub_Elements
.Stub_Type
));
6210 Append_To
(Proc_Statements
,
6211 Make_Return_Statement
(Loc
,
6213 Unchecked_Convert_To
(Fat_Type
,
6214 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
6217 Make_Function_Specification
(Loc
,
6218 Defining_Unit_Name
=> Proc
,
6219 Parameter_Specifications
=> New_List
(
6220 Make_Parameter_Specification
(Loc
,
6221 Defining_Identifier
=> Package_Name
,
6223 New_Occurrence_Of
(Standard_String
, Loc
)),
6225 Make_Parameter_Specification
(Loc
,
6226 Defining_Identifier
=> Subp_Id
,
6228 New_Occurrence_Of
(Standard_String
, Loc
)),
6230 Make_Parameter_Specification
(Loc
,
6231 Defining_Identifier
=> Asynch_P
,
6233 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6235 Make_Parameter_Specification
(Loc
,
6236 Defining_Identifier
=> All_Calls_Remote
,
6238 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
6240 Result_Definition
=>
6241 New_Occurrence_Of
(Fat_Type
, Loc
));
6243 -- Set the kind and return type of the function to prevent
6244 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6246 Set_Ekind
(Proc
, E_Function
);
6247 Set_Etype
(Proc
, Fat_Type
);
6250 Make_Subprogram_Body
(Loc
,
6251 Specification
=> Proc_Spec
,
6252 Declarations
=> Proc_Decls
,
6253 Handled_Statement_Sequence
=>
6254 Make_Handled_Sequence_Of_Statements
(Loc
,
6255 Statements
=> Proc_Statements
)));
6257 Set_TSS
(Fat_Type
, Proc
);
6258 end Add_RAS_Access_TSS
;
6260 ----------------------
6261 -- Add_RAS_From_Any --
6262 ----------------------
6264 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
) is
6265 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6267 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6268 Make_TSS_Name
(RAS_Type
, TSS_From_Any
));
6270 Func_Spec
: Node_Id
;
6272 Statements
: List_Id
;
6274 Any_Parameter
: constant Entity_Id
:=
6275 Make_Defining_Identifier
(Loc
, Name_A
);
6278 Statements
:= New_List
(
6279 Make_Return_Statement
(Loc
,
6281 Make_Aggregate
(Loc
,
6282 Component_Associations
=> New_List
(
6283 Make_Component_Association
(Loc
,
6284 Choices
=> New_List
(
6285 Make_Identifier
(Loc
, Name_Ras
)),
6287 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
6288 Underlying_RACW_Type
(RAS_Type
),
6289 New_Occurrence_Of
(Any_Parameter
, Loc
),
6293 Make_Function_Specification
(Loc
,
6294 Defining_Unit_Name
=>
6296 Parameter_Specifications
=> New_List
(
6297 Make_Parameter_Specification
(Loc
,
6298 Defining_Identifier
=>
6301 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
6302 Result_Definition
=> New_Occurrence_Of
(RAS_Type
, Loc
));
6305 Make_Subprogram_Body
(Loc
,
6306 Specification
=> Func_Spec
,
6307 Declarations
=> No_List
,
6308 Handled_Statement_Sequence
=>
6309 Make_Handled_Sequence_Of_Statements
(Loc
,
6310 Statements
=> Statements
)));
6311 Set_TSS
(RAS_Type
, Fnam
);
6312 end Add_RAS_From_Any
;
6314 --------------------
6315 -- Add_RAS_To_Any --
6316 --------------------
6318 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
) is
6319 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6321 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6322 Make_TSS_Name
(RAS_Type
, TSS_To_Any
));
6325 Statements
: List_Id
;
6327 Func_Spec
: Node_Id
;
6329 Any
: constant Entity_Id
:=
6330 Make_Defining_Identifier
(Loc
,
6331 Chars
=> New_Internal_Name
('A'));
6332 RAS_Parameter
: constant Entity_Id
:=
6333 Make_Defining_Identifier
(Loc
,
6334 Chars
=> New_Internal_Name
('R'));
6335 RACW_Parameter
: constant Node_Id
:=
6336 Make_Selected_Component
(Loc
,
6337 Prefix
=> RAS_Parameter
,
6338 Selector_Name
=> Name_Ras
);
6341 -- Object declarations
6343 Set_Etype
(RACW_Parameter
, Underlying_RACW_Type
(RAS_Type
));
6345 Make_Object_Declaration
(Loc
,
6346 Defining_Identifier
=>
6348 Object_Definition
=>
6349 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
6351 PolyORB_Support
.Helpers
.Build_To_Any_Call
6352 (RACW_Parameter
, No_List
)));
6354 Statements
:= New_List
(
6355 Make_Procedure_Call_Statement
(Loc
,
6357 New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
6358 Parameter_Associations
=> New_List
(
6359 New_Occurrence_Of
(Any
, Loc
),
6360 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
6362 Make_Return_Statement
(Loc
,
6364 New_Occurrence_Of
(Any
, Loc
)));
6367 Make_Function_Specification
(Loc
,
6368 Defining_Unit_Name
=>
6370 Parameter_Specifications
=> New_List
(
6371 Make_Parameter_Specification
(Loc
,
6372 Defining_Identifier
=>
6375 New_Occurrence_Of
(RAS_Type
, Loc
))),
6376 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
6379 Make_Subprogram_Body
(Loc
,
6380 Specification
=> Func_Spec
,
6381 Declarations
=> Decls
,
6382 Handled_Statement_Sequence
=>
6383 Make_Handled_Sequence_Of_Statements
(Loc
,
6384 Statements
=> Statements
)));
6385 Set_TSS
(RAS_Type
, Fnam
);
6388 ----------------------
6389 -- Add_RAS_TypeCode --
6390 ----------------------
6392 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
) is
6393 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6395 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6396 Make_TSS_Name
(RAS_Type
, TSS_TypeCode
));
6398 Func_Spec
: Node_Id
;
6400 Decls
: constant List_Id
:= New_List
;
6401 Name_String
, Repo_Id_String
: String_Id
;
6405 Make_Function_Specification
(Loc
,
6406 Defining_Unit_Name
=>
6408 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6410 PolyORB_Support
.Helpers
.Build_Name_And_Repository_Id
6411 (RAS_Type
, Name_Str
=> Name_String
, Repo_Id_Str
=> Repo_Id_String
);
6414 Make_Subprogram_Body
(Loc
,
6415 Specification
=> Func_Spec
,
6416 Declarations
=> Decls
,
6417 Handled_Statement_Sequence
=>
6418 Make_Handled_Sequence_Of_Statements
(Loc
,
6419 Statements
=> New_List
(
6420 Make_Return_Statement
(Loc
,
6422 Make_Function_Call
(Loc
,
6424 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
6425 Parameter_Associations
=> New_List
(
6426 New_Occurrence_Of
(RTE
(RE_TC_Object
), Loc
),
6427 Make_Aggregate
(Loc
,
6430 Make_Function_Call
(Loc
,
6431 Name
=> New_Occurrence_Of
(
6432 RTE
(RE_TA_String
), Loc
),
6433 Parameter_Associations
=> New_List
(
6434 Make_String_Literal
(Loc
, Name_String
))),
6435 Make_Function_Call
(Loc
,
6436 Name
=> New_Occurrence_Of
(
6437 RTE
(RE_TA_String
), Loc
),
6438 Parameter_Associations
=> New_List
(
6439 Make_String_Literal
(Loc
,
6440 Repo_Id_String
))))))))))));
6441 Set_TSS
(RAS_Type
, Fnam
);
6442 end Add_RAS_TypeCode
;
6444 -----------------------------------------
6445 -- Add_Receiving_Stubs_To_Declarations --
6446 -----------------------------------------
6448 procedure Add_Receiving_Stubs_To_Declarations
6449 (Pkg_Spec
: Node_Id
;
6452 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
6454 Pkg_RPC_Receiver
: constant Entity_Id
:=
6455 Make_Defining_Identifier
(Loc
,
6456 New_Internal_Name
('H'));
6457 Pkg_RPC_Receiver_Object
: Node_Id
;
6459 Pkg_RPC_Receiver_Body
: Node_Id
;
6460 Pkg_RPC_Receiver_Decls
: List_Id
;
6461 Pkg_RPC_Receiver_Statements
: List_Id
;
6462 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
6463 -- A Pkg_RPC_Receiver is built to decode the request
6466 -- Request object received from neutral layer
6468 Subp_Id
: Entity_Id
;
6469 -- Subprogram identifier as received from the neutral
6470 -- distribution core.
6472 Subp_Index
: Entity_Id
;
6473 -- Internal index as determined by matching either the
6474 -- method name from the request structure, or the local
6475 -- subprogram address (in case of a RAS).
6477 Is_Local
: constant Entity_Id
:=
6478 Make_Defining_Identifier
(Loc
, New_Internal_Name
('L'));
6479 Local_Address
: constant Entity_Id
:=
6480 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
6481 -- Address of a local subprogram designated by a
6482 -- reference corresponding to a RAS.
6484 Dispatch_On_Address
: constant List_Id
:= New_List
;
6485 Dispatch_On_Name
: constant List_Id
:= New_List
;
6487 Current_Declaration
: Node_Id
;
6488 Current_Stubs
: Node_Id
;
6489 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
6491 Subp_Info_Array
: constant Entity_Id
:=
6492 Make_Defining_Identifier
(Loc
,
6493 Chars
=> New_Internal_Name
('I'));
6495 Subp_Info_List
: constant List_Id
:= New_List
;
6497 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
6499 All_Calls_Remote_E
: Entity_Id
;
6501 procedure Append_Stubs_To
6502 (RPC_Receiver_Cases
: List_Id
;
6503 Declaration
: Node_Id
;
6506 Subp_Dist_Name
: Entity_Id
;
6507 Subp_Proxy_Addr
: Entity_Id
);
6508 -- Add one case to the specified RPC receiver case list associating
6509 -- Subprogram_Number with the subprogram declared by Declaration, for
6510 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6511 -- subprogram index. Subp_Dist_Name is the string used to call the
6512 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6513 -- object, used in the context of calls through remote
6514 -- access-to-subprogram types.
6516 ---------------------
6517 -- Append_Stubs_To --
6518 ---------------------
6520 procedure Append_Stubs_To
6521 (RPC_Receiver_Cases
: List_Id
;
6522 Declaration
: Node_Id
;
6525 Subp_Dist_Name
: Entity_Id
;
6526 Subp_Proxy_Addr
: Entity_Id
)
6528 Case_Stmts
: List_Id
;
6530 Case_Stmts
:= New_List
(
6531 Make_Procedure_Call_Statement
(Loc
,
6534 Defining_Entity
(Stubs
), Loc
),
6535 Parameter_Associations
=>
6536 New_List
(New_Occurrence_Of
(Request
, Loc
))));
6537 if Nkind
(Specification
(Declaration
))
6538 = N_Function_Specification
6540 Is_Asynchronous
(Defining_Entity
(Specification
(Declaration
)))
6542 Append_To
(Case_Stmts
, Make_Return_Statement
(Loc
));
6545 Append_To
(RPC_Receiver_Cases
,
6546 Make_Case_Statement_Alternative
(Loc
,
6548 New_List
(Make_Integer_Literal
(Loc
, Subp_Number
)),
6552 Append_To
(Dispatch_On_Name
,
6553 Make_Elsif_Part
(Loc
,
6555 Make_Function_Call
(Loc
,
6557 New_Occurrence_Of
(RTE
(RE_Caseless_String_Eq
), Loc
),
6558 Parameter_Associations
=> New_List
(
6559 New_Occurrence_Of
(Subp_Id
, Loc
),
6560 New_Occurrence_Of
(Subp_Dist_Name
, Loc
))),
6561 Then_Statements
=> New_List
(
6562 Make_Assignment_Statement
(Loc
,
6563 New_Occurrence_Of
(Subp_Index
, Loc
),
6564 Make_Integer_Literal
(Loc
,
6567 Append_To
(Dispatch_On_Address
,
6568 Make_Elsif_Part
(Loc
,
6572 New_Occurrence_Of
(Local_Address
, Loc
),
6574 New_Occurrence_Of
(Subp_Proxy_Addr
, Loc
)),
6575 Then_Statements
=> New_List
(
6576 Make_Assignment_Statement
(Loc
,
6577 New_Occurrence_Of
(Subp_Index
, Loc
),
6578 Make_Integer_Literal
(Loc
,
6580 end Append_Stubs_To
;
6582 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6585 -- Building receiving stubs consist in several operations:
6587 -- - a package RPC receiver must be built. This subprogram
6588 -- will get a Subprogram_Id from the incoming stream
6589 -- and will dispatch the call to the right subprogram
6591 -- - a receiving stub for any subprogram visible in the package
6592 -- spec. This stub will read all the parameters from the stream,
6593 -- and put the result as well as the exception occurrence in the
6596 -- - a dummy package with an empty spec and a body made of an
6597 -- elaboration part, whose job is to register the receiving
6598 -- part of this RCI package on the name server. This is done
6599 -- by calling System.Partition_Interface.Register_Receiving_Stub
6601 Build_RPC_Receiver_Body
(
6602 RPC_Receiver
=> Pkg_RPC_Receiver
,
6605 Subp_Index
=> Subp_Index
,
6606 Stmts
=> Pkg_RPC_Receiver_Statements
,
6607 Decl
=> Pkg_RPC_Receiver_Body
);
6608 Pkg_RPC_Receiver_Decls
:= Declarations
(Pkg_RPC_Receiver_Body
);
6610 -- Extract local address information from the target reference:
6611 -- if non-null, that means that this is a reference that denotes
6612 -- one particular operation, and hence that the operation name
6613 -- must not be taken into account for dispatching.
6615 Append_To
(Pkg_RPC_Receiver_Decls
,
6616 Make_Object_Declaration
(Loc
,
6617 Defining_Identifier
=>
6619 Object_Definition
=>
6620 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
6621 Append_To
(Pkg_RPC_Receiver_Decls
,
6622 Make_Object_Declaration
(Loc
,
6623 Defining_Identifier
=>
6625 Object_Definition
=>
6626 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6627 Append_To
(Pkg_RPC_Receiver_Statements
,
6628 Make_Procedure_Call_Statement
(Loc
,
6630 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6631 Parameter_Associations
=> New_List
(
6632 Make_Selected_Component
(Loc
,
6634 Selector_Name
=> Name_Target
),
6635 New_Occurrence_Of
(Is_Local
, Loc
),
6636 New_Occurrence_Of
(Local_Address
, Loc
))));
6638 -- Determine whether the reference that was used to make
6639 -- the call was the base RCI reference (in which case
6640 -- Local_Address is 0, and the method identifier from the
6641 -- request must be used to determine which subprogram is
6642 -- called) or a reference identifying one particular subprogram
6643 -- (in which case Local_Address is the address of that
6644 -- subprogram, and the method name from the request is
6646 -- In each case, cascaded elsifs are used to determine the
6647 -- proper subprogram index. Using hash tables might be
6650 Append_To
(Pkg_RPC_Receiver_Statements
,
6651 Make_Implicit_If_Statement
(Pkg_Spec
,
6654 Left_Opnd
=> New_Occurrence_Of
(Local_Address
, Loc
),
6655 Right_Opnd
=> New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)),
6656 Then_Statements
=> New_List
(
6657 Make_Implicit_If_Statement
(Pkg_Spec
,
6659 New_Occurrence_Of
(Standard_False
, Loc
),
6660 Then_Statements
=> New_List
(
6661 Make_Null_Statement
(Loc
)),
6663 Dispatch_On_Address
)),
6664 Else_Statements
=> New_List
(
6665 Make_Implicit_If_Statement
(Pkg_Spec
,
6667 New_Occurrence_Of
(Standard_False
, Loc
),
6668 Then_Statements
=> New_List
(
6669 Make_Null_Statement
(Loc
)),
6671 Dispatch_On_Name
))));
6673 -- For each subprogram, the receiving stub will be built and a
6674 -- case statement will be made on the Subprogram_Id to dispatch
6675 -- to the right subprogram.
6677 All_Calls_Remote_E
:= Boolean_Literals
(
6678 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
6680 Overload_Counter_Table
.Reset
;
6681 Reserve_NamingContext_Methods
;
6683 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
6684 while Present
(Current_Declaration
) loop
6685 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
6686 and then Comes_From_Source
(Current_Declaration
)
6689 Loc
: constant Source_Ptr
:=
6690 Sloc
(Current_Declaration
);
6691 -- While specifically processing Current_Declaration, use
6692 -- its Sloc as the location of all generated nodes.
6694 Subp_Def
: constant Entity_Id
:=
6696 (Specification
(Current_Declaration
));
6698 Subp_Val
: String_Id
;
6700 Subp_Dist_Name
: constant Entity_Id
:=
6701 Make_Defining_Identifier
(Loc
,
6703 Related_Id
=> Chars
(Subp_Def
),
6705 Suffix_Index
=> -1));
6707 Proxy_Object_Addr
: Entity_Id
;
6710 pragma Assert
(Current_Subprogram_Number
=
6711 Get_Subprogram_Id
(Subp_Def
));
6713 -- Build receiving stub
6716 Build_Subprogram_Receiving_Stubs
6717 (Vis_Decl
=> Current_Declaration
,
6719 Nkind
(Specification
(Current_Declaration
)) =
6720 N_Procedure_Specification
6721 and then Is_Asynchronous
(Subp_Def
));
6723 Append_To
(Decls
, Current_Stubs
);
6724 Analyze
(Current_Stubs
);
6728 Add_RAS_Proxy_And_Analyze
(Decls
,
6730 Current_Declaration
,
6731 All_Calls_Remote_E
=>
6733 Proxy_Object_Addr
=>
6736 -- Compute distribution identifier
6738 Assign_Subprogram_Identifier
(
6740 Current_Subprogram_Number
,
6744 Make_Object_Declaration
(Loc
,
6745 Defining_Identifier
=> Subp_Dist_Name
,
6746 Constant_Present
=> True,
6747 Object_Definition
=> New_Occurrence_Of
(
6748 Standard_String
, Loc
),
6750 Make_String_Literal
(Loc
, Subp_Val
)));
6751 Analyze
(Last
(Decls
));
6753 -- Add subprogram descriptor (RCI_Subp_Info) to the
6754 -- subprograms table for this receiver. The aggregate
6755 -- below must be kept consistent with the declaration
6756 -- of type RCI_Subp_Info in System.Partition_Interface.
6758 Append_To
(Subp_Info_List
,
6759 Make_Component_Association
(Loc
,
6760 Choices
=> New_List
(
6761 Make_Integer_Literal
(Loc
,
6762 Current_Subprogram_Number
)),
6764 Make_Aggregate
(Loc
,
6765 Expressions
=> New_List
(
6766 Make_Attribute_Reference
(Loc
,
6769 Subp_Dist_Name
, Loc
),
6770 Attribute_Name
=> Name_Address
),
6771 Make_Attribute_Reference
(Loc
,
6774 Subp_Dist_Name
, Loc
),
6775 Attribute_Name
=> Name_Length
),
6776 New_Occurrence_Of
(Proxy_Object_Addr
, Loc
)))));
6778 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
6779 Declaration
=> Current_Declaration
,
6780 Stubs
=> Current_Stubs
,
6781 Subp_Number
=> Current_Subprogram_Number
,
6782 Subp_Dist_Name
=> Subp_Dist_Name
,
6783 Subp_Proxy_Addr
=> Proxy_Object_Addr
);
6786 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
6789 Next
(Current_Declaration
);
6792 -- If we receive an invalid Subprogram_Id, it is best to do nothing
6793 -- rather than raising an exception since we do not want someone
6794 -- to crash a remote partition by sending invalid subprogram ids.
6795 -- This is consistent with the other parts of the case statement
6796 -- since even in presence of incorrect parameters in the stream,
6797 -- every exception will be caught and (if the subprogram is not an
6798 -- APC) put into the result stream and sent away.
6800 Append_To
(Pkg_RPC_Receiver_Cases
,
6801 Make_Case_Statement_Alternative
(Loc
,
6803 New_List
(Make_Others_Choice
(Loc
)),
6805 New_List
(Make_Null_Statement
(Loc
))));
6807 Append_To
(Pkg_RPC_Receiver_Statements
,
6808 Make_Case_Statement
(Loc
,
6810 New_Occurrence_Of
(Subp_Index
, Loc
),
6811 Alternatives
=> Pkg_RPC_Receiver_Cases
));
6814 Make_Object_Declaration
(Loc
,
6815 Defining_Identifier
=> Subp_Info_Array
,
6816 Constant_Present
=> True,
6817 Aliased_Present
=> True,
6818 Object_Definition
=>
6819 Make_Subtype_Indication
(Loc
,
6821 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
6823 Make_Index_Or_Discriminant_Constraint
(Loc
,
6826 Low_Bound
=> Make_Integer_Literal
(Loc
,
6827 First_RCI_Subprogram_Id
),
6829 Make_Integer_Literal
(Loc
,
6830 First_RCI_Subprogram_Id
6831 + List_Length
(Subp_Info_List
) - 1))))),
6833 Make_Aggregate
(Loc
,
6834 Component_Associations
=> Subp_Info_List
)));
6835 Analyze
(Last
(Decls
));
6837 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
6838 Analyze
(Last
(Decls
));
6840 Pkg_RPC_Receiver_Object
:=
6841 Make_Object_Declaration
(Loc
,
6842 Defining_Identifier
=>
6843 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
6844 Aliased_Present
=> True,
6845 Object_Definition
=>
6846 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
6847 Append_To
(Decls
, Pkg_RPC_Receiver_Object
);
6848 Analyze
(Last
(Decls
));
6850 Get_Library_Unit_Name_String
(Pkg_Spec
);
6851 Append_To
(Register_Pkg_Actuals
,
6853 Make_String_Literal
(Loc
,
6854 Strval
=> String_From_Name_Buffer
));
6856 Append_To
(Register_Pkg_Actuals
,
6858 Make_Attribute_Reference
(Loc
,
6861 (Defining_Entity
(Pkg_Spec
), Loc
),
6865 Append_To
(Register_Pkg_Actuals
,
6867 Make_Attribute_Reference
(Loc
,
6869 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
6870 Attribute_Name
=> Name_Access
));
6872 Append_To
(Register_Pkg_Actuals
,
6874 Make_Attribute_Reference
(Loc
,
6877 Defining_Identifier
(
6878 Pkg_RPC_Receiver_Object
), Loc
),
6882 Append_To
(Register_Pkg_Actuals
,
6884 Make_Attribute_Reference
(Loc
,
6886 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
6890 Append_To
(Register_Pkg_Actuals
,
6892 Make_Attribute_Reference
(Loc
,
6894 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
6898 Append_To
(Register_Pkg_Actuals
,
6899 -- Is_All_Calls_Remote
6900 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
));
6903 Make_Procedure_Call_Statement
(Loc
,
6905 New_Occurrence_Of
(RTE
(RE_Register_Pkg_Receiving_Stub
), Loc
),
6906 Parameter_Associations
=> Register_Pkg_Actuals
));
6907 Analyze
(Last
(Decls
));
6909 end Add_Receiving_Stubs_To_Declarations
;
6911 ---------------------------------
6912 -- Build_General_Calling_Stubs --
6913 ---------------------------------
6915 procedure Build_General_Calling_Stubs
6917 Statements
: List_Id
;
6918 Target_Object
: Node_Id
;
6919 Subprogram_Id
: Node_Id
;
6920 Asynchronous
: Node_Id
:= Empty
;
6921 Is_Known_Asynchronous
: Boolean := False;
6922 Is_Known_Non_Asynchronous
: Boolean := False;
6923 Is_Function
: Boolean;
6925 Stub_Type
: Entity_Id
:= Empty
;
6926 RACW_Type
: Entity_Id
:= Empty
;
6929 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
6931 Arguments
: Node_Id
;
6932 -- Name of the named values list used to transmit parameters
6933 -- to the remote package
6936 -- The request object constructed by these stubs
6939 -- Name of the result named value (in non-APC cases) which get the
6940 -- result of the remote subprogram.
6942 Result_TC
: Node_Id
;
6943 -- Typecode expression for the result of the request (void
6944 -- typecode for procedures).
6946 Exception_Return_Parameter
: Node_Id
;
6947 -- Name of the parameter which will hold the exception sent by the
6948 -- remote subprogram.
6950 Current_Parameter
: Node_Id
;
6951 -- Current parameter being handled
6953 Ordered_Parameters_List
: constant List_Id
:=
6954 Build_Ordered_Parameters_List
(Spec
);
6956 Asynchronous_P
: Node_Id
;
6957 -- A Boolean expression indicating whether this call is asynchronous
6959 Asynchronous_Statements
: List_Id
:= No_List
;
6960 Non_Asynchronous_Statements
: List_Id
:= No_List
;
6961 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
6963 Extra_Formal_Statements
: constant List_Id
:= New_List
;
6964 -- List of statements for extra formal parameters. It will appear
6965 -- after the regular statements for writing out parameters.
6967 After_Statements
: constant List_Id
:= New_List
;
6968 -- Statements to be executed after call returns (to assign
6969 -- in out or out parameter values).
6972 -- The type of the formal parameter being processed
6974 Is_Controlling_Formal
: Boolean;
6975 Is_First_Controlling_Formal
: Boolean;
6976 First_Controlling_Formal_Seen
: Boolean := False;
6977 -- Controlling formal parameters of distributed object
6978 -- primitives require special handling, and the first
6979 -- such parameter needs even more.
6982 -- ??? document general form of stub subprograms for the PolyORB case
6984 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
6987 Make_Object_Declaration
(Loc
,
6988 Defining_Identifier
=> Request
,
6989 Aliased_Present
=> False,
6990 Object_Definition
=>
6991 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
)));
6994 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
6997 Result_TC
:= PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
6998 Etype
(Result_Definition
(Spec
)), Decls
);
7000 Result_TC
:= New_Occurrence_Of
(RTE
(RE_TC_Void
), Loc
);
7004 Make_Object_Declaration
(Loc
,
7005 Defining_Identifier
=> Result
,
7006 Aliased_Present
=> False,
7007 Object_Definition
=>
7008 New_Occurrence_Of
(RTE
(RE_NamedValue
), Loc
),
7010 Make_Aggregate
(Loc
,
7011 Component_Associations
=> New_List
(
7012 Make_Component_Association
(Loc
,
7013 Choices
=> New_List
(
7014 Make_Identifier
(Loc
, Name_Name
)),
7016 New_Occurrence_Of
(RTE
(RE_Result_Name
), Loc
)),
7017 Make_Component_Association
(Loc
,
7018 Choices
=> New_List
(
7019 Make_Identifier
(Loc
, Name_Argument
)),
7021 Make_Function_Call
(Loc
,
7023 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7024 Parameter_Associations
=> New_List
(
7026 Make_Component_Association
(Loc
,
7027 Choices
=> New_List
(
7028 Make_Identifier
(Loc
, Name_Arg_Modes
)),
7030 Make_Integer_Literal
(Loc
, 0))))));
7032 if not Is_Known_Asynchronous
then
7033 Exception_Return_Parameter
:=
7034 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
7037 Make_Object_Declaration
(Loc
,
7038 Defining_Identifier
=> Exception_Return_Parameter
,
7039 Object_Definition
=>
7040 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
7043 Exception_Return_Parameter
:= Empty
;
7046 -- Initialize and fill in arguments list
7049 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
7050 Declare_Create_NVList
(Loc
, Arguments
, Decls
, Statements
);
7052 Current_Parameter
:= First
(Ordered_Parameters_List
);
7053 while Present
(Current_Parameter
) loop
7055 if Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
) then
7056 Is_Controlling_Formal
:= True;
7057 Is_First_Controlling_Formal
:=
7058 not First_Controlling_Formal_Seen
;
7059 First_Controlling_Formal_Seen
:= True;
7061 Is_Controlling_Formal
:= False;
7062 Is_First_Controlling_Formal
:= False;
7065 if Is_Controlling_Formal
then
7067 -- In the case of a controlling formal argument, we send
7073 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7076 -- The first controlling formal parameter is treated
7077 -- specially: it is used to set the target object of
7080 if not Is_First_Controlling_Formal
then
7083 Constrained
: constant Boolean :=
7084 Is_Constrained
(Etyp
)
7085 or else Is_Elementary_Type
(Etyp
);
7087 Any
: constant Entity_Id
:=
7088 Make_Defining_Identifier
(Loc
,
7089 New_Internal_Name
('A'));
7091 Actual_Parameter
: Node_Id
:=
7093 Defining_Identifier
(
7094 Current_Parameter
), Loc
);
7099 if Is_Controlling_Formal
then
7101 -- For a controlling formal parameter (other
7102 -- than the first one), use the corresponding
7103 -- RACW. If the parameter is not an anonymous
7104 -- access parameter, that involves taking
7105 -- its 'Unrestricted_Access.
7107 if Nkind
(Parameter_Type
(Current_Parameter
))
7108 = N_Access_Definition
7110 Actual_Parameter
:= OK_Convert_To
7111 (Etyp
, Actual_Parameter
);
7113 Actual_Parameter
:= OK_Convert_To
(Etyp
,
7114 Make_Attribute_Reference
(Loc
,
7118 Name_Unrestricted_Access
));
7123 if In_Present
(Current_Parameter
)
7124 or else not Out_Present
(Current_Parameter
)
7125 or else not Constrained
7126 or else Is_Controlling_Formal
7128 -- The parameter has an input value, is constrained
7129 -- at runtime by an input value, or is a controlling
7130 -- formal parameter (always passed as a reference)
7131 -- other than the first one.
7133 Expr
:= PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7134 Actual_Parameter
, Decls
);
7136 Expr
:= Make_Function_Call
(Loc
,
7138 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7139 Parameter_Associations
=> New_List
(
7140 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
7145 Make_Object_Declaration
(Loc
,
7146 Defining_Identifier
=>
7148 Aliased_Present
=> False,
7149 Object_Definition
=>
7150 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7154 Append_To
(Statements
,
7155 Add_Parameter_To_NVList
(Loc
,
7156 Parameter
=> Current_Parameter
,
7157 NVList
=> Arguments
,
7158 Constrained
=> Constrained
,
7161 if Out_Present
(Current_Parameter
)
7162 and then not Is_Controlling_Formal
7164 Append_To
(After_Statements
,
7165 Make_Assignment_Statement
(Loc
,
7168 Defining_Identifier
(Current_Parameter
), Loc
),
7170 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7171 Etype
(Parameter_Type
(Current_Parameter
)),
7172 New_Occurrence_Of
(Any
, Loc
),
7179 -- If the current parameter has a dynamic constrained status,
7180 -- then this status is transmitted as well.
7181 -- This should be done for accessibility as well ???
7183 if Nkind
(Parameter_Type
(Current_Parameter
))
7184 /= N_Access_Definition
7185 and then Need_Extra_Constrained
(Current_Parameter
)
7187 -- In this block, we do not use the extra formal that has been
7188 -- created because it does not exist at the time of expansion
7189 -- when building calling stubs for remote access to subprogram
7190 -- types. We create an extra variable of this type and push it
7191 -- in the stream after the regular parameters.
7194 Extra_Any_Parameter
: constant Entity_Id
:=
7195 Make_Defining_Identifier
7196 (Loc
, New_Internal_Name
('P'));
7200 Make_Object_Declaration
(Loc
,
7201 Defining_Identifier
=>
7202 Extra_Any_Parameter
,
7203 Aliased_Present
=> False,
7204 Object_Definition
=>
7205 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7207 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7208 Make_Attribute_Reference
(Loc
,
7211 Defining_Identifier
(Current_Parameter
), Loc
),
7212 Attribute_Name
=> Name_Constrained
),
7214 Append_To
(Extra_Formal_Statements
,
7215 Add_Parameter_To_NVList
(Loc
,
7216 Parameter
=> Extra_Any_Parameter
,
7217 NVList
=> Arguments
,
7218 Constrained
=> True,
7219 Any
=> Extra_Any_Parameter
));
7223 Next
(Current_Parameter
);
7226 -- Append the formal statements list to the statements
7228 Append_List_To
(Statements
, Extra_Formal_Statements
);
7230 Append_To
(Statements
,
7231 Make_Procedure_Call_Statement
(Loc
,
7233 New_Occurrence_Of
(RTE
(RE_Request_Create
), Loc
),
7234 Parameter_Associations
=> New_List
(
7237 New_Occurrence_Of
(Arguments
, Loc
),
7238 New_Occurrence_Of
(Result
, Loc
),
7239 New_Occurrence_Of
(RTE
(RE_Nil_Exc_List
), Loc
))));
7241 Append_To
(Parameter_Associations
(Last
(Statements
)),
7242 New_Occurrence_Of
(Request
, Loc
));
7245 not (Is_Known_Non_Asynchronous
and Is_Known_Asynchronous
));
7246 if Is_Known_Non_Asynchronous
or Is_Known_Asynchronous
then
7247 Asynchronous_P
:= New_Occurrence_Of
(
7248 Boolean_Literals
(Is_Known_Asynchronous
), Loc
);
7250 pragma Assert
(Present
(Asynchronous
));
7251 Asynchronous_P
:= New_Copy_Tree
(Asynchronous
);
7252 -- The expression node Asynchronous will be used to build
7253 -- an 'if' statement at the end of Build_General_Calling_Stubs:
7254 -- we need to make a copy here.
7257 Append_To
(Parameter_Associations
(Last
(Statements
)),
7258 Make_Indexed_Component
(Loc
,
7261 RTE
(RE_Asynchronous_P_To_Sync_Scope
), Loc
),
7262 Expressions
=> New_List
(Asynchronous_P
)));
7264 Append_To
(Statements
,
7265 Make_Procedure_Call_Statement
(Loc
,
7267 New_Occurrence_Of
(RTE
(RE_Request_Invoke
), Loc
),
7268 Parameter_Associations
=> New_List
(
7269 New_Occurrence_Of
(Request
, Loc
))));
7271 Non_Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7272 Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7274 if not Is_Known_Asynchronous
then
7276 -- Reraise an exception occurrence from the completed request.
7277 -- If the exception occurrence is empty, this is a no-op.
7279 Append_To
(Non_Asynchronous_Statements
,
7280 Make_Procedure_Call_Statement
(Loc
,
7282 New_Occurrence_Of
(RTE
(RE_Request_Raise_Occurrence
), Loc
),
7283 Parameter_Associations
=> New_List
(
7284 New_Occurrence_Of
(Request
, Loc
))));
7288 -- If this is a function call, then read the value and
7291 Append_To
(Non_Asynchronous_Statements
,
7292 Make_Tag_Check
(Loc
,
7293 Make_Return_Statement
(Loc
,
7294 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7295 Etype
(Result_Definition
(Spec
)),
7296 Make_Selected_Component
(Loc
,
7298 Selector_Name
=> Name_Argument
),
7303 Append_List_To
(Non_Asynchronous_Statements
,
7306 if Is_Known_Asynchronous
then
7307 Append_List_To
(Statements
, Asynchronous_Statements
);
7309 elsif Is_Known_Non_Asynchronous
then
7310 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
7313 pragma Assert
(Present
(Asynchronous
));
7314 Append_To
(Statements
,
7315 Make_Implicit_If_Statement
(Nod
,
7316 Condition
=> Asynchronous
,
7317 Then_Statements
=> Asynchronous_Statements
,
7318 Else_Statements
=> Non_Asynchronous_Statements
));
7320 end Build_General_Calling_Stubs
;
7322 -----------------------
7323 -- Build_Stub_Target --
7324 -----------------------
7326 function Build_Stub_Target
7329 RCI_Locator
: Entity_Id
;
7330 Controlling_Parameter
: Entity_Id
) return RPC_Target
7332 Target_Info
: RPC_Target
(PCS_Kind
=> Name_PolyORB_DSA
);
7333 Target_Reference
: constant Entity_Id
:=
7334 Make_Defining_Identifier
(Loc
,
7335 New_Internal_Name
('T'));
7337 if Present
(Controlling_Parameter
) then
7339 Make_Object_Declaration
(Loc
,
7340 Defining_Identifier
=> Target_Reference
,
7341 Object_Definition
=>
7342 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
7344 Make_Function_Call
(Loc
,
7346 New_Occurrence_Of
(RTE
(RE_Make_Ref
), Loc
),
7347 Parameter_Associations
=> New_List
(
7348 Make_Selected_Component
(Loc
,
7349 Prefix
=> Controlling_Parameter
,
7350 Selector_Name
=> Name_Target
)))));
7351 -- Controlling_Parameter has the same components
7352 -- as System.Partition_Interface.RACW_Stub_Type.
7354 Target_Info
.Object
:= New_Occurrence_Of
(Target_Reference
, Loc
);
7357 Target_Info
.Object
:=
7358 Make_Selected_Component
(Loc
,
7360 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
7362 Make_Identifier
(Loc
, Name_Get_RCI_Package_Ref
));
7365 end Build_Stub_Target
;
7367 ---------------------
7368 -- Build_Stub_Type --
7369 ---------------------
7371 procedure Build_Stub_Type
7372 (RACW_Type
: Entity_Id
;
7373 Stub_Type
: Entity_Id
;
7374 Stub_Type_Decl
: out Node_Id
;
7375 RPC_Receiver_Decl
: out Node_Id
)
7377 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
7378 pragma Warnings
(Off
);
7379 pragma Unreferenced
(RACW_Type
);
7380 pragma Warnings
(On
);
7384 Make_Full_Type_Declaration
(Loc
,
7385 Defining_Identifier
=> Stub_Type
,
7387 Make_Record_Definition
(Loc
,
7388 Tagged_Present
=> True,
7389 Limited_Present
=> True,
7391 Make_Component_List
(Loc
,
7392 Component_Items
=> New_List
(
7394 Make_Component_Declaration
(Loc
,
7395 Defining_Identifier
=>
7396 Make_Defining_Identifier
(Loc
, Name_Target
),
7397 Component_Definition
=>
7398 Make_Component_Definition
(Loc
,
7401 Subtype_Indication
=>
7402 New_Occurrence_Of
(RTE
(RE_Entity_Ptr
), Loc
))),
7404 Make_Component_Declaration
(Loc
,
7405 Defining_Identifier
=>
7406 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
7407 Component_Definition
=>
7408 Make_Component_Definition
(Loc
,
7409 Aliased_Present
=> False,
7410 Subtype_Indication
=>
7412 Standard_Boolean
, Loc
)))))));
7414 RPC_Receiver_Decl
:=
7415 Make_Object_Declaration
(Loc
,
7416 Defining_Identifier
=> Make_Defining_Identifier
(Loc
,
7417 New_Internal_Name
('R')),
7418 Aliased_Present
=> True,
7419 Object_Definition
=>
7420 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7421 end Build_Stub_Type
;
7423 -----------------------------
7424 -- Build_RPC_Receiver_Body --
7425 -----------------------------
7427 procedure Build_RPC_Receiver_Body
7428 (RPC_Receiver
: Entity_Id
;
7429 Request
: out Entity_Id
;
7430 Subp_Id
: out Entity_Id
;
7431 Subp_Index
: out Entity_Id
;
7432 Stmts
: out List_Id
;
7435 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
7437 RPC_Receiver_Spec
: Node_Id
;
7438 RPC_Receiver_Decls
: List_Id
;
7441 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
7443 RPC_Receiver_Spec
:=
7444 Build_RPC_Receiver_Specification
(
7445 RPC_Receiver
=> RPC_Receiver
,
7446 Request_Parameter
=> Request
);
7448 Subp_Id
:= Make_Defining_Identifier
(Loc
, Name_P
);
7449 Subp_Index
:= Make_Defining_Identifier
(Loc
, Name_I
);
7451 RPC_Receiver_Decls
:= New_List
(
7452 Make_Object_Renaming_Declaration
(Loc
,
7453 Defining_Identifier
=> Subp_Id
,
7454 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
7456 Make_Explicit_Dereference
(Loc
,
7458 Make_Selected_Component
(Loc
,
7460 Selector_Name
=> Name_Operation
))),
7462 Make_Object_Declaration
(Loc
,
7463 Defining_Identifier
=> Subp_Index
,
7464 Object_Definition
=>
7465 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7467 Make_Attribute_Reference
(Loc
,
7469 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7470 Attribute_Name
=> Name_Last
)));
7475 Make_Subprogram_Body
(Loc
,
7476 Specification
=> RPC_Receiver_Spec
,
7477 Declarations
=> RPC_Receiver_Decls
,
7478 Handled_Statement_Sequence
=>
7479 Make_Handled_Sequence_Of_Statements
(Loc
,
7480 Statements
=> Stmts
));
7481 end Build_RPC_Receiver_Body
;
7483 --------------------------------------
7484 -- Build_Subprogram_Receiving_Stubs --
7485 --------------------------------------
7487 function Build_Subprogram_Receiving_Stubs
7488 (Vis_Decl
: Node_Id
;
7489 Asynchronous
: Boolean;
7490 Dynamically_Asynchronous
: Boolean := False;
7491 Stub_Type
: Entity_Id
:= Empty
;
7492 RACW_Type
: Entity_Id
:= Empty
;
7493 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
7495 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
7497 Request_Parameter
: Node_Id
;
7500 Outer_Decls
: constant List_Id
:= New_List
;
7501 -- At the outermost level, an NVList and Any's are
7502 -- declared for all parameters. The Dynamic_Async
7503 -- flag also needs to be declared there to be visible
7504 -- from the exception handling code.
7506 Outer_Statements
: constant List_Id
:= New_List
;
7507 -- Statements that occur prior to the declaration of the actual
7508 -- parameter variables.
7510 Decls
: constant List_Id
:= New_List
;
7511 -- All the parameters will get declared before calling the real
7512 -- subprograms. Also the out parameters will be declared.
7513 -- At this level, parameters may be unconstrained.
7515 Statements
: constant List_Id
:= New_List
;
7517 Extra_Formal_Statements
: constant List_Id
:= New_List
;
7518 -- Statements concerning extra formal parameters
7520 After_Statements
: constant List_Id
:= New_List
;
7521 -- Statements to be executed after the subprogram call
7523 Inner_Decls
: List_Id
:= No_List
;
7524 -- In case of a function, the inner declarations are needed since
7525 -- the result may be unconstrained.
7527 Excep_Handlers
: List_Id
:= No_List
;
7529 Parameter_List
: constant List_Id
:= New_List
;
7530 -- List of parameters to be passed to the subprogram
7532 First_Controlling_Formal_Seen
: Boolean := False;
7534 Current_Parameter
: Node_Id
;
7536 Ordered_Parameters_List
: constant List_Id
:=
7537 Build_Ordered_Parameters_List
7538 (Specification
(Vis_Decl
));
7540 Arguments
: Node_Id
;
7541 -- Name of the named values list used to retrieve parameters
7543 Subp_Spec
: Node_Id
;
7544 -- Subprogram specification
7546 Called_Subprogram
: Node_Id
;
7547 -- The subprogram to call
7550 if Present
(RACW_Type
) then
7551 Called_Subprogram
:=
7552 New_Occurrence_Of
(Parent_Primitive
, Loc
);
7554 Called_Subprogram
:=
7556 Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
7559 Request_Parameter
:=
7560 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
7563 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
7564 Declare_Create_NVList
(Loc
, Arguments
, Outer_Decls
, Outer_Statements
);
7566 -- Loop through every parameter and get its value from the stream. If
7567 -- the parameter is unconstrained, then the parameter is read using
7568 -- 'Input at the point of declaration.
7570 Current_Parameter
:= First
(Ordered_Parameters_List
);
7571 while Present
(Current_Parameter
) loop
7574 Constrained
: Boolean;
7575 Any
: Entity_Id
:= Empty
;
7576 Object
: constant Entity_Id
:=
7577 Make_Defining_Identifier
(Loc
,
7578 New_Internal_Name
('P'));
7579 Expr
: Node_Id
:= Empty
;
7581 Is_Controlling_Formal
: constant Boolean
7582 := Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
);
7584 Is_First_Controlling_Formal
: Boolean := False;
7586 Set_Ekind
(Object
, E_Variable
);
7588 if Is_Controlling_Formal
then
7590 -- Controlling formals in distributed object primitive
7591 -- operations are handled specially:
7592 -- - the first controlling formal is used as the
7593 -- target of the call;
7594 -- - the remaining controlling formals are transmitted
7598 Is_First_Controlling_Formal
:=
7599 not First_Controlling_Formal_Seen
;
7600 First_Controlling_Formal_Seen
:= True;
7602 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7606 Is_Constrained
(Etyp
)
7607 or else Is_Elementary_Type
(Etyp
);
7609 if not Is_First_Controlling_Formal
then
7610 Any
:= Make_Defining_Identifier
(Loc
,
7611 New_Internal_Name
('A'));
7612 Append_To
(Outer_Decls
,
7613 Make_Object_Declaration
(Loc
,
7614 Defining_Identifier
=>
7616 Object_Definition
=>
7617 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7619 Make_Function_Call
(Loc
,
7621 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7622 Parameter_Associations
=> New_List
(
7623 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
7624 Etyp
, Outer_Decls
)))));
7626 Append_To
(Outer_Statements
,
7627 Add_Parameter_To_NVList
(Loc
,
7628 Parameter
=> Current_Parameter
,
7629 NVList
=> Arguments
,
7630 Constrained
=> Constrained
,
7634 if Is_First_Controlling_Formal
then
7636 Addr
: constant Entity_Id
:=
7637 Make_Defining_Identifier
(Loc
,
7638 New_Internal_Name
('A'));
7639 Is_Local
: constant Entity_Id
:=
7640 Make_Defining_Identifier
(Loc
,
7641 New_Internal_Name
('L'));
7644 -- Special case: obtain the first controlling
7645 -- formal from the target of the remote call,
7646 -- instead of the argument list.
7648 Append_To
(Outer_Decls
,
7649 Make_Object_Declaration
(Loc
,
7650 Defining_Identifier
=>
7652 Object_Definition
=>
7653 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
7654 Append_To
(Outer_Decls
,
7655 Make_Object_Declaration
(Loc
,
7656 Defining_Identifier
=>
7658 Object_Definition
=>
7659 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7660 Append_To
(Outer_Statements
,
7661 Make_Procedure_Call_Statement
(Loc
,
7664 RTE
(RE_Get_Local_Address
), Loc
),
7665 Parameter_Associations
=> New_List
(
7666 Make_Selected_Component
(Loc
,
7669 Request_Parameter
, Loc
),
7671 Make_Identifier
(Loc
, Name_Target
)),
7672 New_Occurrence_Of
(Is_Local
, Loc
),
7673 New_Occurrence_Of
(Addr
, Loc
))));
7675 Expr
:= Unchecked_Convert_To
(RACW_Type
,
7676 New_Occurrence_Of
(Addr
, Loc
));
7679 elsif In_Present
(Current_Parameter
)
7680 or else not Out_Present
(Current_Parameter
)
7681 or else not Constrained
7683 -- If an input parameter is contrained, then its reading is
7684 -- deferred until the beginning of the subprogram body. If
7685 -- it is unconstrained, then an expression is built for
7686 -- the object declaration and the variable is set using
7687 -- 'Input instead of 'Read.
7689 Expr
:= PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7690 Etyp
, New_Occurrence_Of
(Any
, Loc
), Decls
);
7694 Append_To
(Statements
,
7695 Make_Assignment_Statement
(Loc
,
7697 New_Occurrence_Of
(Object
, Loc
),
7703 -- Expr will be used to initialize (and constrain)
7704 -- the parameter when it is declared.
7709 -- If we do not have to output the current parameter, then
7710 -- it can well be flagged as constant. This may allow further
7711 -- optimizations done by the back end.
7714 Make_Object_Declaration
(Loc
,
7715 Defining_Identifier
=> Object
,
7716 Constant_Present
=> not Constrained
7717 and then not Out_Present
(Current_Parameter
),
7718 Object_Definition
=>
7719 New_Occurrence_Of
(Etyp
, Loc
),
7720 Expression
=> Expr
));
7721 Set_Etype
(Object
, Etyp
);
7723 -- An out parameter may be written back using a 'Write
7724 -- attribute instead of a 'Output because it has been
7725 -- constrained by the parameter given to the caller. Note that
7726 -- out controlling arguments in the case of a RACW are not put
7727 -- back in the stream because the pointer on them has not
7730 if Out_Present
(Current_Parameter
)
7731 and then not Is_Controlling_Formal
7733 Append_To
(After_Statements
,
7734 Make_Procedure_Call_Statement
(Loc
,
7736 New_Occurrence_Of
(RTE
(RE_Copy_Any_Value
), Loc
),
7737 Parameter_Associations
=> New_List
(
7738 New_Occurrence_Of
(Any
, Loc
),
7739 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7740 New_Occurrence_Of
(Object
, Loc
),
7744 -- For RACW controlling formals, the Etyp of Object is always
7745 -- an RACW, even if the parameter is not of an anonymous access
7746 -- type. In such case, we need to dereference it at call time.
7748 if Is_Controlling_Formal
then
7749 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7752 Append_To
(Parameter_List
,
7753 Make_Parameter_Association
(Loc
,
7756 Defining_Identifier
(Current_Parameter
), Loc
),
7757 Explicit_Actual_Parameter
=>
7758 Make_Explicit_Dereference
(Loc
,
7759 Unchecked_Convert_To
(RACW_Type
,
7760 OK_Convert_To
(RTE
(RE_Address
),
7761 New_Occurrence_Of
(Object
, Loc
))))));
7764 Append_To
(Parameter_List
,
7765 Make_Parameter_Association
(Loc
,
7768 Defining_Identifier
(Current_Parameter
), Loc
),
7769 Explicit_Actual_Parameter
=>
7770 Unchecked_Convert_To
(RACW_Type
,
7771 OK_Convert_To
(RTE
(RE_Address
),
7772 New_Occurrence_Of
(Object
, Loc
)))));
7776 Append_To
(Parameter_List
,
7777 Make_Parameter_Association
(Loc
,
7780 Defining_Identifier
(Current_Parameter
), Loc
),
7781 Explicit_Actual_Parameter
=>
7782 New_Occurrence_Of
(Object
, Loc
)));
7785 -- If the current parameter needs an extra formal, then read it
7786 -- from the stream and set the corresponding semantic field in
7787 -- the variable. If the kind of the parameter identifier is
7788 -- E_Void, then this is a compiler generated parameter that
7789 -- doesn't need an extra constrained status.
7791 -- The case of Extra_Accessibility should also be handled ???
7793 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7796 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
7798 Present
(Extra_Constrained
7799 (Defining_Identifier
(Current_Parameter
)))
7802 Extra_Parameter
: constant Entity_Id
:=
7804 (Defining_Identifier
7805 (Current_Parameter
));
7806 Extra_Any
: constant Entity_Id
:=
7807 Make_Defining_Identifier
7808 (Loc
, New_Internal_Name
('A'));
7809 Formal_Entity
: constant Entity_Id
:=
7810 Make_Defining_Identifier
7811 (Loc
, Chars
(Extra_Parameter
));
7813 Formal_Type
: constant Entity_Id
:=
7814 Etype
(Extra_Parameter
);
7816 Append_To
(Outer_Decls
,
7817 Make_Object_Declaration
(Loc
,
7818 Defining_Identifier
=>
7820 Object_Definition
=>
7821 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
7823 Append_To
(Outer_Statements
,
7824 Add_Parameter_To_NVList
(Loc
,
7825 Parameter
=> Extra_Parameter
,
7826 NVList
=> Arguments
,
7827 Constrained
=> True,
7831 Make_Object_Declaration
(Loc
,
7832 Defining_Identifier
=> Formal_Entity
,
7833 Object_Definition
=>
7834 New_Occurrence_Of
(Formal_Type
, Loc
)));
7836 Append_To
(Extra_Formal_Statements
,
7837 Make_Assignment_Statement
(Loc
,
7839 New_Occurrence_Of
(Extra_Parameter
, Loc
),
7841 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7842 Etype
(Extra_Parameter
),
7843 New_Occurrence_Of
(Extra_Any
, Loc
),
7845 Set_Extra_Constrained
(Object
, Formal_Entity
);
7851 Next
(Current_Parameter
);
7854 Append_To
(Outer_Statements
,
7855 Make_Procedure_Call_Statement
(Loc
,
7857 New_Occurrence_Of
(RTE
(RE_Request_Arguments
), Loc
),
7858 Parameter_Associations
=> New_List
(
7859 New_Occurrence_Of
(Request_Parameter
, Loc
),
7860 New_Occurrence_Of
(Arguments
, Loc
))));
7862 Append_List_To
(Statements
, Extra_Formal_Statements
);
7864 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
7866 -- The remote subprogram is a function. We build an inner block to
7867 -- be able to hold a potentially unconstrained result in a
7871 Etyp
: constant Entity_Id
:=
7872 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
7873 Result
: constant Node_Id
:=
7874 Make_Defining_Identifier
(Loc
,
7875 New_Internal_Name
('R'));
7877 Inner_Decls
:= New_List
(
7878 Make_Object_Declaration
(Loc
,
7879 Defining_Identifier
=> Result
,
7880 Constant_Present
=> True,
7881 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
7883 Make_Function_Call
(Loc
,
7884 Name
=> Called_Subprogram
,
7885 Parameter_Associations
=> Parameter_List
)));
7887 Set_Etype
(Result
, Etyp
);
7888 Append_To
(After_Statements
,
7889 Make_Procedure_Call_Statement
(Loc
,
7891 New_Occurrence_Of
(RTE
(RE_Set_Result
), Loc
),
7892 Parameter_Associations
=> New_List
(
7893 New_Occurrence_Of
(Request_Parameter
, Loc
),
7894 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7895 New_Occurrence_Of
(Result
, Loc
),
7897 -- A DSA function does not have out or inout arguments
7900 Append_To
(Statements
,
7901 Make_Block_Statement
(Loc
,
7902 Declarations
=> Inner_Decls
,
7903 Handled_Statement_Sequence
=>
7904 Make_Handled_Sequence_Of_Statements
(Loc
,
7905 Statements
=> After_Statements
)));
7908 -- The remote subprogram is a procedure. We do not need any inner
7909 -- block in this case. No specific processing is required here for
7910 -- the dynamically asynchronous case: the indication of whether
7911 -- call is asynchronous or not is managed by the Sync_Scope
7912 -- attibute of the request, and is handled entirely in the
7915 Append_To
(After_Statements
,
7916 Make_Procedure_Call_Statement
(Loc
,
7918 New_Occurrence_Of
(RTE
(RE_Request_Set_Out
), Loc
),
7919 Parameter_Associations
=> New_List
(
7920 New_Occurrence_Of
(Request_Parameter
, Loc
))));
7922 Append_To
(Statements
,
7923 Make_Procedure_Call_Statement
(Loc
,
7924 Name
=> Called_Subprogram
,
7925 Parameter_Associations
=> Parameter_List
));
7927 Append_List_To
(Statements
, After_Statements
);
7931 Make_Procedure_Specification
(Loc
,
7932 Defining_Unit_Name
=>
7933 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
7935 Parameter_Specifications
=> New_List
(
7936 Make_Parameter_Specification
(Loc
,
7937 Defining_Identifier
=> Request_Parameter
,
7939 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
7941 -- An exception raised during the execution of an incoming
7942 -- remote subprogram call and that needs to be sent back
7943 -- to the caller is propagated by the receiving stubs, and
7944 -- will be handled by the caller (the distribution runtime).
7946 if Asynchronous
and then not Dynamically_Asynchronous
then
7948 -- For an asynchronous procedure, add a null exception handler
7950 Excep_Handlers
:= New_List
(
7951 Make_Exception_Handler
(Loc
,
7952 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7953 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
7957 -- In the other cases, if an exception is raised, then the
7958 -- exception occurrence is propagated.
7963 Append_To
(Outer_Statements
,
7964 Make_Block_Statement
(Loc
,
7967 Handled_Statement_Sequence
=>
7968 Make_Handled_Sequence_Of_Statements
(Loc
,
7969 Statements
=> Statements
)));
7972 Make_Subprogram_Body
(Loc
,
7973 Specification
=> Subp_Spec
,
7974 Declarations
=> Outer_Decls
,
7975 Handled_Statement_Sequence
=>
7976 Make_Handled_Sequence_Of_Statements
(Loc
,
7977 Statements
=> Outer_Statements
,
7978 Exception_Handlers
=> Excep_Handlers
));
7979 end Build_Subprogram_Receiving_Stubs
;
7984 package body Helpers
is
7986 -----------------------
7987 -- Local Subprograms --
7988 -----------------------
7990 function Find_Numeric_Representation
7991 (Typ
: Entity_Id
) return Entity_Id
;
7992 -- Given a numeric type Typ, return the smallest integer or floarting
7993 -- point type from Standard, or the smallest unsigned (modular) type
7994 -- from System.Unsigned_Types, whose range encompasses that of Typ.
7996 function Make_Stream_Procedure_Function_Name
7999 Nam
: Name_Id
) return Entity_Id
;
8000 -- Return the name to be assigned for stream subprogram Nam of Typ.
8001 -- (copied from exp_strm.adb, should be shared???)
8003 ------------------------------------------------------------
8004 -- Common subprograms for building various tree fragments --
8005 ------------------------------------------------------------
8007 function Build_Get_Aggregate_Element
8011 Idx
: Node_Id
) return Node_Id
;
8012 -- Build a call to Get_Aggregate_Element on Any
8013 -- for typecode TC, returning the Idx'th element.
8016 Subprogram
: Entity_Id
;
8017 -- Reference location for constructed nodes
8020 -- For 'Range and Etype
8023 -- For the construction of the innermost element expression
8025 with procedure Add_Process_Element
8028 Counter
: Entity_Id
;
8031 procedure Append_Array_Traversal
8034 Counter
: Entity_Id
:= Empty
;
8036 -- Build nested loop statements that iterate over the elements of an
8037 -- array Arry. The statement(s) built by Add_Process_Element are
8038 -- executed for each element; Indices is the list of indices to be
8039 -- used in the construction of the indexed component that denotes the
8040 -- current element. Subprogram is the entity for the subprogram for
8041 -- which this iterator is generated. The generated statements are
8042 -- appended to Stmts.
8046 -- The record entity being dealt with
8048 with procedure Add_Process_Element
8050 Container
: Node_Or_Entity_Id
;
8051 Counter
: in out Int
;
8054 -- Rec is the instance of the record type, or Empty.
8055 -- Field is either the N_Defining_Identifier for a component,
8056 -- or an N_Variant_Part.
8058 procedure Append_Record_Traversal
8061 Container
: Node_Or_Entity_Id
;
8062 Counter
: in out Int
);
8063 -- Process component list Clist. Individual fields are passed
8064 -- to Field_Processing. Each variant part is also processed.
8065 -- Container is the outer Any (for From_Any/To_Any),
8066 -- the outer typecode (for TC) to which the operation applies.
8068 -----------------------------
8069 -- Append_Record_Traversal --
8070 -----------------------------
8072 procedure Append_Record_Traversal
8075 Container
: Node_Or_Entity_Id
;
8076 Counter
: in out Int
)
8078 CI
: constant List_Id
:= Component_Items
(Clist
);
8079 VP
: constant Node_Id
:= Variant_Part
(Clist
);
8081 Item
: Node_Id
:= First
(CI
);
8085 while Present
(Item
) loop
8086 Def
:= Defining_Identifier
(Item
);
8087 if not Is_Internal_Name
(Chars
(Def
)) then
8089 (Stmts
, Container
, Counter
, Rec
, Def
);
8094 if Present
(VP
) then
8095 Add_Process_Element
(Stmts
, Container
, Counter
, Rec
, VP
);
8097 end Append_Record_Traversal
;
8099 -------------------------
8100 -- Build_From_Any_Call --
8101 -------------------------
8103 function Build_From_Any_Call
8106 Decls
: List_Id
) return Node_Id
8108 Loc
: constant Source_Ptr
:= Sloc
(N
);
8110 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
8112 Fnam
: Entity_Id
:= Empty
;
8113 Lib_RE
: RE_Id
:= RE_Null
;
8117 -- First simple case where the From_Any function is present
8118 -- in the type's TSS.
8120 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_From_Any
);
8122 if Sloc
(U_Type
) <= Standard_Location
then
8123 U_Type
:= Base_Type
(U_Type
);
8126 -- Check first for Boolean and Character. These are enumeration
8127 -- types, but we treat them specially, since they may require
8128 -- special handling in the transfer protocol. However, this
8129 -- special handling only applies if they have standard
8130 -- representation, otherwise they are treated like any other
8131 -- enumeration type.
8133 if Present
(Fnam
) then
8136 elsif U_Type
= Standard_Boolean
then
8139 elsif U_Type
= Standard_Character
then
8142 elsif U_Type
= Standard_Wide_Character
then
8145 elsif U_Type
= Standard_Wide_Wide_Character
then
8146 Lib_RE
:= RE_FA_WWC
;
8148 -- Floating point types
8150 elsif U_Type
= Standard_Short_Float
then
8153 elsif U_Type
= Standard_Float
then
8156 elsif U_Type
= Standard_Long_Float
then
8159 elsif U_Type
= Standard_Long_Long_Float
then
8160 Lib_RE
:= RE_FA_LLF
;
8164 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
8165 Lib_RE
:= RE_FA_SSI
;
8167 elsif U_Type
= Etype
(Standard_Short_Integer
) then
8170 elsif U_Type
= Etype
(Standard_Integer
) then
8173 elsif U_Type
= Etype
(Standard_Long_Integer
) then
8176 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
8177 Lib_RE
:= RE_FA_LLI
;
8179 -- Unsigned integer types
8181 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
8182 Lib_RE
:= RE_FA_SSU
;
8184 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
8187 elsif U_Type
= RTE
(RE_Unsigned
) then
8190 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
8193 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
8194 Lib_RE
:= RE_FA_LLU
;
8196 elsif U_Type
= Standard_String
then
8197 Lib_RE
:= RE_FA_String
;
8199 -- Other (non-primitive) types
8205 Build_From_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
8206 Append_To
(Decls
, Decl
);
8210 -- Call the function
8212 if Lib_RE
/= RE_Null
then
8213 pragma Assert
(No
(Fnam
));
8214 Fnam
:= RTE
(Lib_RE
);
8218 Make_Function_Call
(Loc
,
8219 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
8220 Parameter_Associations
=> New_List
(N
));
8221 end Build_From_Any_Call
;
8223 -----------------------------
8224 -- Build_From_Any_Function --
8225 -----------------------------
8227 procedure Build_From_Any_Function
8231 Fnam
: out Entity_Id
)
8234 Decls
: constant List_Id
:= New_List
;
8235 Stms
: constant List_Id
:= New_List
;
8236 Any_Parameter
: constant Entity_Id
8237 := Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
8239 Fnam
:= Make_Stream_Procedure_Function_Name
(Loc
,
8240 Typ
, Name_uFrom_Any
);
8243 Make_Function_Specification
(Loc
,
8244 Defining_Unit_Name
=> Fnam
,
8245 Parameter_Specifications
=> New_List
(
8246 Make_Parameter_Specification
(Loc
,
8247 Defining_Identifier
=>
8250 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
8251 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
8253 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8256 (not (Is_Remote_Access_To_Class_Wide_Type
(Typ
)));
8258 if Is_Derived_Type
(Typ
)
8259 and then not Is_Tagged_Type
(Typ
)
8262 Make_Return_Statement
(Loc
,
8266 Build_From_Any_Call
(
8268 New_Occurrence_Of
(Any_Parameter
, Loc
),
8271 elsif Is_Record_Type
(Typ
)
8272 and then not Is_Derived_Type
(Typ
)
8273 and then not Is_Tagged_Type
(Typ
)
8275 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
8277 Make_Return_Statement
(Loc
,
8281 Build_From_Any_Call
(
8283 New_Occurrence_Of
(Any_Parameter
, Loc
),
8287 Disc
: Entity_Id
:= Empty
;
8288 Discriminant_Associations
: List_Id
;
8289 Rdef
: constant Node_Id
:=
8290 Type_Definition
(Declaration_Node
(Typ
));
8291 Component_Counter
: Int
:= 0;
8293 -- The returned object
8295 Res
: constant Entity_Id
:=
8296 Make_Defining_Identifier
(Loc
,
8297 New_Internal_Name
('R'));
8299 Res_Definition
: Node_Id
:= New_Occurrence_Of
(Typ
, Loc
);
8301 procedure FA_Rec_Add_Process_Element
8304 Counter
: in out Int
;
8308 procedure FA_Append_Record_Traversal
is
8309 new Append_Record_Traversal
8311 Add_Process_Element
=> FA_Rec_Add_Process_Element
);
8313 --------------------------------
8314 -- FA_Rec_Add_Process_Element --
8315 --------------------------------
8317 procedure FA_Rec_Add_Process_Element
8320 Counter
: in out Int
;
8325 if Nkind
(Field
) = N_Defining_Identifier
then
8327 -- A regular component
8330 Make_Assignment_Statement
(Loc
,
8331 Name
=> Make_Selected_Component
(Loc
,
8333 New_Occurrence_Of
(Rec
, Loc
),
8335 New_Occurrence_Of
(Field
, Loc
)),
8337 Build_From_Any_Call
(Etype
(Field
),
8338 Build_Get_Aggregate_Element
(Loc
,
8340 Tc
=> Build_TypeCode_Call
(Loc
,
8341 Etype
(Field
), Decls
),
8342 Idx
=> Make_Integer_Literal
(Loc
,
8351 Struct_Counter
: Int
:= 0;
8353 Block_Decls
: constant List_Id
:= New_List
;
8354 Block_Stmts
: constant List_Id
:= New_List
;
8357 Alt_List
: constant List_Id
:= New_List
;
8358 Choice_List
: List_Id
;
8360 Struct_Any
: constant Entity_Id
:=
8361 Make_Defining_Identifier
(Loc
,
8362 New_Internal_Name
('S'));
8366 Make_Object_Declaration
(Loc
,
8367 Defining_Identifier
=>
8371 Object_Definition
=>
8372 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8374 Make_Function_Call
(Loc
,
8375 Name
=> New_Occurrence_Of
(
8376 RTE
(RE_Extract_Union_Value
), Loc
),
8377 Parameter_Associations
=> New_List
(
8378 Build_Get_Aggregate_Element
(Loc
,
8380 Tc
=> Make_Function_Call
(Loc
,
8381 Name
=> New_Occurrence_Of
(
8382 RTE
(RE_Any_Member_Type
), Loc
),
8383 Parameter_Associations
=>
8385 New_Occurrence_Of
(Any
, Loc
),
8386 Make_Integer_Literal
(Loc
,
8388 Idx
=> Make_Integer_Literal
(Loc
,
8392 Make_Block_Statement
(Loc
,
8395 Handled_Statement_Sequence
=>
8396 Make_Handled_Sequence_Of_Statements
(Loc
,
8397 Statements
=> Block_Stmts
)));
8399 Append_To
(Block_Stmts
,
8400 Make_Case_Statement
(Loc
,
8402 Make_Selected_Component
(Loc
,
8405 Chars
(Name
(Field
))),
8409 Variant
:= First_Non_Pragma
(Variants
(Field
));
8411 while Present
(Variant
) loop
8412 Choice_List
:= New_Copy_List_Tree
8413 (Discrete_Choices
(Variant
));
8415 VP_Stmts
:= New_List
;
8416 FA_Append_Record_Traversal
(
8418 Clist
=> Component_List
(Variant
),
8419 Container
=> Struct_Any
,
8420 Counter
=> Struct_Counter
);
8422 Append_To
(Alt_List
,
8423 Make_Case_Statement_Alternative
(Loc
,
8424 Discrete_Choices
=> Choice_List
,
8427 Next_Non_Pragma
(Variant
);
8431 Counter
:= Counter
+ 1;
8432 end FA_Rec_Add_Process_Element
;
8435 -- First all discriminants
8437 if Has_Discriminants
(Typ
) then
8438 Disc
:= First_Discriminant
(Typ
);
8439 Discriminant_Associations
:= New_List
;
8441 while Present
(Disc
) loop
8443 Disc_Var_Name
: constant Entity_Id
:=
8444 Make_Defining_Identifier
(Loc
, Chars
(Disc
));
8445 Disc_Type
: constant Entity_Id
:=
8449 Make_Object_Declaration
(Loc
,
8450 Defining_Identifier
=>
8452 Constant_Present
=> True,
8453 Object_Definition
=>
8454 New_Occurrence_Of
(Disc_Type
, Loc
),
8456 Build_From_Any_Call
(Etype
(Disc
),
8457 Build_Get_Aggregate_Element
(Loc
,
8458 Any
=> Any_Parameter
,
8459 Tc
=> Build_TypeCode_Call
8460 (Loc
, Etype
(Disc
), Decls
),
8461 Idx
=> Make_Integer_Literal
8462 (Loc
, Component_Counter
)),
8464 Component_Counter
:= Component_Counter
+ 1;
8466 Append_To
(Discriminant_Associations
,
8467 Make_Discriminant_Association
(Loc
,
8468 Selector_Names
=> New_List
(
8469 New_Occurrence_Of
(Disc
, Loc
)),
8471 New_Occurrence_Of
(Disc_Var_Name
, Loc
)));
8473 Next_Discriminant
(Disc
);
8476 Res_Definition
:= Make_Subtype_Indication
(Loc
,
8477 Subtype_Mark
=> Res_Definition
,
8479 Make_Index_Or_Discriminant_Constraint
(Loc
,
8480 Discriminant_Associations
));
8483 -- Now we have all the discriminants in variables, we can
8484 -- declared a constrained object. Note that we are not
8485 -- initializing (non-discriminant) components directly in
8486 -- the object declarations, because which fields to
8487 -- initialize depends (at run time) on the discriminant
8491 Make_Object_Declaration
(Loc
,
8492 Defining_Identifier
=>
8494 Object_Definition
=>
8497 -- ... then all components
8499 FA_Append_Record_Traversal
(Stms
,
8500 Clist
=> Component_List
(Rdef
),
8501 Container
=> Any_Parameter
,
8502 Counter
=> Component_Counter
);
8505 Make_Return_Statement
(Loc
,
8506 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
8510 elsif Is_Array_Type
(Typ
) then
8512 Constrained
: constant Boolean := Is_Constrained
(Typ
);
8514 procedure FA_Ary_Add_Process_Element
8517 Counter
: Entity_Id
;
8519 -- Assign the current element (as identified by Counter) of
8520 -- Any to the variable denoted by name Datum, and advance
8521 -- Counter by 1. If Datum is not an Any, a call to From_Any
8522 -- for its type is inserted.
8524 --------------------------------
8525 -- FA_Ary_Add_Process_Element --
8526 --------------------------------
8528 procedure FA_Ary_Add_Process_Element
8531 Counter
: Entity_Id
;
8534 Assignment
: constant Node_Id
:=
8535 Make_Assignment_Statement
(Loc
,
8537 Expression
=> Empty
);
8539 Element_Any
: constant Node_Id
:=
8540 Build_Get_Aggregate_Element
(Loc
,
8542 Tc
=> Build_TypeCode_Call
(Loc
,
8543 Etype
(Datum
), Decls
),
8544 Idx
=> New_Occurrence_Of
(Counter
, Loc
));
8547 -- Note: here we *prepend* statements to Stmts, so
8548 -- we must do it in reverse order.
8551 Make_Assignment_Statement
(Loc
,
8553 New_Occurrence_Of
(Counter
, Loc
),
8557 New_Occurrence_Of
(Counter
, Loc
),
8559 Make_Integer_Literal
(Loc
, 1))));
8561 if Nkind
(Datum
) /= N_Attribute_Reference
then
8563 -- We ignore the value of the length of each
8564 -- dimension, since the target array has already
8565 -- been constrained anyway.
8567 if Etype
(Datum
) /= RTE
(RE_Any
) then
8568 Set_Expression
(Assignment
,
8569 Build_From_Any_Call
(
8570 Component_Type
(Typ
),
8574 Set_Expression
(Assignment
, Element_Any
);
8576 Prepend_To
(Stmts
, Assignment
);
8578 end FA_Ary_Add_Process_Element
;
8580 Counter
: constant Entity_Id
:=
8581 Make_Defining_Identifier
(Loc
, Name_J
);
8583 Initial_Counter_Value
: Int
:= 0;
8585 Component_TC
: constant Entity_Id
:=
8586 Make_Defining_Identifier
(Loc
, Name_T
);
8588 Res
: constant Entity_Id
:=
8589 Make_Defining_Identifier
(Loc
, Name_R
);
8591 procedure Append_From_Any_Array_Iterator
is
8592 new Append_Array_Traversal
(
8595 Indices
=> New_List
,
8596 Add_Process_Element
=> FA_Ary_Add_Process_Element
);
8598 Res_Subtype_Indication
: Node_Id
:=
8599 New_Occurrence_Of
(Typ
, Loc
);
8602 if not Constrained
then
8604 Ndim
: constant Int
:= Number_Dimensions
(Typ
);
8607 Indx
: Node_Id
:= First_Index
(Typ
);
8610 Ranges
: constant List_Id
:= New_List
;
8613 for J
in 1 .. Ndim
loop
8614 Lnam
:= New_External_Name
('L', J
);
8615 Hnam
:= New_External_Name
('H', J
);
8616 Indt
:= Etype
(Indx
);
8619 Make_Object_Declaration
(Loc
,
8620 Defining_Identifier
=>
8621 Make_Defining_Identifier
(Loc
, Lnam
),
8624 Object_Definition
=>
8625 New_Occurrence_Of
(Indt
, Loc
),
8627 Build_From_Any_Call
(
8629 Build_Get_Aggregate_Element
(Loc
,
8630 Any
=> Any_Parameter
,
8631 Tc
=> Build_TypeCode_Call
(Loc
,
8633 Idx
=> Make_Integer_Literal
(Loc
, J
- 1)),
8637 Make_Object_Declaration
(Loc
,
8638 Defining_Identifier
=>
8639 Make_Defining_Identifier
(Loc
, Hnam
),
8642 Object_Definition
=>
8643 New_Occurrence_Of
(Indt
, Loc
),
8644 Expression
=> Make_Attribute_Reference
(Loc
,
8646 New_Occurrence_Of
(Indt
, Loc
),
8647 Attribute_Name
=> Name_Val
,
8648 Expressions
=> New_List
(
8649 Make_Op_Subtract
(Loc
,
8653 Make_Attribute_Reference
(Loc
,
8655 New_Occurrence_Of
(Indt
, Loc
),
8658 Expressions
=> New_List
(
8659 Make_Identifier
(Loc
, Lnam
))),
8661 Make_Function_Call
(Loc
,
8662 Name
=> New_Occurrence_Of
(RTE
(
8663 RE_Get_Nested_Sequence_Length
),
8665 Parameter_Associations
=>
8668 Any_Parameter
, Loc
),
8669 Make_Integer_Literal
(Loc
,
8672 Make_Integer_Literal
(Loc
, 1))))));
8676 Low_Bound
=> Make_Identifier
(Loc
, Lnam
),
8677 High_Bound
=> Make_Identifier
(Loc
, Hnam
)));
8682 -- Now we have all the necessary bound information:
8683 -- apply the set of range constraints to the
8684 -- (unconstrained) nominal subtype of Res.
8686 Initial_Counter_Value
:= Ndim
;
8687 Res_Subtype_Indication
:= Make_Subtype_Indication
(Loc
,
8689 Res_Subtype_Indication
,
8691 Make_Index_Or_Discriminant_Constraint
(Loc
,
8692 Constraints
=> Ranges
));
8697 Make_Object_Declaration
(Loc
,
8698 Defining_Identifier
=> Res
,
8699 Object_Definition
=> Res_Subtype_Indication
));
8700 Set_Etype
(Res
, Typ
);
8703 Make_Object_Declaration
(Loc
,
8704 Defining_Identifier
=> Counter
,
8705 Object_Definition
=>
8706 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
8708 Make_Integer_Literal
(Loc
, Initial_Counter_Value
)));
8711 Make_Object_Declaration
(Loc
,
8712 Defining_Identifier
=> Component_TC
,
8713 Constant_Present
=> True,
8714 Object_Definition
=>
8715 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
),
8717 Build_TypeCode_Call
(Loc
,
8718 Component_Type
(Typ
), Decls
)));
8720 Append_From_Any_Array_Iterator
(Stms
,
8721 Any_Parameter
, Counter
);
8724 Make_Return_Statement
(Loc
,
8725 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
8728 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
8730 Make_Return_Statement
(Loc
,
8732 Unchecked_Convert_To
(
8734 Build_From_Any_Call
(
8735 Find_Numeric_Representation
(Typ
),
8736 New_Occurrence_Of
(Any_Parameter
, Loc
),
8740 -- Default: type is represented as an opaque sequence of bytes
8743 Strm
: constant Entity_Id
:=
8744 Make_Defining_Identifier
(Loc
,
8745 Chars
=> New_Internal_Name
('S'));
8746 Res
: constant Entity_Id
:=
8747 Make_Defining_Identifier
(Loc
,
8748 Chars
=> New_Internal_Name
('R'));
8751 -- Strm : Buffer_Stream_Type;
8754 Make_Object_Declaration
(Loc
,
8755 Defining_Identifier
=>
8759 Object_Definition
=>
8760 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
8762 -- Any_To_BS (Strm, A);
8765 Make_Procedure_Call_Statement
(Loc
,
8767 New_Occurrence_Of
(RTE
(RE_Any_To_BS
), Loc
),
8768 Parameter_Associations
=> New_List
(
8769 New_Occurrence_Of
(Any_Parameter
, Loc
),
8770 New_Occurrence_Of
(Strm
, Loc
))));
8773 -- Res : constant T := T'Input (Strm);
8775 -- Release_Buffer (Strm);
8779 Append_To
(Stms
, Make_Block_Statement
(Loc
,
8780 Declarations
=> New_List
(
8781 Make_Object_Declaration
(Loc
,
8782 Defining_Identifier
=> Res
,
8783 Constant_Present
=> True,
8784 Object_Definition
=>
8785 New_Occurrence_Of
(Typ
, Loc
),
8787 Make_Attribute_Reference
(Loc
,
8788 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
8789 Attribute_Name
=> Name_Input
,
8790 Expressions
=> New_List
(
8791 Make_Attribute_Reference
(Loc
,
8792 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
8793 Attribute_Name
=> Name_Access
))))),
8795 Handled_Statement_Sequence
=>
8796 Make_Handled_Sequence_Of_Statements
(Loc
,
8797 Statements
=> New_List
(
8798 Make_Procedure_Call_Statement
(Loc
,
8800 New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
8801 Parameter_Associations
=>
8803 New_Occurrence_Of
(Strm
, Loc
))),
8804 Make_Return_Statement
(Loc
,
8805 Expression
=> New_Occurrence_Of
(Res
, Loc
))))));
8811 Make_Subprogram_Body
(Loc
,
8812 Specification
=> Spec
,
8813 Declarations
=> Decls
,
8814 Handled_Statement_Sequence
=>
8815 Make_Handled_Sequence_Of_Statements
(Loc
,
8816 Statements
=> Stms
));
8817 end Build_From_Any_Function
;
8819 ---------------------------------
8820 -- Build_Get_Aggregate_Element --
8821 ---------------------------------
8823 function Build_Get_Aggregate_Element
8827 Idx
: Node_Id
) return Node_Id
8830 return Make_Function_Call
(Loc
,
8833 RTE
(RE_Get_Aggregate_Element
), Loc
),
8834 Parameter_Associations
=> New_List
(
8835 New_Occurrence_Of
(Any
, Loc
),
8838 end Build_Get_Aggregate_Element
;
8840 -------------------------
8841 -- Build_Reposiroty_Id --
8842 -------------------------
8844 procedure Build_Name_And_Repository_Id
8846 Name_Str
: out String_Id
;
8847 Repo_Id_Str
: out String_Id
)
8851 Store_String_Chars
("DSA:");
8852 Get_Library_Unit_Name_String
(Scope
(E
));
8853 Store_String_Chars
(
8854 Name_Buffer
(Name_Buffer
'First
8855 .. Name_Buffer
'First + Name_Len
- 1));
8856 Store_String_Char
('.');
8857 Get_Name_String
(Chars
(E
));
8858 Store_String_Chars
(
8859 Name_Buffer
(Name_Buffer
'First
8860 .. Name_Buffer
'First + Name_Len
- 1));
8861 Store_String_Chars
(":1.0");
8862 Repo_Id_Str
:= End_String
;
8863 Name_Str
:= String_From_Name_Buffer
;
8864 end Build_Name_And_Repository_Id
;
8866 -----------------------
8867 -- Build_To_Any_Call --
8868 -----------------------
8870 function Build_To_Any_Call
8872 Decls
: List_Id
) return Node_Id
8874 Loc
: constant Source_Ptr
:= Sloc
(N
);
8876 Typ
: Entity_Id
:= Etype
(N
);
8879 Fnam
: Entity_Id
:= Empty
;
8880 Lib_RE
: RE_Id
:= RE_Null
;
8883 -- If N is a selected component, then maybe its Etype
8884 -- has not been set yet: try to use the Etype of the
8885 -- selector_name in that case.
8887 if No
(Typ
) and then Nkind
(N
) = N_Selected_Component
then
8888 Typ
:= Etype
(Selector_Name
(N
));
8890 pragma Assert
(Present
(Typ
));
8892 -- The full view, if Typ is private; the completion,
8893 -- if Typ is incomplete.
8895 U_Type
:= Underlying_Type
(Typ
);
8897 -- First simple case where the To_Any function is present
8898 -- in the type's TSS.
8900 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_To_Any
);
8902 -- Check first for Boolean and Character. These are enumeration
8903 -- types, but we treat them specially, since they may require
8904 -- special handling in the transfer protocol. However, this
8905 -- special handling only applies if they have standard
8906 -- representation, otherwise they are treated like any other
8907 -- enumeration type.
8909 if Sloc
(U_Type
) <= Standard_Location
then
8910 U_Type
:= Base_Type
(U_Type
);
8913 if Present
(Fnam
) then
8916 elsif U_Type
= Standard_Boolean
then
8919 elsif U_Type
= Standard_Character
then
8922 elsif U_Type
= Standard_Wide_Character
then
8925 elsif U_Type
= Standard_Wide_Wide_Character
then
8926 Lib_RE
:= RE_TA_WWC
;
8928 -- Floating point types
8930 elsif U_Type
= Standard_Short_Float
then
8933 elsif U_Type
= Standard_Float
then
8936 elsif U_Type
= Standard_Long_Float
then
8939 elsif U_Type
= Standard_Long_Long_Float
then
8940 Lib_RE
:= RE_TA_LLF
;
8944 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
8945 Lib_RE
:= RE_TA_SSI
;
8947 elsif U_Type
= Etype
(Standard_Short_Integer
) then
8950 elsif U_Type
= Etype
(Standard_Integer
) then
8953 elsif U_Type
= Etype
(Standard_Long_Integer
) then
8956 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
8957 Lib_RE
:= RE_TA_LLI
;
8959 -- Unsigned integer types
8961 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
8962 Lib_RE
:= RE_TA_SSU
;
8964 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
8967 elsif U_Type
= RTE
(RE_Unsigned
) then
8970 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
8973 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
8974 Lib_RE
:= RE_TA_LLU
;
8976 elsif U_Type
= Standard_String
then
8977 Lib_RE
:= RE_TA_String
;
8979 elsif U_Type
= Underlying_Type
(RTE
(RE_TypeCode
)) then
8982 -- Other (non-primitive) types
8988 Build_To_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
8989 Append_To
(Decls
, Decl
);
8993 -- Call the function
8995 if Lib_RE
/= RE_Null
then
8996 pragma Assert
(No
(Fnam
));
8997 Fnam
:= RTE
(Lib_RE
);
9001 Make_Function_Call
(Loc
,
9002 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
9003 Parameter_Associations
=> New_List
(N
));
9004 end Build_To_Any_Call
;
9006 ---------------------------
9007 -- Build_To_Any_Function --
9008 ---------------------------
9010 procedure Build_To_Any_Function
9014 Fnam
: out Entity_Id
)
9017 Decls
: constant List_Id
:= New_List
;
9018 Stms
: constant List_Id
:= New_List
;
9020 Expr_Parameter
: constant Entity_Id
:=
9021 Make_Defining_Identifier
(Loc
, Name_E
);
9023 Any
: constant Entity_Id
:=
9024 Make_Defining_Identifier
(Loc
, Name_A
);
9027 Result_TC
: Node_Id
:= Build_TypeCode_Call
(Loc
, Typ
, Decls
);
9030 Fnam
:= Make_Stream_Procedure_Function_Name
(Loc
,
9034 Make_Function_Specification
(Loc
,
9035 Defining_Unit_Name
=> Fnam
,
9036 Parameter_Specifications
=> New_List
(
9037 Make_Parameter_Specification
(Loc
,
9038 Defining_Identifier
=>
9041 New_Occurrence_Of
(Typ
, Loc
))),
9042 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9043 Set_Etype
(Expr_Parameter
, Typ
);
9046 Make_Object_Declaration
(Loc
,
9047 Defining_Identifier
=>
9049 Object_Definition
=>
9050 New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9052 if Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9054 Rt_Type
: constant Entity_Id
9056 Expr
: constant Node_Id
9059 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9061 Set_Expression
(Any_Decl
, Build_To_Any_Call
(Expr
, Decls
));
9064 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9065 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
9067 Rt_Type
: constant Entity_Id
9069 Expr
: constant Node_Id
9072 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9075 Set_Expression
(Any_Decl
,
9076 Build_To_Any_Call
(Expr
, Decls
));
9081 Disc
: Entity_Id
:= Empty
;
9082 Rdef
: constant Node_Id
:=
9083 Type_Definition
(Declaration_Node
(Typ
));
9085 Elements
: constant List_Id
:= New_List
;
9087 procedure TA_Rec_Add_Process_Element
9089 Container
: Node_Or_Entity_Id
;
9090 Counter
: in out Int
;
9094 procedure TA_Append_Record_Traversal
is
9095 new Append_Record_Traversal
9096 (Rec
=> Expr_Parameter
,
9097 Add_Process_Element
=> TA_Rec_Add_Process_Element
);
9099 --------------------------------
9100 -- TA_Rec_Add_Process_Element --
9101 --------------------------------
9103 procedure TA_Rec_Add_Process_Element
9105 Container
: Node_Or_Entity_Id
;
9106 Counter
: in out Int
;
9110 Field_Ref
: Node_Id
;
9113 if Nkind
(Field
) = N_Defining_Identifier
then
9115 -- A regular component
9117 Field_Ref
:= Make_Selected_Component
(Loc
,
9118 Prefix
=> New_Occurrence_Of
(Rec
, Loc
),
9119 Selector_Name
=> New_Occurrence_Of
(Field
, Loc
));
9120 Set_Etype
(Field_Ref
, Etype
(Field
));
9123 Make_Procedure_Call_Statement
(Loc
,
9126 RTE
(RE_Add_Aggregate_Element
), Loc
),
9127 Parameter_Associations
=> New_List
(
9128 New_Occurrence_Of
(Any
, Loc
),
9129 Build_To_Any_Call
(Field_Ref
, Decls
))));
9136 Struct_Counter
: Int
:= 0;
9138 Block_Decls
: constant List_Id
:= New_List
;
9139 Block_Stmts
: constant List_Id
:= New_List
;
9142 Alt_List
: constant List_Id
:= New_List
;
9143 Choice_List
: List_Id
;
9145 Union_Any
: constant Entity_Id
:=
9146 Make_Defining_Identifier
(Loc
,
9147 New_Internal_Name
('U'));
9149 Struct_Any
: constant Entity_Id
:=
9150 Make_Defining_Identifier
(Loc
,
9151 New_Internal_Name
('S'));
9153 function Make_Discriminant_Reference
9155 -- Build a selected component for the
9156 -- discriminant of this variant part.
9158 ---------------------------------
9159 -- Make_Discriminant_Reference --
9160 ---------------------------------
9162 function Make_Discriminant_Reference
9165 Nod
: constant Node_Id
:=
9166 Make_Selected_Component
(Loc
,
9169 Chars
(Name
(Field
)));
9171 Set_Etype
(Nod
, Name
(Field
));
9173 end Make_Discriminant_Reference
;
9177 Make_Block_Statement
(Loc
,
9180 Handled_Statement_Sequence
=>
9181 Make_Handled_Sequence_Of_Statements
(Loc
,
9182 Statements
=> Block_Stmts
)));
9184 Append_To
(Block_Decls
,
9185 Make_Object_Declaration
(Loc
,
9186 Defining_Identifier
=> Union_Any
,
9187 Object_Definition
=>
9188 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9190 Make_Function_Call
(Loc
,
9191 Name
=> New_Occurrence_Of
(
9192 RTE
(RE_Create_Any
), Loc
),
9193 Parameter_Associations
=> New_List
(
9194 Make_Function_Call
(Loc
,
9197 RTE
(RE_Any_Member_Type
), Loc
),
9198 Parameter_Associations
=> New_List
(
9199 New_Occurrence_Of
(Container
, Loc
),
9200 Make_Integer_Literal
(Loc
,
9203 Append_To
(Block_Decls
,
9204 Make_Object_Declaration
(Loc
,
9205 Defining_Identifier
=> Struct_Any
,
9206 Object_Definition
=>
9207 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9209 Make_Function_Call
(Loc
,
9210 Name
=> New_Occurrence_Of
(
9211 RTE
(RE_Create_Any
), Loc
),
9212 Parameter_Associations
=> New_List
(
9213 Make_Function_Call
(Loc
,
9216 RTE
(RE_Any_Member_Type
), Loc
),
9217 Parameter_Associations
=> New_List
(
9218 New_Occurrence_Of
(Union_Any
, Loc
),
9219 Make_Integer_Literal
(Loc
,
9222 Append_To
(Block_Stmts
,
9223 Make_Case_Statement
(Loc
,
9225 Make_Discriminant_Reference
,
9229 Variant
:= First_Non_Pragma
(Variants
(Field
));
9230 while Present
(Variant
) loop
9231 Choice_List
:= New_Copy_List_Tree
9232 (Discrete_Choices
(Variant
));
9234 VP_Stmts
:= New_List
;
9235 TA_Append_Record_Traversal
(
9237 Clist
=> Component_List
(Variant
),
9238 Container
=> Struct_Any
,
9239 Counter
=> Struct_Counter
);
9241 -- Append discriminant value and inner struct
9242 -- to union aggregate.
9244 Append_To
(VP_Stmts
,
9245 Make_Procedure_Call_Statement
(Loc
,
9248 RTE
(RE_Add_Aggregate_Element
), Loc
),
9249 Parameter_Associations
=> New_List
(
9250 New_Occurrence_Of
(Union_Any
, Loc
),
9252 Make_Discriminant_Reference
,
9255 Append_To
(VP_Stmts
,
9256 Make_Procedure_Call_Statement
(Loc
,
9259 RTE
(RE_Add_Aggregate_Element
), Loc
),
9260 Parameter_Associations
=> New_List
(
9261 New_Occurrence_Of
(Union_Any
, Loc
),
9262 New_Occurrence_Of
(Struct_Any
, Loc
))));
9264 -- Append union to outer aggregate
9266 Append_To
(VP_Stmts
,
9267 Make_Procedure_Call_Statement
(Loc
,
9270 RTE
(RE_Add_Aggregate_Element
), Loc
),
9271 Parameter_Associations
=> New_List
(
9272 New_Occurrence_Of
(Container
, Loc
),
9273 Make_Function_Call
(Loc
,
9274 Name
=> New_Occurrence_Of
(
9275 RTE
(RE_Any_Aggregate_Build
), Loc
),
9276 Parameter_Associations
=> New_List
(
9278 Union_Any
, Loc
))))));
9280 Append_To
(Alt_List
,
9281 Make_Case_Statement_Alternative
(Loc
,
9282 Discrete_Choices
=> Choice_List
,
9285 Next_Non_Pragma
(Variant
);
9289 end TA_Rec_Add_Process_Element
;
9292 -- First all discriminants
9294 if Has_Discriminants
(Typ
) then
9295 Disc
:= First_Discriminant
(Typ
);
9297 while Present
(Disc
) loop
9298 Append_To
(Elements
,
9299 Make_Component_Association
(Loc
,
9300 Choices
=> New_List
(
9301 Make_Integer_Literal
(Loc
, Counter
)),
9304 Make_Selected_Component
(Loc
,
9305 Prefix
=> Expr_Parameter
,
9306 Selector_Name
=> Chars
(Disc
)),
9308 Counter
:= Counter
+ 1;
9309 Next_Discriminant
(Disc
);
9313 -- Make elements an empty array
9316 Dummy_Any
: constant Entity_Id
:=
9317 Make_Defining_Identifier
(Loc
,
9318 Chars
=> New_Internal_Name
('A'));
9322 Make_Object_Declaration
(Loc
,
9323 Defining_Identifier
=> Dummy_Any
,
9324 Object_Definition
=>
9325 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
9327 Append_To
(Elements
,
9328 Make_Component_Association
(Loc
,
9329 Choices
=> New_List
(
9332 Make_Integer_Literal
(Loc
, 1),
9334 Make_Integer_Literal
(Loc
, 0))),
9336 New_Occurrence_Of
(Dummy_Any
, Loc
)));
9340 Set_Expression
(Any_Decl
,
9341 Make_Function_Call
(Loc
,
9342 Name
=> New_Occurrence_Of
(
9343 RTE
(RE_Any_Aggregate_Build
), Loc
),
9344 Parameter_Associations
=> New_List
(
9346 Make_Aggregate
(Loc
,
9347 Component_Associations
=> Elements
))));
9350 -- ... then all components
9352 TA_Append_Record_Traversal
(Stms
,
9353 Clist
=> Component_List
(Rdef
),
9355 Counter
=> Counter
);
9359 elsif Is_Array_Type
(Typ
) then
9361 Constrained
: constant Boolean := Is_Constrained
(Typ
);
9363 procedure TA_Ary_Add_Process_Element
9366 Counter
: Entity_Id
;
9369 --------------------------------
9370 -- TA_Ary_Add_Process_Element --
9371 --------------------------------
9373 procedure TA_Ary_Add_Process_Element
9376 Counter
: Entity_Id
;
9379 pragma Warnings
(Off
);
9380 pragma Unreferenced
(Counter
);
9381 pragma Warnings
(On
);
9383 Element_Any
: Node_Id
;
9386 if Etype
(Datum
) = RTE
(RE_Any
) then
9387 Element_Any
:= Datum
;
9389 Element_Any
:= Build_To_Any_Call
(Datum
, Decls
);
9393 Make_Procedure_Call_Statement
(Loc
,
9394 Name
=> New_Occurrence_Of
(
9395 RTE
(RE_Add_Aggregate_Element
), Loc
),
9396 Parameter_Associations
=> New_List
(
9397 New_Occurrence_Of
(Any
, Loc
),
9399 end TA_Ary_Add_Process_Element
;
9401 procedure Append_To_Any_Array_Iterator
is
9402 new Append_Array_Traversal
(
9404 Arry
=> Expr_Parameter
,
9405 Indices
=> New_List
,
9406 Add_Process_Element
=> TA_Ary_Add_Process_Element
);
9411 Set_Expression
(Any_Decl
,
9412 Make_Function_Call
(Loc
,
9414 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
9415 Parameter_Associations
=> New_List
(Result_TC
)));
9418 if not Constrained
then
9419 Index
:= First_Index
(Typ
);
9420 for J
in 1 .. Number_Dimensions
(Typ
) loop
9422 Make_Procedure_Call_Statement
(Loc
,
9425 RTE
(RE_Add_Aggregate_Element
), Loc
),
9426 Parameter_Associations
=> New_List
(
9427 New_Occurrence_Of
(Any
, Loc
),
9429 OK_Convert_To
(Etype
(Index
),
9430 Make_Attribute_Reference
(Loc
,
9432 New_Occurrence_Of
(Expr_Parameter
, Loc
),
9433 Attribute_Name
=> Name_First
,
9434 Expressions
=> New_List
(
9435 Make_Integer_Literal
(Loc
, J
)))),
9441 Append_To_Any_Array_Iterator
(Stms
, Any
);
9444 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9445 Set_Expression
(Any_Decl
,
9448 Find_Numeric_Representation
(Typ
),
9449 New_Occurrence_Of
(Expr_Parameter
, Loc
)),
9453 -- Default: type is represented as an opaque sequence of bytes
9456 Strm
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
9457 New_Internal_Name
('S'));
9460 -- Strm : aliased Buffer_Stream_Type;
9463 Make_Object_Declaration
(Loc
,
9464 Defining_Identifier
=>
9468 Object_Definition
=>
9469 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
9471 -- Allocate_Buffer (Strm);
9474 Make_Procedure_Call_Statement
(Loc
,
9476 New_Occurrence_Of
(RTE
(RE_Allocate_Buffer
), Loc
),
9477 Parameter_Associations
=> New_List
(
9478 New_Occurrence_Of
(Strm
, Loc
))));
9480 -- T'Output (Strm'Access, E);
9483 Make_Attribute_Reference
(Loc
,
9484 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
9485 Attribute_Name
=> Name_Output
,
9486 Expressions
=> New_List
(
9487 Make_Attribute_Reference
(Loc
,
9488 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
9489 Attribute_Name
=> Name_Access
),
9490 New_Occurrence_Of
(Expr_Parameter
, Loc
))));
9492 -- BS_To_Any (Strm, A);
9495 Make_Procedure_Call_Statement
(Loc
,
9497 New_Occurrence_Of
(RTE
(RE_BS_To_Any
), Loc
),
9498 Parameter_Associations
=> New_List
(
9499 New_Occurrence_Of
(Strm
, Loc
),
9500 New_Occurrence_Of
(Any
, Loc
))));
9502 -- Release_Buffer (Strm);
9505 Make_Procedure_Call_Statement
(Loc
,
9507 New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
9508 Parameter_Associations
=> New_List
(
9509 New_Occurrence_Of
(Strm
, Loc
))));
9513 Append_To
(Decls
, Any_Decl
);
9515 if Present
(Result_TC
) then
9517 Make_Procedure_Call_Statement
(Loc
,
9518 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
9519 Parameter_Associations
=> New_List
(
9520 New_Occurrence_Of
(Any
, Loc
),
9525 Make_Return_Statement
(Loc
,
9526 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
9529 Make_Subprogram_Body
(Loc
,
9530 Specification
=> Spec
,
9531 Declarations
=> Decls
,
9532 Handled_Statement_Sequence
=>
9533 Make_Handled_Sequence_Of_Statements
(Loc
,
9534 Statements
=> Stms
));
9535 end Build_To_Any_Function
;
9537 -------------------------
9538 -- Build_TypeCode_Call --
9539 -------------------------
9541 function Build_TypeCode_Call
9544 Decls
: List_Id
) return Node_Id
9546 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
9547 -- The full view, if Typ is private; the completion,
9548 -- if Typ is incomplete.
9550 Fnam
: Entity_Id
:= Empty
;
9551 Lib_RE
: RE_Id
:= RE_Null
;
9556 -- Special case System.PolyORB.Interface.Any: its primitives have
9557 -- not been set yet, so can't call Find_Inherited_TSS.
9559 if Typ
= RTE
(RE_Any
) then
9560 Fnam
:= RTE
(RE_TC_Any
);
9563 -- First simple case where the TypeCode is present
9564 -- in the type's TSS.
9566 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_TypeCode
);
9570 if Sloc
(U_Type
) <= Standard_Location
then
9572 -- Do not try to build alias typecodes for subtypes from
9575 U_Type
:= Base_Type
(U_Type
);
9578 if U_Type
= Standard_Boolean
then
9581 elsif U_Type
= Standard_Character
then
9584 elsif U_Type
= Standard_Wide_Character
then
9587 elsif U_Type
= Standard_Wide_Wide_Character
then
9588 Lib_RE
:= RE_TC_WWC
;
9590 -- Floating point types
9592 elsif U_Type
= Standard_Short_Float
then
9595 elsif U_Type
= Standard_Float
then
9598 elsif U_Type
= Standard_Long_Float
then
9601 elsif U_Type
= Standard_Long_Long_Float
then
9602 Lib_RE
:= RE_TC_LLF
;
9604 -- Integer types (walk back to the base type)
9606 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
9607 Lib_RE
:= RE_TC_SSI
;
9609 elsif U_Type
= Etype
(Standard_Short_Integer
) then
9612 elsif U_Type
= Etype
(Standard_Integer
) then
9615 elsif U_Type
= Etype
(Standard_Long_Integer
) then
9618 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
9619 Lib_RE
:= RE_TC_LLI
;
9621 -- Unsigned integer types
9623 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
9624 Lib_RE
:= RE_TC_SSU
;
9626 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
9629 elsif U_Type
= RTE
(RE_Unsigned
) then
9632 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
9635 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
9636 Lib_RE
:= RE_TC_LLU
;
9638 elsif U_Type
= Standard_String
then
9639 Lib_RE
:= RE_TC_String
;
9641 -- Other (non-primitive) types
9647 Build_TypeCode_Function
(Loc
, U_Type
, Decl
, Fnam
);
9648 Append_To
(Decls
, Decl
);
9652 if Lib_RE
/= RE_Null
then
9653 Fnam
:= RTE
(Lib_RE
);
9657 -- Call the function
9660 Make_Function_Call
(Loc
, Name
=> New_Occurrence_Of
(Fnam
, Loc
));
9662 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
9664 Set_Etype
(Expr
, RTE
(RE_TypeCode
));
9667 end Build_TypeCode_Call
;
9669 -----------------------------
9670 -- Build_TypeCode_Function --
9671 -----------------------------
9673 procedure Build_TypeCode_Function
9677 Fnam
: out Entity_Id
)
9680 Decls
: constant List_Id
:= New_List
;
9681 Stms
: constant List_Id
:= New_List
;
9683 TCNam
: constant Entity_Id
:=
9684 Make_Stream_Procedure_Function_Name
(Loc
,
9685 Typ
, Name_uTypeCode
);
9687 Parameters
: List_Id
;
9689 procedure Add_String_Parameter
9691 Parameter_List
: List_Id
);
9692 -- Add a literal for S to Parameters
9694 procedure Add_TypeCode_Parameter
9696 Parameter_List
: List_Id
);
9697 -- Add the typecode for Typ to Parameters
9699 procedure Add_Long_Parameter
9700 (Expr_Node
: Node_Id
;
9701 Parameter_List
: List_Id
);
9702 -- Add a signed long integer expression to Parameters
9704 procedure Initialize_Parameter_List
9705 (Name_String
: String_Id
;
9706 Repo_Id_String
: String_Id
;
9707 Parameter_List
: out List_Id
);
9708 -- Return a list that contains the first two parameters
9709 -- for a parameterized typecode: name and repository id.
9711 function Make_Constructed_TypeCode
9713 Parameters
: List_Id
) return Node_Id
;
9714 -- Call TC_Build with the given kind and parameters
9716 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
);
9717 -- Make a return statement that calls TC_Build with the given
9718 -- typecode kind, and the constructed parameters list.
9720 procedure Return_Alias_TypeCode
(Base_TypeCode
: Node_Id
);
9721 -- Return a typecode that is a TC_Alias for the given typecode
9723 --------------------------
9724 -- Add_String_Parameter --
9725 --------------------------
9727 procedure Add_String_Parameter
9729 Parameter_List
: List_Id
)
9732 Append_To
(Parameter_List
,
9733 Make_Function_Call
(Loc
,
9735 New_Occurrence_Of
(RTE
(RE_TA_String
), Loc
),
9736 Parameter_Associations
=> New_List
(
9737 Make_String_Literal
(Loc
, S
))));
9738 end Add_String_Parameter
;
9740 ----------------------------
9741 -- Add_TypeCode_Parameter --
9742 ----------------------------
9744 procedure Add_TypeCode_Parameter
9746 Parameter_List
: List_Id
)
9749 Append_To
(Parameter_List
,
9750 Make_Function_Call
(Loc
,
9752 New_Occurrence_Of
(RTE
(RE_TA_TC
), Loc
),
9753 Parameter_Associations
=> New_List
(
9755 end Add_TypeCode_Parameter
;
9757 ------------------------
9758 -- Add_Long_Parameter --
9759 ------------------------
9761 procedure Add_Long_Parameter
9762 (Expr_Node
: Node_Id
;
9763 Parameter_List
: List_Id
)
9766 Append_To
(Parameter_List
,
9767 Make_Function_Call
(Loc
,
9769 New_Occurrence_Of
(RTE
(RE_TA_LI
), Loc
),
9770 Parameter_Associations
=> New_List
(Expr_Node
)));
9771 end Add_Long_Parameter
;
9773 -------------------------------
9774 -- Initialize_Parameter_List --
9775 -------------------------------
9777 procedure Initialize_Parameter_List
9778 (Name_String
: String_Id
;
9779 Repo_Id_String
: String_Id
;
9780 Parameter_List
: out List_Id
)
9783 Parameter_List
:= New_List
;
9784 Add_String_Parameter
(Name_String
, Parameter_List
);
9785 Add_String_Parameter
(Repo_Id_String
, Parameter_List
);
9786 end Initialize_Parameter_List
;
9788 ---------------------------
9789 -- Return_Alias_TypeCode --
9790 ---------------------------
9792 procedure Return_Alias_TypeCode
9793 (Base_TypeCode
: Node_Id
)
9796 Add_TypeCode_Parameter
(Base_TypeCode
, Parameters
);
9797 Return_Constructed_TypeCode
(RTE
(RE_TC_Alias
));
9798 end Return_Alias_TypeCode
;
9800 -------------------------------
9801 -- Make_Constructed_TypeCode --
9802 -------------------------------
9804 function Make_Constructed_TypeCode
9806 Parameters
: List_Id
) return Node_Id
9808 Constructed_TC
: constant Node_Id
:=
9809 Make_Function_Call
(Loc
,
9811 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
9812 Parameter_Associations
=> New_List
(
9813 New_Occurrence_Of
(Kind
, Loc
),
9814 Make_Aggregate
(Loc
,
9815 Expressions
=> Parameters
)));
9817 Set_Etype
(Constructed_TC
, RTE
(RE_TypeCode
));
9818 return Constructed_TC
;
9819 end Make_Constructed_TypeCode
;
9821 ---------------------------------
9822 -- Return_Constructed_TypeCode --
9823 ---------------------------------
9825 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
) is
9828 Make_Return_Statement
(Loc
,
9830 Make_Constructed_TypeCode
(Kind
, Parameters
)));
9831 end Return_Constructed_TypeCode
;
9837 procedure TC_Rec_Add_Process_Element
9840 Counter
: in out Int
;
9844 procedure TC_Append_Record_Traversal
is
9845 new Append_Record_Traversal
(
9847 Add_Process_Element
=> TC_Rec_Add_Process_Element
);
9849 --------------------------------
9850 -- TC_Rec_Add_Process_Element --
9851 --------------------------------
9853 procedure TC_Rec_Add_Process_Element
9856 Counter
: in out Int
;
9860 pragma Warnings
(Off
);
9861 pragma Unreferenced
(Any
, Counter
, Rec
);
9862 pragma Warnings
(On
);
9865 if Nkind
(Field
) = N_Defining_Identifier
then
9867 -- A regular component
9869 Add_TypeCode_Parameter
(
9870 Build_TypeCode_Call
(Loc
, Etype
(Field
), Decls
), Params
);
9871 Get_Name_String
(Chars
(Field
));
9872 Add_String_Parameter
(String_From_Name_Buffer
, Params
);
9879 Discriminant_Type
: constant Entity_Id
:=
9880 Etype
(Name
(Field
));
9882 Is_Enum
: constant Boolean :=
9883 Is_Enumeration_Type
(Discriminant_Type
);
9885 Union_TC_Params
: List_Id
;
9887 U_Name
: constant Name_Id
:=
9888 New_External_Name
(Chars
(Typ
), 'U', -1);
9890 Name_Str
: String_Id
;
9891 Struct_TC_Params
: List_Id
;
9895 Default
: constant Node_Id
:=
9896 Make_Integer_Literal
(Loc
, -1);
9898 Dummy_Counter
: Int
:= 0;
9900 procedure Add_Params_For_Variant_Components
;
9901 -- Add a struct TypeCode and a corresponding member name
9902 -- to the union parameter list.
9904 -- Ordering of declarations is a complete mess in this
9905 -- area, it is supposed to be types/varibles, then
9906 -- subprogram specs, then subprogram bodies ???
9908 ---------------------------------------
9909 -- Add_Params_For_Variant_Components --
9910 ---------------------------------------
9912 procedure Add_Params_For_Variant_Components
9914 S_Name
: constant Name_Id
:=
9915 New_External_Name
(U_Name
, 'S', -1);
9918 Get_Name_String
(S_Name
);
9919 Name_Str
:= String_From_Name_Buffer
;
9920 Initialize_Parameter_List
9921 (Name_Str
, Name_Str
, Struct_TC_Params
);
9923 -- Build struct parameters
9925 TC_Append_Record_Traversal
(Struct_TC_Params
,
9926 Component_List
(Variant
),
9930 Add_TypeCode_Parameter
9931 (Make_Constructed_TypeCode
9932 (RTE
(RE_TC_Struct
), Struct_TC_Params
),
9935 Add_String_Parameter
(Name_Str
, Union_TC_Params
);
9936 end Add_Params_For_Variant_Components
;
9939 Get_Name_String
(U_Name
);
9940 Name_Str
:= String_From_Name_Buffer
;
9942 Initialize_Parameter_List
9943 (Name_Str
, Name_Str
, Union_TC_Params
);
9945 Add_String_Parameter
(Name_Str
, Params
);
9947 -- Add union in enclosing parameter list
9949 Add_TypeCode_Parameter
9950 (Make_Constructed_TypeCode
9951 (RTE
(RE_TC_Union
), Union_TC_Params
),
9954 -- Build union parameters
9956 Add_TypeCode_Parameter
9957 (Discriminant_Type
, Union_TC_Params
);
9958 Add_Long_Parameter
(Default
, Union_TC_Params
);
9960 Variant
:= First_Non_Pragma
(Variants
(Field
));
9961 while Present
(Variant
) loop
9962 Choice
:= First
(Discrete_Choices
(Variant
));
9963 while Present
(Choice
) loop
9964 case Nkind
(Choice
) is
9967 L
: constant Uint
:=
9968 Expr_Value
(Low_Bound
(Choice
));
9969 H
: constant Uint
:=
9970 Expr_Value
(High_Bound
(Choice
));
9972 -- 3.8.1(8) guarantees that the bounds of
9973 -- this range are static.
9980 Expr
:= New_Occurrence_Of
(
9981 Get_Enum_Lit_From_Pos
(
9982 Discriminant_Type
, J
, Loc
), Loc
);
9985 Make_Integer_Literal
(Loc
, J
);
9987 Append_To
(Union_TC_Params
,
9988 Build_To_Any_Call
(Expr
, Decls
));
9989 Add_Params_For_Variant_Components
;
9994 when N_Others_Choice
=>
9995 Add_Long_Parameter
(
9996 Make_Integer_Literal
(Loc
, 0),
9998 Add_Params_For_Variant_Components
;
10001 Append_To
(Union_TC_Params
,
10002 Build_To_Any_Call
(Choice
, Decls
));
10003 Add_Params_For_Variant_Components
;
10009 Next_Non_Pragma
(Variant
);
10014 end TC_Rec_Add_Process_Element
;
10016 Type_Name_Str
: String_Id
;
10017 Type_Repo_Id_Str
: String_Id
;
10020 pragma Assert
(not Is_Itype
(Typ
));
10024 Make_Function_Specification
(Loc
,
10025 Defining_Unit_Name
=> Fnam
,
10026 Parameter_Specifications
=> Empty_List
,
10027 Result_Definition
=>
10028 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
10030 Build_Name_And_Repository_Id
(Typ
,
10031 Name_Str
=> Type_Name_Str
, Repo_Id_Str
=> Type_Repo_Id_Str
);
10032 Initialize_Parameter_List
10033 (Type_Name_Str
, Type_Repo_Id_Str
, Parameters
);
10035 if Is_Derived_Type
(Typ
)
10036 and then not Is_Tagged_Type
(Typ
)
10039 Parent_Type
: Entity_Id
:= Etype
(Typ
);
10042 if Is_Itype
(Parent_Type
) then
10044 -- Skip implicit base type
10046 Parent_Type
:= Etype
(Parent_Type
);
10049 Return_Alias_TypeCode
(
10050 Build_TypeCode_Call
(Loc
, Parent_Type
, Decls
));
10053 elsif Is_Integer_Type
(Typ
)
10054 or else Is_Unsigned_Type
(Typ
)
10056 Return_Alias_TypeCode
(
10057 Build_TypeCode_Call
(Loc
,
10058 Find_Numeric_Representation
(Typ
), Decls
));
10060 elsif Is_Record_Type
(Typ
)
10061 and then not Is_Tagged_Type
(Typ
)
10063 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
10064 Return_Alias_TypeCode
(
10065 Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10068 Disc
: Entity_Id
:= Empty
;
10069 Rdef
: constant Node_Id
:=
10070 Type_Definition
(Declaration_Node
(Typ
));
10071 Dummy_Counter
: Int
:= 0;
10073 -- First all discriminants
10075 if Has_Discriminants
(Typ
) then
10076 Disc
:= First_Discriminant
(Typ
);
10078 while Present
(Disc
) loop
10079 Add_TypeCode_Parameter
(
10080 Build_TypeCode_Call
(Loc
, Etype
(Disc
), Decls
),
10082 Get_Name_String
(Chars
(Disc
));
10083 Add_String_Parameter
(
10084 String_From_Name_Buffer
,
10086 Next_Discriminant
(Disc
);
10089 -- ... then all components
10091 TC_Append_Record_Traversal
10092 (Parameters
, Component_List
(Rdef
),
10093 Empty
, Dummy_Counter
);
10094 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10098 elsif Is_Array_Type
(Typ
) then
10100 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10101 Inner_TypeCode
: Node_Id
;
10102 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10103 Indx
: Node_Id
:= First_Index
(Typ
);
10106 Inner_TypeCode
:= Build_TypeCode_Call
(Loc
,
10107 Component_Type
(Typ
),
10110 for J
in 1 .. Ndim
loop
10111 if Constrained
then
10112 Inner_TypeCode
:= Make_Constructed_TypeCode
10113 (RTE
(RE_TC_Array
), New_List
(
10114 Build_To_Any_Call
(
10115 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10116 Make_Attribute_Reference
(Loc
,
10118 New_Occurrence_Of
(Typ
, Loc
),
10121 Expressions
=> New_List
(
10122 Make_Integer_Literal
(Loc
,
10125 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10128 -- Unconstrained case: add low bound for each
10131 Add_TypeCode_Parameter
10132 (Build_TypeCode_Call
(Loc
, Etype
(Indx
), Decls
),
10134 Get_Name_String
(New_External_Name
('L', J
));
10135 Add_String_Parameter
(
10136 String_From_Name_Buffer
,
10140 Inner_TypeCode
:= Make_Constructed_TypeCode
10141 (RTE
(RE_TC_Sequence
), New_List
(
10142 Build_To_Any_Call
(
10143 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10144 Make_Integer_Literal
(Loc
, 0)),
10146 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10150 if Constrained
then
10151 Return_Alias_TypeCode
(Inner_TypeCode
);
10153 Add_TypeCode_Parameter
(Inner_TypeCode
, Parameters
);
10155 Store_String_Char
('V');
10156 Add_String_Parameter
(End_String
, Parameters
);
10157 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10162 -- Default: type is represented as an opaque sequence of bytes
10164 Return_Alias_TypeCode
10165 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10169 Make_Subprogram_Body
(Loc
,
10170 Specification
=> Spec
,
10171 Declarations
=> Decls
,
10172 Handled_Statement_Sequence
=>
10173 Make_Handled_Sequence_Of_Statements
(Loc
,
10174 Statements
=> Stms
));
10175 end Build_TypeCode_Function
;
10177 ---------------------------------
10178 -- Find_Numeric_Representation --
10179 ---------------------------------
10181 function Find_Numeric_Representation
10182 (Typ
: Entity_Id
) return Entity_Id
10184 FST
: constant Entity_Id
:= First_Subtype
(Typ
);
10185 P_Size
: constant Uint
:= Esize
(FST
);
10188 if Is_Unsigned_Type
(Typ
) then
10189 if P_Size
<= Standard_Short_Short_Integer_Size
then
10190 return RTE
(RE_Short_Short_Unsigned
);
10192 elsif P_Size
<= Standard_Short_Integer_Size
then
10193 return RTE
(RE_Short_Unsigned
);
10195 elsif P_Size
<= Standard_Integer_Size
then
10196 return RTE
(RE_Unsigned
);
10198 elsif P_Size
<= Standard_Long_Integer_Size
then
10199 return RTE
(RE_Long_Unsigned
);
10202 return RTE
(RE_Long_Long_Unsigned
);
10205 elsif Is_Integer_Type
(Typ
) then
10206 if P_Size
<= Standard_Short_Short_Integer_Size
then
10207 return Standard_Short_Short_Integer
;
10209 elsif P_Size
<= Standard_Short_Integer_Size
then
10210 return Standard_Short_Integer
;
10212 elsif P_Size
<= Standard_Integer_Size
then
10213 return Standard_Integer
;
10215 elsif P_Size
<= Standard_Long_Integer_Size
then
10216 return Standard_Long_Integer
;
10219 return Standard_Long_Long_Integer
;
10222 elsif Is_Floating_Point_Type
(Typ
) then
10223 if P_Size
<= Standard_Short_Float_Size
then
10224 return Standard_Short_Float
;
10226 elsif P_Size
<= Standard_Float_Size
then
10227 return Standard_Float
;
10229 elsif P_Size
<= Standard_Long_Float_Size
then
10230 return Standard_Long_Float
;
10233 return Standard_Long_Long_Float
;
10237 raise Program_Error
;
10240 -- TBD: fixed point types???
10241 -- TBverified numeric types with a biased representation???
10243 end Find_Numeric_Representation
;
10245 ---------------------------
10246 -- Append_Array_Traversal --
10247 ---------------------------
10249 procedure Append_Array_Traversal
10252 Counter
: Entity_Id
:= Empty
;
10255 Loc
: constant Source_Ptr
:= Sloc
(Subprogram
);
10256 Typ
: constant Entity_Id
:= Etype
(Arry
);
10257 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10258 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10260 Inner_Any
, Inner_Counter
: Entity_Id
;
10262 Loop_Stm
: Node_Id
;
10263 Inner_Stmts
: constant List_Id
:= New_List
;
10266 if Depth
> Ndim
then
10268 -- Processing for one element of an array
10271 Element_Expr
: constant Node_Id
:=
10272 Make_Indexed_Component
(Loc
,
10273 New_Occurrence_Of
(Arry
, Loc
),
10277 Set_Etype
(Element_Expr
, Component_Type
(Typ
));
10278 Add_Process_Element
(Stmts
,
10280 Counter
=> Counter
,
10281 Datum
=> Element_Expr
);
10287 Append_To
(Indices
,
10288 Make_Identifier
(Loc
, New_External_Name
('L', Depth
)));
10290 if not Constrained
or else Depth
> 1 then
10291 Inner_Any
:= Make_Defining_Identifier
(Loc
,
10292 New_External_Name
('A', Depth
));
10293 Set_Etype
(Inner_Any
, RTE
(RE_Any
));
10295 Inner_Any
:= Empty
;
10298 if Present
(Counter
) then
10299 Inner_Counter
:= Make_Defining_Identifier
(Loc
,
10300 New_External_Name
('J', Depth
));
10302 Inner_Counter
:= Empty
;
10306 Loop_Any
: Node_Id
:= Inner_Any
;
10309 -- For the first dimension of a constrained array, we add
10310 -- elements directly in the corresponding Any; there is no
10311 -- intervening inner Any.
10313 if No
(Loop_Any
) then
10317 Append_Array_Traversal
(Inner_Stmts
,
10319 Counter
=> Inner_Counter
,
10320 Depth
=> Depth
+ 1);
10324 Make_Implicit_Loop_Statement
(Subprogram
,
10325 Iteration_Scheme
=>
10326 Make_Iteration_Scheme
(Loc
,
10327 Loop_Parameter_Specification
=>
10328 Make_Loop_Parameter_Specification
(Loc
,
10329 Defining_Identifier
=>
10330 Make_Defining_Identifier
(Loc
,
10331 Chars
=> New_External_Name
('L', Depth
)),
10333 Discrete_Subtype_Definition
=>
10334 Make_Attribute_Reference
(Loc
,
10335 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10336 Attribute_Name
=> Name_Range
,
10338 Expressions
=> New_List
(
10339 Make_Integer_Literal
(Loc
, Depth
))))),
10340 Statements
=> Inner_Stmts
);
10343 Decls
: constant List_Id
:= New_List
;
10344 Dimen_Stmts
: constant List_Id
:= New_List
;
10345 Length_Node
: Node_Id
;
10347 Inner_Any_TypeCode
: constant Entity_Id
:=
10348 Make_Defining_Identifier
(Loc
,
10349 New_External_Name
('T', Depth
));
10351 Inner_Any_TypeCode_Expr
: Node_Id
;
10355 if Constrained
then
10356 Inner_Any_TypeCode_Expr
:=
10357 Make_Function_Call
(Loc
,
10359 New_Occurrence_Of
(RTE
(RE_Get_TC
), Loc
),
10360 Parameter_Associations
=> New_List
(
10361 New_Occurrence_Of
(Any
, Loc
)));
10363 Inner_Any_TypeCode_Expr
:=
10364 Make_Function_Call
(Loc
,
10366 New_Occurrence_Of
(RTE
(RE_Any_Member_Type
), Loc
),
10367 Parameter_Associations
=> New_List
(
10368 New_Occurrence_Of
(Any
, Loc
),
10369 Make_Integer_Literal
(Loc
, Ndim
)));
10372 Inner_Any_TypeCode_Expr
:=
10373 Make_Function_Call
(Loc
,
10375 New_Occurrence_Of
(RTE
(RE_Content_Type
), Loc
),
10376 Parameter_Associations
=> New_List
(
10377 Make_Identifier
(Loc
,
10378 New_External_Name
('T', Depth
- 1))));
10382 Make_Object_Declaration
(Loc
,
10383 Defining_Identifier
=> Inner_Any_TypeCode
,
10384 Constant_Present
=> True,
10385 Object_Definition
=> New_Occurrence_Of
(
10386 RTE
(RE_TypeCode
), Loc
),
10387 Expression
=> Inner_Any_TypeCode_Expr
));
10389 if Present
(Inner_Any
) then
10391 Make_Object_Declaration
(Loc
,
10392 Defining_Identifier
=> Inner_Any
,
10393 Object_Definition
=>
10394 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
10396 Make_Function_Call
(Loc
,
10398 New_Occurrence_Of
(
10399 RTE
(RE_Create_Any
), Loc
),
10400 Parameter_Associations
=> New_List
(
10401 New_Occurrence_Of
(Inner_Any_TypeCode
, Loc
)))));
10404 if Present
(Inner_Counter
) then
10406 Make_Object_Declaration
(Loc
,
10407 Defining_Identifier
=> Inner_Counter
,
10408 Object_Definition
=>
10409 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
10411 Make_Integer_Literal
(Loc
, 0)));
10414 if not Constrained
then
10415 Length_Node
:= Make_Attribute_Reference
(Loc
,
10416 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10417 Attribute_Name
=> Name_Length
,
10419 New_List
(Make_Integer_Literal
(Loc
, Depth
)));
10420 Set_Etype
(Length_Node
, RTE
(RE_Long_Unsigned
));
10422 Add_Process_Element
(Dimen_Stmts
,
10423 Datum
=> Length_Node
,
10425 Counter
=> Inner_Counter
);
10428 -- Loop_Stm does approrpriate processing for each element
10431 Append_To
(Dimen_Stmts
, Loop_Stm
);
10433 -- Link outer and inner any
10435 if Present
(Inner_Any
) then
10436 Add_Process_Element
(Dimen_Stmts
,
10438 Counter
=> Counter
,
10439 Datum
=> New_Occurrence_Of
(Inner_Any
, Loc
));
10443 Make_Block_Statement
(Loc
,
10446 Handled_Statement_Sequence
=>
10447 Make_Handled_Sequence_Of_Statements
(Loc
,
10448 Statements
=> Dimen_Stmts
)));
10450 end Append_Array_Traversal
;
10452 -----------------------------------------
10453 -- Make_Stream_Procedure_Function_Name --
10454 -----------------------------------------
10456 function Make_Stream_Procedure_Function_Name
10459 Nam
: Name_Id
) return Entity_Id
10462 -- For tagged types, we use a canonical name so that it matches
10463 -- the primitive spec. For all other cases, we use a serialized
10464 -- name so that multiple generations of the same procedure do not
10467 if Is_Tagged_Type
(Typ
) then
10468 return Make_Defining_Identifier
(Loc
, Nam
);
10470 return Make_Defining_Identifier
(Loc
,
10472 New_External_Name
(Nam
, ' ', Increment_Serial_Number
));
10474 end Make_Stream_Procedure_Function_Name
;
10477 -----------------------------------
10478 -- Reserve_NamingContext_Methods --
10479 -----------------------------------
10481 procedure Reserve_NamingContext_Methods
is
10482 Str_Resolve
: constant String := "resolve";
10484 Name_Buffer
(1 .. Str_Resolve
'Length) := Str_Resolve
;
10485 Name_Len
:= Str_Resolve
'Length;
10486 Overload_Counter_Table
.Set
(Name_Find
, 1);
10487 end Reserve_NamingContext_Methods
;
10489 end PolyORB_Support
;
10491 -------------------------------
10492 -- RACW_Type_Is_Asynchronous --
10493 -------------------------------
10495 procedure RACW_Type_Is_Asynchronous
(RACW_Type
: Entity_Id
) is
10496 Asynchronous_Flag
: constant Entity_Id
:=
10497 Asynchronous_Flags_Table
.Get
(RACW_Type
);
10499 Replace
(Expression
(Parent
(Asynchronous_Flag
)),
10500 New_Occurrence_Of
(Standard_True
, Sloc
(Asynchronous_Flag
)));
10501 end RACW_Type_Is_Asynchronous
;
10503 -------------------------
10504 -- RCI_Package_Locator --
10505 -------------------------
10507 function RCI_Package_Locator
10509 Package_Spec
: Node_Id
) return Node_Id
10512 Pkg_Name
: String_Id
;
10515 Get_Library_Unit_Name_String
(Package_Spec
);
10516 Pkg_Name
:= String_From_Name_Buffer
;
10518 Make_Package_Instantiation
(Loc
,
10519 Defining_Unit_Name
=>
10520 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
10522 New_Occurrence_Of
(RTE
(RE_RCI_Locator
), Loc
),
10523 Generic_Associations
=> New_List
(
10524 Make_Generic_Association
(Loc
,
10526 Make_Identifier
(Loc
, Name_RCI_Name
),
10527 Explicit_Generic_Actual_Parameter
=>
10528 Make_String_Literal
(Loc
,
10529 Strval
=> Pkg_Name
))));
10531 RCI_Locator_Table
.Set
(Defining_Unit_Name
(Package_Spec
),
10532 Defining_Unit_Name
(Inst
));
10534 end RCI_Package_Locator
;
10536 -----------------------------------------------
10537 -- Remote_Types_Tagged_Full_View_Encountered --
10538 -----------------------------------------------
10540 procedure Remote_Types_Tagged_Full_View_Encountered
10541 (Full_View
: Entity_Id
)
10543 Stub_Elements
: constant Stub_Structure
:=
10544 Stubs_Table
.Get
(Full_View
);
10546 if Stub_Elements
/= Empty_Stub_Structure
then
10547 Add_RACW_Primitive_Declarations_And_Bodies
10549 Stub_Elements
.RPC_Receiver_Decl
,
10550 List_Containing
(Declaration_Node
(Full_View
)));
10552 end Remote_Types_Tagged_Full_View_Encountered
;
10554 -------------------
10555 -- Scope_Of_Spec --
10556 -------------------
10558 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
is
10559 Unit_Name
: Node_Id
;
10562 Unit_Name
:= Defining_Unit_Name
(Spec
);
10563 while Nkind
(Unit_Name
) /= N_Defining_Identifier
loop
10564 Unit_Name
:= Defining_Identifier
(Unit_Name
);
10570 ----------------------
10571 -- Set_Renaming_TSS --
10572 ----------------------
10574 procedure Set_Renaming_TSS
10577 TSS_Nam
: TSS_Name_Type
)
10579 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
10580 Spec
: constant Node_Id
:= Parent
(Nam
);
10582 TSS_Node
: constant Node_Id
:=
10583 Make_Subprogram_Renaming_Declaration
(Loc
,
10585 Copy_Specification
(Loc
,
10587 New_Name
=> Make_TSS_Name
(Typ
, TSS_Nam
)),
10588 Name
=> New_Occurrence_Of
(Nam
, Loc
));
10590 Snam
: constant Entity_Id
:=
10591 Defining_Unit_Name
(Specification
(TSS_Node
));
10594 if Nkind
(Spec
) = N_Function_Specification
then
10595 Set_Ekind
(Snam
, E_Function
);
10596 Set_Etype
(Snam
, Entity
(Result_Definition
(Spec
)));
10598 Set_Ekind
(Snam
, E_Procedure
);
10599 Set_Etype
(Snam
, Standard_Void_Type
);
10602 Set_TSS
(Typ
, Snam
);
10603 end Set_Renaming_TSS
;
10605 ----------------------------------------------
10606 -- Specific_Add_Obj_RPC_Receiver_Completion --
10607 ----------------------------------------------
10609 procedure Specific_Add_Obj_RPC_Receiver_Completion
10612 RPC_Receiver
: Entity_Id
;
10613 Stub_Elements
: Stub_Structure
) is
10615 case Get_PCS_Name
is
10616 when Name_PolyORB_DSA
=>
10617 PolyORB_Support
.Add_Obj_RPC_Receiver_Completion
(Loc
,
10618 Decls
, RPC_Receiver
, Stub_Elements
);
10620 GARLIC_Support
.Add_Obj_RPC_Receiver_Completion
(Loc
,
10621 Decls
, RPC_Receiver
, Stub_Elements
);
10623 end Specific_Add_Obj_RPC_Receiver_Completion
;
10625 --------------------------------
10626 -- Specific_Add_RACW_Features --
10627 --------------------------------
10629 procedure Specific_Add_RACW_Features
10630 (RACW_Type
: Entity_Id
;
10632 Stub_Type
: Entity_Id
;
10633 Stub_Type_Access
: Entity_Id
;
10634 RPC_Receiver_Decl
: Node_Id
;
10635 Declarations
: List_Id
) is
10637 case Get_PCS_Name
is
10638 when Name_PolyORB_DSA
=>
10639 PolyORB_Support
.Add_RACW_Features
(
10648 GARLIC_Support
.Add_RACW_Features
(
10655 end Specific_Add_RACW_Features
;
10657 --------------------------------
10658 -- Specific_Add_RAST_Features --
10659 --------------------------------
10661 procedure Specific_Add_RAST_Features
10662 (Vis_Decl
: Node_Id
;
10663 RAS_Type
: Entity_Id
) is
10665 case Get_PCS_Name
is
10666 when Name_PolyORB_DSA
=>
10667 PolyORB_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
10669 GARLIC_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
10671 end Specific_Add_RAST_Features
;
10673 --------------------------------------------------
10674 -- Specific_Add_Receiving_Stubs_To_Declarations --
10675 --------------------------------------------------
10677 procedure Specific_Add_Receiving_Stubs_To_Declarations
10678 (Pkg_Spec
: Node_Id
;
10682 case Get_PCS_Name
is
10683 when Name_PolyORB_DSA
=>
10684 PolyORB_Support
.Add_Receiving_Stubs_To_Declarations
(
10687 GARLIC_Support
.Add_Receiving_Stubs_To_Declarations
(
10690 end Specific_Add_Receiving_Stubs_To_Declarations
;
10692 ------------------------------------------
10693 -- Specific_Build_General_Calling_Stubs --
10694 ------------------------------------------
10696 procedure Specific_Build_General_Calling_Stubs
10698 Statements
: List_Id
;
10699 Target
: RPC_Target
;
10700 Subprogram_Id
: Node_Id
;
10701 Asynchronous
: Node_Id
:= Empty
;
10702 Is_Known_Asynchronous
: Boolean := False;
10703 Is_Known_Non_Asynchronous
: Boolean := False;
10704 Is_Function
: Boolean;
10706 Stub_Type
: Entity_Id
:= Empty
;
10707 RACW_Type
: Entity_Id
:= Empty
;
10711 case Get_PCS_Name
is
10712 when Name_PolyORB_DSA
=>
10713 PolyORB_Support
.Build_General_Calling_Stubs
(
10719 Is_Known_Asynchronous
,
10720 Is_Known_Non_Asynchronous
,
10727 GARLIC_Support
.Build_General_Calling_Stubs
(
10731 Target
.RPC_Receiver
,
10734 Is_Known_Asynchronous
,
10735 Is_Known_Non_Asynchronous
,
10742 end Specific_Build_General_Calling_Stubs
;
10744 --------------------------------------
10745 -- Specific_Build_RPC_Receiver_Body --
10746 --------------------------------------
10748 procedure Specific_Build_RPC_Receiver_Body
10749 (RPC_Receiver
: Entity_Id
;
10750 Request
: out Entity_Id
;
10751 Subp_Id
: out Entity_Id
;
10752 Subp_Index
: out Entity_Id
;
10753 Stmts
: out List_Id
;
10754 Decl
: out Node_Id
)
10757 case Get_PCS_Name
is
10758 when Name_PolyORB_DSA
=>
10759 PolyORB_Support
.Build_RPC_Receiver_Body
10767 GARLIC_Support
.Build_RPC_Receiver_Body
10775 end Specific_Build_RPC_Receiver_Body
;
10777 --------------------------------
10778 -- Specific_Build_Stub_Target --
10779 --------------------------------
10781 function Specific_Build_Stub_Target
10784 RCI_Locator
: Entity_Id
;
10785 Controlling_Parameter
: Entity_Id
) return RPC_Target
10788 case Get_PCS_Name
is
10789 when Name_PolyORB_DSA
=>
10790 return PolyORB_Support
.Build_Stub_Target
(Loc
,
10791 Decls
, RCI_Locator
, Controlling_Parameter
);
10793 return GARLIC_Support
.Build_Stub_Target
(Loc
,
10794 Decls
, RCI_Locator
, Controlling_Parameter
);
10796 end Specific_Build_Stub_Target
;
10798 ------------------------------
10799 -- Specific_Build_Stub_Type --
10800 ------------------------------
10802 procedure Specific_Build_Stub_Type
10803 (RACW_Type
: Entity_Id
;
10804 Stub_Type
: Entity_Id
;
10805 Stub_Type_Decl
: out Node_Id
;
10806 RPC_Receiver_Decl
: out Node_Id
)
10809 case Get_PCS_Name
is
10810 when Name_PolyORB_DSA
=>
10811 PolyORB_Support
.Build_Stub_Type
(
10812 RACW_Type
, Stub_Type
,
10813 Stub_Type_Decl
, RPC_Receiver_Decl
);
10815 GARLIC_Support
.Build_Stub_Type
(
10816 RACW_Type
, Stub_Type
,
10817 Stub_Type_Decl
, RPC_Receiver_Decl
);
10819 end Specific_Build_Stub_Type
;
10821 function Specific_Build_Subprogram_Receiving_Stubs
10822 (Vis_Decl
: Node_Id
;
10823 Asynchronous
: Boolean;
10824 Dynamically_Asynchronous
: Boolean := False;
10825 Stub_Type
: Entity_Id
:= Empty
;
10826 RACW_Type
: Entity_Id
:= Empty
;
10827 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
10830 case Get_PCS_Name
is
10831 when Name_PolyORB_DSA
=>
10832 return PolyORB_Support
.Build_Subprogram_Receiving_Stubs
(
10835 Dynamically_Asynchronous
,
10840 return GARLIC_Support
.Build_Subprogram_Receiving_Stubs
(
10843 Dynamically_Asynchronous
,
10848 end Specific_Build_Subprogram_Receiving_Stubs
;
10850 --------------------------
10851 -- Underlying_RACW_Type --
10852 --------------------------
10854 function Underlying_RACW_Type
(RAS_Typ
: Entity_Id
) return Entity_Id
is
10855 Record_Type
: Entity_Id
;
10858 if Ekind
(RAS_Typ
) = E_Record_Type
then
10859 Record_Type
:= RAS_Typ
;
10861 pragma Assert
(Present
(Equivalent_Type
(RAS_Typ
)));
10862 Record_Type
:= Equivalent_Type
(RAS_Typ
);
10866 Etype
(Subtype_Indication
(
10867 Component_Definition
(
10868 First
(Component_Items
(Component_List
(
10869 Type_Definition
(Declaration_Node
(Record_Type
))))))));
10870 end Underlying_RACW_Type
;