1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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 No (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),
2259 Null_Exclusion_Present =>
2260 Null_Exclusion_Present (Current_Type));
2264 Make_Access_Definition (Loc,
2266 New_Occurrence_Of (Current_Etype, Loc),
2267 Null_Exclusion_Present =>
2268 Null_Exclusion_Present (Current_Type));
2272 Current_Etype := Entity (Current_Type);
2274 if Present (Object_Type)
2275 and then Current_Etype = Object_Type
2277 Current_Type := New_Occurrence_Of (Stub_Type, Loc);
2279 Current_Type := New_Occurrence_Of (Current_Etype, Loc);
2283 New_Identifier := Make_Defining_Identifier (Loc,
2284 Chars (Current_Identifier));
2286 Append_To (Parameters,
2287 Make_Parameter_Specification (Loc,
2288 Defining_Identifier => New_Identifier,
2289 Parameter_Type => Current_Type,
2290 In_Present => In_Present (Current_Parameter),
2291 Out_Present => Out_Present (Current_Parameter),
2293 New_Copy_Tree (Expression (Current_Parameter))));
2295 -- For a regular formal parameter (that needs to be marshalled
2296 -- in the context of remote calls), set the Etype now, because
2297 -- marshalling processing might need it.
2299 if Is_Entity_Name (Current_Type) then
2300 Set_Etype (New_Identifier, Entity (Current_Type));
2302 -- Current_Type is an access definition, special processing
2303 -- (not requiring etype) will occur for marshalling.
2309 Next (Current_Parameter);
2313 case Nkind (Spec) is
2315 when N_Function_Specification | N_Access_Function_Definition =>
2317 Make_Function_Specification (Loc,
2318 Defining_Unit_Name =>
2319 Make_Defining_Identifier (Loc,
2320 Chars => Name_For_New_Spec),
2321 Parameter_Specifications => Parameters,
2322 Result_Definition =>
2323 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2325 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2327 Make_Procedure_Specification (Loc,
2328 Defining_Unit_Name =>
2329 Make_Defining_Identifier (Loc,
2330 Chars => Name_For_New_Spec),
2331 Parameter_Specifications => Parameters);
2334 raise Program_Error;
2336 end Copy_Specification;
2338 ---------------------------
2339 -- Could_Be_Asynchronous --
2340 ---------------------------
2342 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2343 Current_Parameter : Node_Id;
2346 if Present (Parameter_Specifications (Spec)) then
2347 Current_Parameter := First (Parameter_Specifications (Spec));
2348 while Present (Current_Parameter) loop
2349 if Out_Present (Current_Parameter) then
2353 Next (Current_Parameter);
2358 end Could_Be_Asynchronous;
2360 ---------------------------
2361 -- Declare_Create_NVList --
2362 ---------------------------
2364 procedure Declare_Create_NVList
2372 Make_Object_Declaration (Loc,
2373 Defining_Identifier => NVList,
2374 Aliased_Present => False,
2375 Object_Definition =>
2376 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2379 Make_Procedure_Call_Statement (Loc,
2381 New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2382 Parameter_Associations => New_List (
2383 New_Occurrence_Of (NVList, Loc))));
2384 end Declare_Create_NVList;
2386 ---------------------------------------------
2387 -- Expand_All_Calls_Remote_Subprogram_Call --
2388 ---------------------------------------------
2390 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2391 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2392 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2393 Loc : constant Source_Ptr := Sloc (N);
2394 RCI_Locator : Node_Id;
2395 RCI_Cache : Entity_Id;
2396 Calling_Stubs : Node_Id;
2397 E_Calling_Stubs : Entity_Id;
2400 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2402 if E_Calling_Stubs = Empty then
2403 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
2405 if RCI_Cache = Empty then
2408 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2409 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
2411 -- The RCI_Locator package is inserted at the top level in the
2412 -- current unit, and must appear in the proper scope, so that it
2413 -- is not prematurely removed by the GCC back-end.
2416 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2419 if Ekind (Scop) = E_Package_Body then
2420 New_Scope (Spec_Entity (Scop));
2422 elsif Ekind (Scop) = E_Subprogram_Body then
2424 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2430 Analyze (RCI_Locator);
2434 RCI_Cache := Defining_Unit_Name (RCI_Locator);
2437 RCI_Locator := Parent (RCI_Cache);
2440 Calling_Stubs := Build_Subprogram_Calling_Stubs
2441 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2443 Build_Subprogram_Id (Loc, Called_Subprogram),
2444 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2446 Is_Asynchronous (Called_Subprogram),
2447 Locator => RCI_Cache,
2448 New_Name => New_Internal_Name ('S
'));
2449 Insert_After (RCI_Locator, Calling_Stubs);
2450 Analyze (Calling_Stubs);
2451 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2454 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2455 end Expand_All_Calls_Remote_Subprogram_Call;
2457 ---------------------------------
2458 -- Expand_Calling_Stubs_Bodies --
2459 ---------------------------------
2461 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2462 Spec : constant Node_Id := Specification (Unit_Node);
2463 Decls : constant List_Id := Visible_Declarations (Spec);
2465 New_Scope (Scope_Of_Spec (Spec));
2466 Add_Calling_Stubs_To_Declarations
2467 (Specification (Unit_Node), Decls);
2469 end Expand_Calling_Stubs_Bodies;
2471 -----------------------------------
2472 -- Expand_Receiving_Stubs_Bodies --
2473 -----------------------------------
2475 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2481 if Nkind (Unit_Node) = N_Package_Declaration then
2482 Spec := Specification (Unit_Node);
2483 Decls := Private_Declarations (Spec);
2486 Decls := Visible_Declarations (Spec);
2489 New_Scope (Scope_Of_Spec (Spec));
2490 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls);
2494 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2495 Decls := Declarations (Unit_Node);
2496 New_Scope (Scope_Of_Spec (Unit_Node));
2498 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Temp);
2499 Insert_List_Before (First (Decls), Temp);
2503 end Expand_Receiving_Stubs_Bodies;
2505 --------------------
2506 -- GARLIC_Support --
2507 --------------------
2509 package body GARLIC_Support is
2511 -- Local subprograms
2513 procedure Add_RACW_Read_Attribute
2514 (RACW_Type : Entity_Id;
2515 Stub_Type : Entity_Id;
2516 Stub_Type_Access : Entity_Id;
2517 Declarations : List_Id);
2518 -- Add Read attribute in Decls for the RACW type. The Read attribute
2519 -- is added right after the RACW_Type declaration while the body is
2520 -- inserted after Declarations.
2522 procedure Add_RACW_Write_Attribute
2523 (RACW_Type : Entity_Id;
2524 Stub_Type : Entity_Id;
2525 Stub_Type_Access : Entity_Id;
2526 RPC_Receiver : Node_Id;
2527 Declarations : List_Id);
2528 -- Same thing for the Write attribute
2530 function Stream_Parameter return Node_Id;
2531 function Result return Node_Id;
2532 function Object return Node_Id renames Result;
2533 -- Functions to create occurrences of the formal parameter names of
2534 -- the 'Read
and 'Write attributes.
2537 -- Shared source location used by Add_{Read,Write}_Read_Attribute
2538 -- and their ancillary subroutines (set on entry by Add_RACW_Features).
2540 procedure Add_RAS_Access_TSS (N : Node_Id);
2541 -- Add a subprogram body for RAS Access TSS
2543 -------------------------------------
2544 -- Add_Obj_RPC_Receiver_Completion --
2545 -------------------------------------
2547 procedure Add_Obj_RPC_Receiver_Completion
2550 RPC_Receiver : Entity_Id;
2551 Stub_Elements : Stub_Structure) is
2553 -- The RPC receiver body should not be the completion of the
2554 -- declaration recorded in the stub structure, because then the
2555 -- occurrences of the formal parameters within the body should
2556 -- refer to the entities from the declaration, not from the
2557 -- completion, to which we do not have easy access. Instead, the
2558 -- RPC receiver body acts as its own declaration, and the RPC
2559 -- receiver declaration is completed by a renaming-as-body.
2562 Make_Subprogram_Renaming_Declaration (Loc,
2564 Copy_Specification (Loc,
2565 Specification (Stub_Elements.RPC_Receiver_Decl)),
2566 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2567 end Add_Obj_RPC_Receiver_Completion;
2569 -----------------------
2570 -- Add_RACW_Features --
2571 -----------------------
2573 procedure Add_RACW_Features
2574 (RACW_Type : Entity_Id;
2575 Stub_Type : Entity_Id;
2576 Stub_Type_Access : Entity_Id;
2577 RPC_Receiver_Decl : Node_Id;
2578 Declarations : List_Id)
2580 RPC_Receiver : Node_Id;
2581 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2584 Loc := Sloc (RACW_Type);
2588 -- For a RAS, the RPC receiver is that of the RCI unit,
2589 -- not that of the corresponding distributed object type.
2590 -- We retrieve its address from the local proxy object.
2592 RPC_Receiver := Make_Selected_Component (Loc,
2594 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2595 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2598 RPC_Receiver := Make_Attribute_Reference (Loc,
2599 Prefix => New_Occurrence_Of (
2600 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2601 Attribute_Name => Name_Address);
2604 Add_RACW_Write_Attribute (
2611 Add_RACW_Read_Attribute (
2616 end Add_RACW_Features;
2618 -----------------------------
2619 -- Add_RACW_Read_Attribute --
2620 -----------------------------
2622 procedure Add_RACW_Read_Attribute
2623 (RACW_Type : Entity_Id;
2624 Stub_Type : Entity_Id;
2625 Stub_Type_Access : Entity_Id;
2626 Declarations : List_Id)
2628 Proc_Decl : Node_Id;
2629 Attr_Decl : Node_Id;
2631 Body_Node : Node_Id;
2634 Statements : List_Id;
2635 Local_Statements : List_Id;
2636 Remote_Statements : List_Id;
2637 -- Various parts of the procedure
2639 Procedure_Name : constant Name_Id :=
2640 New_Internal_Name ('R
');
2641 Source_Partition : constant Entity_Id :=
2642 Make_Defining_Identifier
2643 (Loc, New_Internal_Name ('P
'));
2644 Source_Receiver : constant Entity_Id :=
2645 Make_Defining_Identifier
2646 (Loc, New_Internal_Name ('S
'));
2647 Source_Address : constant Entity_Id :=
2648 Make_Defining_Identifier
2649 (Loc, New_Internal_Name ('P
'));
2650 Local_Stub : constant Entity_Id :=
2651 Make_Defining_Identifier
2652 (Loc, New_Internal_Name ('L
'));
2653 Stubbed_Result : constant Entity_Id :=
2654 Make_Defining_Identifier
2655 (Loc, New_Internal_Name ('S
'));
2656 Asynchronous_Flag : constant Entity_Id :=
2657 Asynchronous_Flags_Table.Get (RACW_Type);
2658 pragma Assert (Present (Asynchronous_Flag));
2660 -- Start of processing for Add_RACW_Read_Attribute
2663 -- Generate object declarations
2666 Make_Object_Declaration (Loc,
2667 Defining_Identifier => Source_Partition,
2668 Object_Definition =>
2669 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
2671 Make_Object_Declaration (Loc,
2672 Defining_Identifier => Source_Receiver,
2673 Object_Definition =>
2674 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2676 Make_Object_Declaration (Loc,
2677 Defining_Identifier => Source_Address,
2678 Object_Definition =>
2679 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2681 Make_Object_Declaration (Loc,
2682 Defining_Identifier => Local_Stub,
2683 Aliased_Present => True,
2684 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
2686 Make_Object_Declaration (Loc,
2687 Defining_Identifier => Stubbed_Result,
2688 Object_Definition =>
2689 New_Occurrence_Of (Stub_Type_Access, Loc),
2691 Make_Attribute_Reference (Loc,
2693 New_Occurrence_Of (Local_Stub, Loc),
2695 Name_Unchecked_Access)));
2697 -- Read the source Partition_ID and RPC_Receiver from incoming stream
2699 Statements := New_List (
2700 Make_Attribute_Reference (Loc,
2702 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
2703 Attribute_Name => Name_Read,
2704 Expressions => New_List (
2706 New_Occurrence_Of (Source_Partition, Loc))),
2708 Make_Attribute_Reference (Loc,
2710 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2713 Expressions => New_List (
2715 New_Occurrence_Of (Source_Receiver, Loc))),
2717 Make_Attribute_Reference (Loc,
2719 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2722 Expressions => New_List (
2724 New_Occurrence_Of (Source_Address, Loc))));
2726 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
2728 Set_Etype (Stubbed_Result, Stub_Type_Access);
2730 -- If the Address is Null_Address, then return a null object
2732 Append_To (Statements,
2733 Make_Implicit_If_Statement (RACW_Type,
2736 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
2737 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
2738 Then_Statements => New_List (
2739 Make_Assignment_Statement (Loc,
2741 Expression => Make_Null (Loc)),
2742 Make_Return_Statement (Loc))));
2744 -- If the RACW denotes an object created on the current partition,
2745 -- Local_Statements will be executed. The real object will be used.
2747 Local_Statements := New_List (
2748 Make_Assignment_Statement (Loc,
2751 Unchecked_Convert_To (RACW_Type,
2752 OK_Convert_To (RTE (RE_Address),
2753 New_Occurrence_Of (Source_Address, Loc)))));
2755 -- If the object is located on another partition, then a stub object
2756 -- will be created with all the information needed to rebuild the
2757 -- real object at the other end.
2759 Remote_Statements := New_List (
2761 Make_Assignment_Statement (Loc,
2762 Name => Make_Selected_Component (Loc,
2763 Prefix => Stubbed_Result,
2764 Selector_Name => Name_Origin),
2766 New_Occurrence_Of (Source_Partition, Loc)),
2768 Make_Assignment_Statement (Loc,
2769 Name => Make_Selected_Component (Loc,
2770 Prefix => Stubbed_Result,
2771 Selector_Name => Name_Receiver),
2773 New_Occurrence_Of (Source_Receiver, Loc)),
2775 Make_Assignment_Statement (Loc,
2776 Name => Make_Selected_Component (Loc,
2777 Prefix => Stubbed_Result,
2778 Selector_Name => Name_Addr),
2780 New_Occurrence_Of (Source_Address, Loc)));
2782 Append_To (Remote_Statements,
2783 Make_Assignment_Statement (Loc,
2784 Name => Make_Selected_Component (Loc,
2785 Prefix => Stubbed_Result,
2786 Selector_Name => Name_Asynchronous),
2788 New_Occurrence_Of (Asynchronous_Flag, Loc)));
2790 Append_List_To (Remote_Statements,
2791 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
2792 -- ??? Issue with asynchronous calls here: the Asynchronous
2793 -- flag is set on the stub type if, and only if, the RACW type
2794 -- has a pragma Asynchronous. This is incorrect for RACWs that
2795 -- implement RAS types, because in that case the /designated
2796 -- subprogram/ (not the type) might be asynchronous, and
2797 -- that causes the stub to need to be asynchronous too.
2798 -- A solution is to transport a RAS as a struct containing
2799 -- a RACW and an asynchronous flag, and to properly alter
2800 -- the Asynchronous component in the stub type in the RAS's
2803 Append_To (Remote_Statements,
2804 Make_Assignment_Statement (Loc,
2806 Expression => Unchecked_Convert_To (RACW_Type,
2807 New_Occurrence_Of (Stubbed_Result, Loc))));
2809 -- Distinguish between the local and remote cases, and execute the
2810 -- appropriate piece of code.
2812 Append_To (Statements,
2813 Make_Implicit_If_Statement (RACW_Type,
2817 Make_Function_Call (Loc,
2818 Name => New_Occurrence_Of (
2819 RTE (RE_Get_Local_Partition_Id), Loc)),
2820 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
2821 Then_Statements => Local_Statements,
2822 Else_Statements => Remote_Statements));
2824 Build_Stream_Procedure
2825 (Loc, RACW_Type, Body_Node,
2826 Make_Defining_Identifier (Loc, Procedure_Name),
2827 Statements, Outp => True);
2828 Set_Declarations (Body_Node, Decls);
2830 Proc_Decl := Make_Subprogram_Declaration (Loc,
2831 Copy_Specification (Loc, Specification (Body_Node)));
2834 Make_Attribute_Definition_Clause (Loc,
2835 Name => New_Occurrence_Of (RACW_Type, Loc),
2839 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
2841 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
2842 Insert_After (Proc_Decl, Attr_Decl);
2843 Append_To (Declarations, Body_Node);
2844 end Add_RACW_Read_Attribute;
2846 ------------------------------
2847 -- Add_RACW_Write_Attribute --
2848 ------------------------------
2850 procedure Add_RACW_Write_Attribute
2851 (RACW_Type : Entity_Id;
2852 Stub_Type : Entity_Id;
2853 Stub_Type_Access : Entity_Id;
2854 RPC_Receiver : Node_Id;
2855 Declarations : List_Id)
2857 Body_Node : Node_Id;
2858 Proc_Decl : Node_Id;
2859 Attr_Decl : Node_Id;
2861 Statements : List_Id;
2862 Local_Statements : List_Id;
2863 Remote_Statements : List_Id;
2864 Null_Statements : List_Id;
2866 Procedure_Name : constant Name_Id := New_Internal_Name ('R
');
2869 -- Build the code fragment corresponding to the marshalling of a
2872 Local_Statements := New_List (
2874 Pack_Entity_Into_Stream_Access (Loc,
2875 Stream => Stream_Parameter,
2876 Object => RTE (RE_Get_Local_Partition_Id)),
2878 Pack_Node_Into_Stream_Access (Loc,
2879 Stream => Stream_Parameter,
2880 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
2881 Etyp => RTE (RE_Unsigned_64)),
2883 Pack_Node_Into_Stream_Access (Loc,
2884 Stream => Stream_Parameter,
2885 Object => OK_Convert_To (RTE (RE_Unsigned_64),
2886 Make_Attribute_Reference (Loc,
2888 Make_Explicit_Dereference (Loc,
2890 Attribute_Name => Name_Address)),
2891 Etyp => RTE (RE_Unsigned_64)));
2893 -- Build the code fragment corresponding to the marshalling of
2896 Remote_Statements := New_List (
2898 Pack_Node_Into_Stream_Access (Loc,
2899 Stream => Stream_Parameter,
2901 Make_Selected_Component (Loc,
2902 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2905 Make_Identifier (Loc, Name_Origin)),
2906 Etyp => RTE (RE_Partition_ID)),
2908 Pack_Node_Into_Stream_Access (Loc,
2909 Stream => Stream_Parameter,
2911 Make_Selected_Component (Loc,
2912 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2915 Make_Identifier (Loc, Name_Receiver)),
2916 Etyp => RTE (RE_Unsigned_64)),
2918 Pack_Node_Into_Stream_Access (Loc,
2919 Stream => Stream_Parameter,
2921 Make_Selected_Component (Loc,
2922 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2925 Make_Identifier (Loc, Name_Addr)),
2926 Etyp => RTE (RE_Unsigned_64)));
2928 -- Build code fragment corresponding to marshalling of a null object
2930 Null_Statements := New_List (
2932 Pack_Entity_Into_Stream_Access (Loc,
2933 Stream => Stream_Parameter,
2934 Object => RTE (RE_Get_Local_Partition_Id)),
2936 Pack_Node_Into_Stream_Access (Loc,
2937 Stream => Stream_Parameter,
2938 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
2939 Etyp => RTE (RE_Unsigned_64)),
2941 Pack_Node_Into_Stream_Access (Loc,
2942 Stream => Stream_Parameter,
2943 Object => Make_Integer_Literal (Loc, Uint_0),
2944 Etyp => RTE (RE_Unsigned_64)));
2946 Statements := New_List (
2947 Make_Implicit_If_Statement (RACW_Type,
2950 Left_Opnd => Object,
2951 Right_Opnd => Make_Null (Loc)),
2952 Then_Statements => Null_Statements,
2953 Elsif_Parts => New_List (
2954 Make_Elsif_Part (Loc,
2958 Make_Attribute_Reference (Loc,
2960 Attribute_Name => Name_Tag),
2962 Make_Attribute_Reference (Loc,
2963 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2964 Attribute_Name => Name_Tag)),
2965 Then_Statements => Remote_Statements)),
2966 Else_Statements => Local_Statements));
2968 Build_Stream_Procedure
2969 (Loc, RACW_Type, Body_Node,
2970 Make_Defining_Identifier (Loc, Procedure_Name),
2971 Statements, Outp => False);
2973 Proc_Decl := Make_Subprogram_Declaration (Loc,
2974 Copy_Specification (Loc, Specification (Body_Node)));
2977 Make_Attribute_Definition_Clause (Loc,
2978 Name => New_Occurrence_Of (RACW_Type, Loc),
2979 Chars => Name_Write,
2982 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
2984 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
2985 Insert_After (Proc_Decl, Attr_Decl);
2986 Append_To (Declarations, Body_Node);
2987 end Add_RACW_Write_Attribute;
2989 ------------------------
2990 -- Add_RAS_Access_TSS --
2991 ------------------------
2993 procedure Add_RAS_Access_TSS (N : Node_Id) is
2994 Loc : constant Source_Ptr := Sloc (N);
2996 Ras_Type : constant Entity_Id := Defining_Identifier (N);
2997 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
2998 -- Ras_Type is the access to subprogram type while Fat_Type is the
2999 -- corresponding record type.
3001 RACW_Type : constant Entity_Id :=
3002 Underlying_RACW_Type (Ras_Type);
3003 Desig : constant Entity_Id :=
3004 Etype (Designated_Type (RACW_Type));
3006 Stub_Elements : constant Stub_Structure :=
3007 Stubs_Table.Get (Desig);
3008 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3010 Proc : constant Entity_Id :=
3011 Make_Defining_Identifier (Loc,
3012 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3014 Proc_Spec : Node_Id;
3016 -- Formal parameters
3018 Package_Name : constant Entity_Id :=
3019 Make_Defining_Identifier (Loc,
3023 Subp_Id : constant Entity_Id :=
3024 Make_Defining_Identifier (Loc,
3026 -- Target subprogram
3028 Asynch_P : constant Entity_Id :=
3029 Make_Defining_Identifier (Loc,
3030 Chars => Name_Asynchronous);
3031 -- Is the procedure to which the 'Access applies asynchronous?
3033 All_Calls_Remote
: constant Entity_Id
:=
3034 Make_Defining_Identifier
(Loc
,
3035 Chars
=> Name_All_Calls_Remote
);
3036 -- True if an All_Calls_Remote pragma applies to the RCI unit
3037 -- that contains the subprogram.
3039 -- Common local variables
3041 Proc_Decls
: List_Id
;
3042 Proc_Statements
: List_Id
;
3044 Origin
: constant Entity_Id
:=
3045 Make_Defining_Identifier
(Loc
,
3046 Chars
=> New_Internal_Name
('P'));
3048 -- Additional local variables for the local case
3050 Proxy_Addr
: constant Entity_Id
:=
3051 Make_Defining_Identifier
(Loc
,
3052 Chars
=> New_Internal_Name
('P'));
3054 -- Additional local variables for the remote case
3056 Local_Stub
: constant Entity_Id
:=
3057 Make_Defining_Identifier
(Loc
,
3058 Chars
=> New_Internal_Name
('L'));
3060 Stub_Ptr
: constant Entity_Id
:=
3061 Make_Defining_Identifier
(Loc
,
3062 Chars
=> New_Internal_Name
('S'));
3065 (Field_Name
: Name_Id
;
3066 Value
: Node_Id
) return Node_Id
;
3067 -- Construct an assignment that sets the named component in the
3075 (Field_Name
: Name_Id
;
3076 Value
: Node_Id
) return Node_Id
3080 Make_Assignment_Statement
(Loc
,
3082 Make_Selected_Component
(Loc
,
3084 Selector_Name
=> Field_Name
),
3085 Expression
=> Value
);
3088 -- Start of processing for Add_RAS_Access_TSS
3091 Proc_Decls
:= New_List
(
3093 -- Common declarations
3095 Make_Object_Declaration
(Loc
,
3096 Defining_Identifier
=> Origin
,
3097 Constant_Present
=> True,
3098 Object_Definition
=>
3099 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3101 Make_Function_Call
(Loc
,
3103 New_Occurrence_Of
(RTE
(RE_Get_Active_Partition_Id
), Loc
),
3104 Parameter_Associations
=> New_List
(
3105 New_Occurrence_Of
(Package_Name
, Loc
)))),
3107 -- Declaration use only in the local case: proxy address
3109 Make_Object_Declaration
(Loc
,
3110 Defining_Identifier
=> Proxy_Addr
,
3111 Object_Definition
=>
3112 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3114 -- Declarations used only in the remote case: stub object and
3117 Make_Object_Declaration
(Loc
,
3118 Defining_Identifier
=> Local_Stub
,
3119 Aliased_Present
=> True,
3120 Object_Definition
=>
3121 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
3123 Make_Object_Declaration
(Loc
,
3124 Defining_Identifier
=>
3126 Object_Definition
=>
3127 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
3129 Make_Attribute_Reference
(Loc
,
3130 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
3131 Attribute_Name
=> Name_Unchecked_Access
)));
3133 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
3134 -- Build_Get_Unique_RP_Call needs this information
3136 -- Note: Here we assume that the Fat_Type is a record
3137 -- containing just a pointer to a proxy or stub object.
3139 Proc_Statements
:= New_List
(
3143 -- Get_RAS_Info (Pkg, Subp, PA);
3144 -- if Origin = Local_Partition_Id
3145 -- and then not All_Calls_Remote
3147 -- return Fat_Type!(PA);
3150 Make_Procedure_Call_Statement
(Loc
,
3152 New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
3153 Parameter_Associations
=> New_List
(
3154 New_Occurrence_Of
(Package_Name
, Loc
),
3155 New_Occurrence_Of
(Subp_Id
, Loc
),
3156 New_Occurrence_Of
(Proxy_Addr
, Loc
))),
3158 Make_Implicit_If_Statement
(N
,
3164 New_Occurrence_Of
(Origin
, Loc
),
3166 Make_Function_Call
(Loc
,
3168 RTE
(RE_Get_Local_Partition_Id
), Loc
))),
3171 New_Occurrence_Of
(All_Calls_Remote
, Loc
))),
3172 Then_Statements
=> New_List
(
3173 Make_Return_Statement
(Loc
,
3174 Unchecked_Convert_To
(Fat_Type
,
3175 OK_Convert_To
(RTE
(RE_Address
),
3176 New_Occurrence_Of
(Proxy_Addr
, Loc
)))))),
3178 Set_Field
(Name_Origin
,
3179 New_Occurrence_Of
(Origin
, Loc
)),
3181 Set_Field
(Name_Receiver
,
3182 Make_Function_Call
(Loc
,
3184 New_Occurrence_Of
(RTE
(RE_Get_RCI_Package_Receiver
), Loc
),
3185 Parameter_Associations
=> New_List
(
3186 New_Occurrence_Of
(Package_Name
, Loc
)))),
3188 Set_Field
(Name_Addr
, New_Occurrence_Of
(Proxy_Addr
, Loc
)),
3190 -- E.4.1(9) A remote call is asynchronous if it is a call to
3191 -- a procedure, or a call through a value of an access-to-procedure
3192 -- type, to which a pragma Asynchronous applies.
3194 -- Parameter Asynch_P is true when the procedure is asynchronous;
3195 -- Expression Asynch_T is true when the type is asynchronous.
3197 Set_Field
(Name_Asynchronous
,
3199 New_Occurrence_Of
(Asynch_P
, Loc
),
3200 New_Occurrence_Of
(Boolean_Literals
(
3201 Is_Asynchronous
(Ras_Type
)), Loc
))));
3203 Append_List_To
(Proc_Statements
,
3204 Build_Get_Unique_RP_Call
3205 (Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
3207 -- Return the newly created value
3209 Append_To
(Proc_Statements
,
3210 Make_Return_Statement
(Loc
,
3212 Unchecked_Convert_To
(Fat_Type
,
3213 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
3216 Make_Function_Specification
(Loc
,
3217 Defining_Unit_Name
=> Proc
,
3218 Parameter_Specifications
=> New_List
(
3219 Make_Parameter_Specification
(Loc
,
3220 Defining_Identifier
=> Package_Name
,
3222 New_Occurrence_Of
(Standard_String
, Loc
)),
3224 Make_Parameter_Specification
(Loc
,
3225 Defining_Identifier
=> Subp_Id
,
3227 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
)),
3229 Make_Parameter_Specification
(Loc
,
3230 Defining_Identifier
=> Asynch_P
,
3232 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3234 Make_Parameter_Specification
(Loc
,
3235 Defining_Identifier
=> All_Calls_Remote
,
3237 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
3239 Result_Definition
=>
3240 New_Occurrence_Of
(Fat_Type
, Loc
));
3242 -- Set the kind and return type of the function to prevent
3243 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3245 Set_Ekind
(Proc
, E_Function
);
3246 Set_Etype
(Proc
, Fat_Type
);
3249 Make_Subprogram_Body
(Loc
,
3250 Specification
=> Proc_Spec
,
3251 Declarations
=> Proc_Decls
,
3252 Handled_Statement_Sequence
=>
3253 Make_Handled_Sequence_Of_Statements
(Loc
,
3254 Statements
=> Proc_Statements
)));
3256 Set_TSS
(Fat_Type
, Proc
);
3257 end Add_RAS_Access_TSS
;
3259 -----------------------
3260 -- Add_RAST_Features --
3261 -----------------------
3263 procedure Add_RAST_Features
3264 (Vis_Decl
: Node_Id
;
3265 RAS_Type
: Entity_Id
)
3267 pragma Warnings
(Off
);
3268 pragma Unreferenced
(RAS_Type
);
3269 pragma Warnings
(On
);
3271 Add_RAS_Access_TSS
(Vis_Decl
);
3272 end Add_RAST_Features
;
3274 -----------------------------------------
3275 -- Add_Receiving_Stubs_To_Declarations --
3276 -----------------------------------------
3278 procedure Add_Receiving_Stubs_To_Declarations
3279 (Pkg_Spec
: Node_Id
;
3282 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
3284 Request_Parameter
: Node_Id
;
3286 Pkg_RPC_Receiver
: constant Entity_Id
:=
3287 Make_Defining_Identifier
(Loc
,
3288 New_Internal_Name
('H'));
3289 Pkg_RPC_Receiver_Statements
: List_Id
;
3290 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
3291 Pkg_RPC_Receiver_Body
: Node_Id
;
3292 -- A Pkg_RPC_Receiver is built to decode the request
3294 Lookup_RAS_Info
: constant Entity_Id
:=
3295 Make_Defining_Identifier
(Loc
,
3296 Chars
=> New_Internal_Name
('R'));
3297 -- A remote subprogram is created to allow peers to look up
3298 -- RAS information using subprogram ids.
3300 Subp_Id
: Entity_Id
;
3301 Subp_Index
: Entity_Id
;
3302 -- Subprogram_Id as read from the incoming stream
3304 Current_Declaration
: Node_Id
;
3305 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
3306 Current_Stubs
: Node_Id
;
3308 Subp_Info_Array
: constant Entity_Id
:=
3309 Make_Defining_Identifier
(Loc
,
3310 Chars
=> New_Internal_Name
('I'));
3312 Subp_Info_List
: constant List_Id
:= New_List
;
3314 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
3316 All_Calls_Remote_E
: Entity_Id
;
3317 Proxy_Object_Addr
: Entity_Id
;
3319 procedure Append_Stubs_To
3320 (RPC_Receiver_Cases
: List_Id
;
3322 Subprogram_Number
: Int
);
3323 -- Add one case to the specified RPC receiver case list
3324 -- associating Subprogram_Number with the subprogram declared
3325 -- by Declaration, for which we have receiving stubs in Stubs.
3327 ---------------------
3328 -- Append_Stubs_To --
3329 ---------------------
3331 procedure Append_Stubs_To
3332 (RPC_Receiver_Cases
: List_Id
;
3334 Subprogram_Number
: Int
)
3337 Append_To
(RPC_Receiver_Cases
,
3338 Make_Case_Statement_Alternative
(Loc
,
3340 New_List
(Make_Integer_Literal
(Loc
, Subprogram_Number
)),
3343 Make_Procedure_Call_Statement
(Loc
,
3346 Defining_Entity
(Stubs
), Loc
),
3347 Parameter_Associations
=> New_List
(
3348 New_Occurrence_Of
(Request_Parameter
, Loc
))))));
3349 end Append_Stubs_To
;
3351 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3354 -- Building receiving stubs consist in several operations:
3356 -- - a package RPC receiver must be built. This subprogram
3357 -- will get a Subprogram_Id from the incoming stream
3358 -- and will dispatch the call to the right subprogram
3360 -- - a receiving stub for any subprogram visible in the package
3361 -- spec. This stub will read all the parameters from the stream,
3362 -- and put the result as well as the exception occurrence in the
3365 -- - a dummy package with an empty spec and a body made of an
3366 -- elaboration part, whose job is to register the receiving
3367 -- part of this RCI package on the name server. This is done
3368 -- by calling System.Partition_Interface.Register_Receiving_Stub
3370 Build_RPC_Receiver_Body
(
3371 RPC_Receiver
=> Pkg_RPC_Receiver
,
3372 Request
=> Request_Parameter
,
3374 Subp_Index
=> Subp_Index
,
3375 Stmts
=> Pkg_RPC_Receiver_Statements
,
3376 Decl
=> Pkg_RPC_Receiver_Body
);
3377 pragma Assert
(Subp_Id
= Subp_Index
);
3379 -- A null subp_id denotes a call through a RAS, in which case the
3380 -- next Uint_64 element in the stream is the address of the local
3381 -- proxy object, from which we can retrieve the actual subprogram id.
3383 Append_To
(Pkg_RPC_Receiver_Statements
,
3384 Make_Implicit_If_Statement
(Pkg_Spec
,
3387 New_Occurrence_Of
(Subp_Id
, Loc
),
3388 Make_Integer_Literal
(Loc
, 0)),
3389 Then_Statements
=> New_List
(
3390 Make_Assignment_Statement
(Loc
,
3392 New_Occurrence_Of
(Subp_Id
, Loc
),
3394 Make_Selected_Component
(Loc
,
3396 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
3397 OK_Convert_To
(RTE
(RE_Address
),
3398 Make_Attribute_Reference
(Loc
,
3400 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3403 Expressions
=> New_List
(
3404 Make_Selected_Component
(Loc
,
3405 Prefix
=> Request_Parameter
,
3406 Selector_Name
=> Name_Params
))))),
3408 Make_Identifier
(Loc
, Name_Subp_Id
))))));
3410 -- Build a subprogram for RAS information lookups
3412 Current_Declaration
:=
3413 Make_Subprogram_Declaration
(Loc
,
3415 Make_Function_Specification
(Loc
,
3416 Defining_Unit_Name
=>
3418 Parameter_Specifications
=> New_List
(
3419 Make_Parameter_Specification
(Loc
,
3420 Defining_Identifier
=>
3421 Make_Defining_Identifier
(Loc
, Name_Subp_Id
),
3425 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))),
3426 Result_Definition
=>
3427 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)));
3428 Append_To
(Decls
, Current_Declaration
);
3429 Analyze
(Current_Declaration
);
3431 Current_Stubs
:= Build_Subprogram_Receiving_Stubs
3432 (Vis_Decl
=> Current_Declaration
,
3433 Asynchronous
=> False);
3434 Append_To
(Decls
, Current_Stubs
);
3435 Analyze
(Current_Stubs
);
3437 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3440 Subprogram_Number
=> 1);
3442 -- For each subprogram, the receiving stub will be built and a
3443 -- case statement will be made on the Subprogram_Id to dispatch
3444 -- to the right subprogram.
3446 All_Calls_Remote_E
:= Boolean_Literals
(
3447 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
3449 Overload_Counter_Table
.Reset
;
3451 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
3452 while Present
(Current_Declaration
) loop
3453 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
3454 and then Comes_From_Source
(Current_Declaration
)
3457 Loc
: constant Source_Ptr
:=
3458 Sloc
(Current_Declaration
);
3459 -- While specifically processing Current_Declaration, use
3460 -- its Sloc as the location of all generated nodes.
3462 Subp_Def
: constant Entity_Id
:=
3464 (Specification
(Current_Declaration
));
3466 Subp_Val
: String_Id
;
3469 pragma Assert
(Current_Subprogram_Number
=
3470 Get_Subprogram_Id
(Subp_Def
));
3472 -- Build receiving stub
3475 Build_Subprogram_Receiving_Stubs
3476 (Vis_Decl
=> Current_Declaration
,
3478 Nkind
(Specification
(Current_Declaration
)) =
3479 N_Procedure_Specification
3480 and then Is_Asynchronous
(Subp_Def
));
3482 Append_To
(Decls
, Current_Stubs
);
3483 Analyze
(Current_Stubs
);
3487 Add_RAS_Proxy_And_Analyze
(Decls
,
3489 Current_Declaration
,
3490 All_Calls_Remote_E
=>
3492 Proxy_Object_Addr
=>
3495 -- Compute distribution identifier
3497 Assign_Subprogram_Identifier
(
3499 Current_Subprogram_Number
,
3502 -- Add subprogram descriptor (RCI_Subp_Info) to the
3503 -- subprograms table for this receiver. The aggregate
3504 -- below must be kept consistent with the declaration
3505 -- of type RCI_Subp_Info in System.Partition_Interface.
3507 Append_To
(Subp_Info_List
,
3508 Make_Component_Association
(Loc
,
3509 Choices
=> New_List
(
3510 Make_Integer_Literal
(Loc
,
3511 Current_Subprogram_Number
)),
3513 Make_Aggregate
(Loc
,
3514 Component_Associations
=> New_List
(
3515 Make_Component_Association
(Loc
,
3516 Choices
=> New_List
(
3517 Make_Identifier
(Loc
, Name_Addr
)),
3520 Proxy_Object_Addr
, Loc
))))));
3522 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3525 Subprogram_Number
=>
3526 Current_Subprogram_Number
);
3529 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
3532 Next
(Current_Declaration
);
3535 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3536 -- rather than raising an exception since we do not want someone
3537 -- to crash a remote partition by sending invalid subprogram ids.
3538 -- This is consistent with the other parts of the case statement
3539 -- since even in presence of incorrect parameters in the stream,
3540 -- every exception will be caught and (if the subprogram is not an
3541 -- APC) put into the result stream and sent away.
3543 Append_To
(Pkg_RPC_Receiver_Cases
,
3544 Make_Case_Statement_Alternative
(Loc
,
3546 New_List
(Make_Others_Choice
(Loc
)),
3548 New_List
(Make_Null_Statement
(Loc
))));
3550 Append_To
(Pkg_RPC_Receiver_Statements
,
3551 Make_Case_Statement
(Loc
,
3553 New_Occurrence_Of
(Subp_Id
, Loc
),
3554 Alternatives
=> Pkg_RPC_Receiver_Cases
));
3557 Make_Object_Declaration
(Loc
,
3558 Defining_Identifier
=> Subp_Info_Array
,
3559 Constant_Present
=> True,
3560 Aliased_Present
=> True,
3561 Object_Definition
=>
3562 Make_Subtype_Indication
(Loc
,
3564 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
3566 Make_Index_Or_Discriminant_Constraint
(Loc
,
3569 Low_Bound
=> Make_Integer_Literal
(Loc
,
3570 First_RCI_Subprogram_Id
),
3572 Make_Integer_Literal
(Loc
,
3573 First_RCI_Subprogram_Id
3574 + List_Length
(Subp_Info_List
) - 1))))),
3576 Make_Aggregate
(Loc
,
3577 Component_Associations
=> Subp_Info_List
)));
3578 Analyze
(Last
(Decls
));
3581 Make_Subprogram_Body
(Loc
,
3583 Copy_Specification
(Loc
, Parent
(Lookup_RAS_Info
)),
3586 Handled_Statement_Sequence
=>
3587 Make_Handled_Sequence_Of_Statements
(Loc
,
3588 Statements
=> New_List
(
3589 Make_Return_Statement
(Loc
,
3590 Expression
=> OK_Convert_To
(RTE
(RE_Unsigned_64
),
3591 Make_Selected_Component
(Loc
,
3593 Make_Indexed_Component
(Loc
,
3595 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3596 Expressions
=> New_List
(
3597 Convert_To
(Standard_Integer
,
3598 Make_Identifier
(Loc
, Name_Subp_Id
)))),
3600 Make_Identifier
(Loc
, Name_Addr
))))))));
3601 Analyze
(Last
(Decls
));
3603 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
3604 Analyze
(Last
(Decls
));
3606 Get_Library_Unit_Name_String
(Pkg_Spec
);
3607 Append_To
(Register_Pkg_Actuals
,
3609 Make_String_Literal
(Loc
,
3610 Strval
=> String_From_Name_Buffer
));
3612 Append_To
(Register_Pkg_Actuals
,
3614 Make_Attribute_Reference
(Loc
,
3616 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
3618 Name_Unrestricted_Access
));
3620 Append_To
(Register_Pkg_Actuals
,
3622 Make_Attribute_Reference
(Loc
,
3624 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
3628 Append_To
(Register_Pkg_Actuals
,
3630 Make_Attribute_Reference
(Loc
,
3632 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3636 Append_To
(Register_Pkg_Actuals
,
3638 Make_Attribute_Reference
(Loc
,
3640 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3645 Make_Procedure_Call_Statement
(Loc
,
3647 New_Occurrence_Of
(RTE
(RE_Register_Receiving_Stub
), Loc
),
3648 Parameter_Associations
=> Register_Pkg_Actuals
));
3649 Analyze
(Last
(Decls
));
3650 end Add_Receiving_Stubs_To_Declarations
;
3652 ---------------------------------
3653 -- Build_General_Calling_Stubs --
3654 ---------------------------------
3656 procedure Build_General_Calling_Stubs
3658 Statements
: List_Id
;
3659 Target_Partition
: Entity_Id
;
3660 Target_RPC_Receiver
: Node_Id
;
3661 Subprogram_Id
: Node_Id
;
3662 Asynchronous
: Node_Id
:= Empty
;
3663 Is_Known_Asynchronous
: Boolean := False;
3664 Is_Known_Non_Asynchronous
: Boolean := False;
3665 Is_Function
: Boolean;
3667 Stub_Type
: Entity_Id
:= Empty
;
3668 RACW_Type
: Entity_Id
:= Empty
;
3671 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
3673 Stream_Parameter
: Node_Id
;
3674 -- Name of the stream used to transmit parameters to the
3677 Result_Parameter
: Node_Id
;
3678 -- Name of the result parameter (in non-APC cases) which get the
3679 -- result of the remote subprogram.
3681 Exception_Return_Parameter
: Node_Id
;
3682 -- Name of the parameter which will hold the exception sent by the
3683 -- remote subprogram.
3685 Current_Parameter
: Node_Id
;
3686 -- Current parameter being handled
3688 Ordered_Parameters_List
: constant List_Id
:=
3689 Build_Ordered_Parameters_List
(Spec
);
3691 Asynchronous_Statements
: List_Id
:= No_List
;
3692 Non_Asynchronous_Statements
: List_Id
:= No_List
;
3693 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
3695 Extra_Formal_Statements
: constant List_Id
:= New_List
;
3696 -- List of statements for extra formal parameters. It will appear
3697 -- after the regular statements for writing out parameters.
3699 pragma Warnings
(Off
);
3700 pragma Unreferenced
(RACW_Type
);
3701 -- Used only for the PolyORB case
3702 pragma Warnings
(On
);
3705 -- The general form of a calling stub for a given subprogram is:
3707 -- procedure X (...) is P : constant Partition_ID :=
3708 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
3709 -- System.RPC.Params_Stream_Type (0); begin
3710 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
3711 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
3712 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
3713 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
3715 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
3717 -- There are some variations: Do_APC is called for an asynchronous
3718 -- procedure and the part after the call is completely ommitted as
3719 -- well as the declaration of Result. For a function call, 'Input is
3720 -- always used to read the result even if it is constrained.
3723 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
3726 Make_Object_Declaration
(Loc
,
3727 Defining_Identifier
=> Stream_Parameter
,
3728 Aliased_Present
=> True,
3729 Object_Definition
=>
3730 Make_Subtype_Indication
(Loc
,
3732 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
3734 Make_Index_Or_Discriminant_Constraint
(Loc
,
3736 New_List
(Make_Integer_Literal
(Loc
, 0))))));
3738 if not Is_Known_Asynchronous
then
3740 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
3743 Make_Object_Declaration
(Loc
,
3744 Defining_Identifier
=> Result_Parameter
,
3745 Aliased_Present
=> True,
3746 Object_Definition
=>
3747 Make_Subtype_Indication
(Loc
,
3749 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
3751 Make_Index_Or_Discriminant_Constraint
(Loc
,
3753 New_List
(Make_Integer_Literal
(Loc
, 0))))));
3755 Exception_Return_Parameter
:=
3756 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
3759 Make_Object_Declaration
(Loc
,
3760 Defining_Identifier
=> Exception_Return_Parameter
,
3761 Object_Definition
=>
3762 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
3765 Result_Parameter
:= Empty
;
3766 Exception_Return_Parameter
:= Empty
;
3769 -- Put first the RPC receiver corresponding to the remote package
3771 Append_To
(Statements
,
3772 Make_Attribute_Reference
(Loc
,
3774 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3775 Attribute_Name
=> Name_Write
,
3776 Expressions
=> New_List
(
3777 Make_Attribute_Reference
(Loc
,
3779 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3782 Target_RPC_Receiver
)));
3784 -- Then put the Subprogram_Id of the subprogram we want to call in
3787 Append_To
(Statements
,
3788 Make_Attribute_Reference
(Loc
,
3790 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
3793 Expressions
=> New_List
(
3794 Make_Attribute_Reference
(Loc
,
3796 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3797 Attribute_Name
=> Name_Access
),
3800 Current_Parameter
:= First
(Ordered_Parameters_List
);
3801 while Present
(Current_Parameter
) loop
3803 Typ
: constant Node_Id
:=
3804 Parameter_Type
(Current_Parameter
);
3806 Constrained
: Boolean;
3808 Extra_Parameter
: Entity_Id
;
3811 if Is_RACW_Controlling_Formal
3812 (Current_Parameter
, Stub_Type
)
3814 -- In the case of a controlling formal argument, we marshall
3815 -- its addr field rather than the local stub.
3817 Append_To
(Statements
,
3818 Pack_Node_Into_Stream
(Loc
,
3819 Stream
=> Stream_Parameter
,
3821 Make_Selected_Component
(Loc
,
3823 Defining_Identifier
(Current_Parameter
),
3824 Selector_Name
=> Name_Addr
),
3825 Etyp
=> RTE
(RE_Unsigned_64
)));
3828 Value
:= New_Occurrence_Of
3829 (Defining_Identifier
(Current_Parameter
), Loc
);
3831 -- Access type parameters are transmitted as in out
3832 -- parameters. However, a dereference is needed so that
3833 -- we marshall the designated object.
3835 if Nkind
(Typ
) = N_Access_Definition
then
3836 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
3837 Etyp
:= Etype
(Subtype_Mark
(Typ
));
3839 Etyp
:= Etype
(Typ
);
3843 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
3845 -- Any parameter but unconstrained out parameters are
3846 -- transmitted to the peer.
3848 if In_Present
(Current_Parameter
)
3849 or else not Out_Present
(Current_Parameter
)
3850 or else not Constrained
3852 Append_To
(Statements
,
3853 Make_Attribute_Reference
(Loc
,
3855 New_Occurrence_Of
(Etyp
, Loc
),
3857 Output_From_Constrained
(Constrained
),
3858 Expressions
=> New_List
(
3859 Make_Attribute_Reference
(Loc
,
3861 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3862 Attribute_Name
=> Name_Access
),
3867 -- If the current parameter has a dynamic constrained status,
3868 -- then this status is transmitted as well.
3869 -- This should be done for accessibility as well ???
3871 if Nkind
(Typ
) /= N_Access_Definition
3872 and then Need_Extra_Constrained
(Current_Parameter
)
3874 -- In this block, we do not use the extra formal that has
3875 -- been created because it does not exist at the time of
3876 -- expansion when building calling stubs for remote access
3877 -- to subprogram types. We create an extra variable of this
3878 -- type and push it in the stream after the regular
3881 Extra_Parameter
:= Make_Defining_Identifier
3882 (Loc
, New_Internal_Name
('P'));
3885 Make_Object_Declaration
(Loc
,
3886 Defining_Identifier
=> Extra_Parameter
,
3887 Constant_Present
=> True,
3888 Object_Definition
=>
3889 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3891 Make_Attribute_Reference
(Loc
,
3894 Defining_Identifier
(Current_Parameter
), Loc
),
3895 Attribute_Name
=> Name_Constrained
)));
3897 Append_To
(Extra_Formal_Statements
,
3898 Make_Attribute_Reference
(Loc
,
3900 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3903 Expressions
=> New_List
(
3904 Make_Attribute_Reference
(Loc
,
3906 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3909 New_Occurrence_Of
(Extra_Parameter
, Loc
))));
3912 Next
(Current_Parameter
);
3916 -- Append the formal statements list to the statements
3918 Append_List_To
(Statements
, Extra_Formal_Statements
);
3920 if not Is_Known_Non_Asynchronous
then
3922 -- Build the call to System.RPC.Do_APC
3924 Asynchronous_Statements
:= New_List
(
3925 Make_Procedure_Call_Statement
(Loc
,
3927 New_Occurrence_Of
(RTE
(RE_Do_Apc
), Loc
),
3928 Parameter_Associations
=> New_List
(
3929 New_Occurrence_Of
(Target_Partition
, Loc
),
3930 Make_Attribute_Reference
(Loc
,
3932 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3936 Asynchronous_Statements
:= No_List
;
3939 if not Is_Known_Asynchronous
then
3941 -- Build the call to System.RPC.Do_RPC
3943 Non_Asynchronous_Statements
:= New_List
(
3944 Make_Procedure_Call_Statement
(Loc
,
3946 New_Occurrence_Of
(RTE
(RE_Do_Rpc
), Loc
),
3947 Parameter_Associations
=> New_List
(
3948 New_Occurrence_Of
(Target_Partition
, Loc
),
3950 Make_Attribute_Reference
(Loc
,
3952 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3956 Make_Attribute_Reference
(Loc
,
3958 New_Occurrence_Of
(Result_Parameter
, Loc
),
3962 -- Read the exception occurrence from the result stream and
3963 -- reraise it. It does no harm if this is a Null_Occurrence since
3964 -- this does nothing.
3966 Append_To
(Non_Asynchronous_Statements
,
3967 Make_Attribute_Reference
(Loc
,
3969 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
3974 Expressions
=> New_List
(
3975 Make_Attribute_Reference
(Loc
,
3977 New_Occurrence_Of
(Result_Parameter
, Loc
),
3980 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
3982 Append_To
(Non_Asynchronous_Statements
,
3983 Make_Procedure_Call_Statement
(Loc
,
3985 New_Occurrence_Of
(RTE
(RE_Reraise_Occurrence
), Loc
),
3986 Parameter_Associations
=> New_List
(
3987 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
3991 -- If this is a function call, then read the value and return
3992 -- it. The return value is written/read using 'Output/'Input.
3994 Append_To
(Non_Asynchronous_Statements
,
3995 Make_Tag_Check
(Loc
,
3996 Make_Return_Statement
(Loc
,
3998 Make_Attribute_Reference
(Loc
,
4001 Etype
(Result_Definition
(Spec
)), Loc
),
4003 Attribute_Name
=> Name_Input
,
4005 Expressions
=> New_List
(
4006 Make_Attribute_Reference
(Loc
,
4008 New_Occurrence_Of
(Result_Parameter
, Loc
),
4009 Attribute_Name
=> Name_Access
))))));
4012 -- Loop around parameters and assign out (or in out)
4013 -- parameters. In the case of RACW, controlling arguments
4014 -- cannot possibly have changed since they are remote, so we do
4015 -- not read them from the stream.
4017 Current_Parameter
:= First
(Ordered_Parameters_List
);
4018 while Present
(Current_Parameter
) loop
4020 Typ
: constant Node_Id
:=
4021 Parameter_Type
(Current_Parameter
);
4028 (Defining_Identifier
(Current_Parameter
), Loc
);
4030 if Nkind
(Typ
) = N_Access_Definition
then
4031 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4032 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4034 Etyp
:= Etype
(Typ
);
4037 if (Out_Present
(Current_Parameter
)
4038 or else Nkind
(Typ
) = N_Access_Definition
)
4039 and then Etyp
/= Stub_Type
4041 Append_To
(Non_Asynchronous_Statements
,
4042 Make_Attribute_Reference
(Loc
,
4044 New_Occurrence_Of
(Etyp
, Loc
),
4046 Attribute_Name
=> Name_Read
,
4048 Expressions
=> New_List
(
4049 Make_Attribute_Reference
(Loc
,
4051 New_Occurrence_Of
(Result_Parameter
, Loc
),
4058 Next
(Current_Parameter
);
4063 if Is_Known_Asynchronous
then
4064 Append_List_To
(Statements
, Asynchronous_Statements
);
4066 elsif Is_Known_Non_Asynchronous
then
4067 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
4070 pragma Assert
(Present
(Asynchronous
));
4071 Prepend_To
(Asynchronous_Statements
,
4072 Make_Attribute_Reference
(Loc
,
4073 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4074 Attribute_Name
=> Name_Write
,
4075 Expressions
=> New_List
(
4076 Make_Attribute_Reference
(Loc
,
4078 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4079 Attribute_Name
=> Name_Access
),
4080 New_Occurrence_Of
(Standard_True
, Loc
))));
4082 Prepend_To
(Non_Asynchronous_Statements
,
4083 Make_Attribute_Reference
(Loc
,
4084 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4085 Attribute_Name
=> Name_Write
,
4086 Expressions
=> New_List
(
4087 Make_Attribute_Reference
(Loc
,
4089 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4090 Attribute_Name
=> Name_Access
),
4091 New_Occurrence_Of
(Standard_False
, Loc
))));
4093 Append_To
(Statements
,
4094 Make_Implicit_If_Statement
(Nod
,
4095 Condition
=> Asynchronous
,
4096 Then_Statements
=> Asynchronous_Statements
,
4097 Else_Statements
=> Non_Asynchronous_Statements
));
4099 end Build_General_Calling_Stubs
;
4101 -----------------------------
4102 -- Build_RPC_Receiver_Body --
4103 -----------------------------
4105 procedure Build_RPC_Receiver_Body
4106 (RPC_Receiver
: Entity_Id
;
4107 Request
: out Entity_Id
;
4108 Subp_Id
: out Entity_Id
;
4109 Subp_Index
: out Entity_Id
;
4110 Stmts
: out List_Id
;
4113 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
4115 RPC_Receiver_Spec
: Node_Id
;
4116 RPC_Receiver_Decls
: List_Id
;
4119 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
4121 RPC_Receiver_Spec
:=
4122 Build_RPC_Receiver_Specification
4123 (RPC_Receiver
=> RPC_Receiver
,
4124 Request_Parameter
=> Request
);
4126 Subp_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4127 Subp_Index
:= Subp_Id
;
4129 -- Subp_Id may not be a constant, because in the case of the RPC
4130 -- receiver for an RCI package, when a call is received from a RAS
4131 -- dereference, it will be assigned during subsequent processing.
4133 RPC_Receiver_Decls
:= New_List
(
4134 Make_Object_Declaration
(Loc
,
4135 Defining_Identifier
=> Subp_Id
,
4136 Object_Definition
=>
4137 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4139 Make_Attribute_Reference
(Loc
,
4141 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4142 Attribute_Name
=> Name_Input
,
4143 Expressions
=> New_List
(
4144 Make_Selected_Component
(Loc
,
4146 Selector_Name
=> Name_Params
)))));
4151 Make_Subprogram_Body
(Loc
,
4152 Specification
=> RPC_Receiver_Spec
,
4153 Declarations
=> RPC_Receiver_Decls
,
4154 Handled_Statement_Sequence
=>
4155 Make_Handled_Sequence_Of_Statements
(Loc
,
4156 Statements
=> Stmts
));
4157 end Build_RPC_Receiver_Body
;
4159 -----------------------
4160 -- Build_Stub_Target --
4161 -----------------------
4163 function Build_Stub_Target
4166 RCI_Locator
: Entity_Id
;
4167 Controlling_Parameter
: Entity_Id
) return RPC_Target
4169 Target_Info
: RPC_Target
(PCS_Kind
=> Name_GARLIC_DSA
);
4171 Target_Info
.Partition
:=
4172 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4173 if Present
(Controlling_Parameter
) then
4175 Make_Object_Declaration
(Loc
,
4176 Defining_Identifier
=> Target_Info
.Partition
,
4177 Constant_Present
=> True,
4178 Object_Definition
=>
4179 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4182 Make_Selected_Component
(Loc
,
4183 Prefix
=> Controlling_Parameter
,
4184 Selector_Name
=> Name_Origin
)));
4186 Target_Info
.RPC_Receiver
:=
4187 Make_Selected_Component
(Loc
,
4188 Prefix
=> Controlling_Parameter
,
4189 Selector_Name
=> Name_Receiver
);
4193 Make_Object_Declaration
(Loc
,
4194 Defining_Identifier
=> Target_Info
.Partition
,
4195 Constant_Present
=> True,
4196 Object_Definition
=>
4197 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4200 Make_Function_Call
(Loc
,
4201 Name
=> Make_Selected_Component
(Loc
,
4203 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4205 Make_Identifier
(Loc
,
4206 Name_Get_Active_Partition_ID
)))));
4208 Target_Info
.RPC_Receiver
:=
4209 Make_Selected_Component
(Loc
,
4211 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4213 Make_Identifier
(Loc
, Name_Get_RCI_Package_Receiver
));
4216 end Build_Stub_Target
;
4218 ---------------------
4219 -- Build_Stub_Type --
4220 ---------------------
4222 procedure Build_Stub_Type
4223 (RACW_Type
: Entity_Id
;
4224 Stub_Type
: Entity_Id
;
4225 Stub_Type_Decl
: out Node_Id
;
4226 RPC_Receiver_Decl
: out Node_Id
)
4228 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
4229 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
4233 Make_Full_Type_Declaration
(Loc
,
4234 Defining_Identifier
=> Stub_Type
,
4236 Make_Record_Definition
(Loc
,
4237 Tagged_Present
=> True,
4238 Limited_Present
=> True,
4240 Make_Component_List
(Loc
,
4241 Component_Items
=> New_List
(
4243 Make_Component_Declaration
(Loc
,
4244 Defining_Identifier
=>
4245 Make_Defining_Identifier
(Loc
, Name_Origin
),
4246 Component_Definition
=>
4247 Make_Component_Definition
(Loc
,
4248 Aliased_Present
=> False,
4249 Subtype_Indication
=>
4251 RTE
(RE_Partition_ID
), Loc
))),
4253 Make_Component_Declaration
(Loc
,
4254 Defining_Identifier
=>
4255 Make_Defining_Identifier
(Loc
, Name_Receiver
),
4256 Component_Definition
=>
4257 Make_Component_Definition
(Loc
,
4258 Aliased_Present
=> False,
4259 Subtype_Indication
=>
4260 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4262 Make_Component_Declaration
(Loc
,
4263 Defining_Identifier
=>
4264 Make_Defining_Identifier
(Loc
, Name_Addr
),
4265 Component_Definition
=>
4266 Make_Component_Definition
(Loc
,
4267 Aliased_Present
=> False,
4268 Subtype_Indication
=>
4269 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4271 Make_Component_Declaration
(Loc
,
4272 Defining_Identifier
=>
4273 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
4274 Component_Definition
=>
4275 Make_Component_Definition
(Loc
,
4276 Aliased_Present
=> False,
4277 Subtype_Indication
=>
4279 Standard_Boolean
, Loc
)))))));
4282 RPC_Receiver_Decl
:= Empty
;
4285 RPC_Receiver_Request
: constant Entity_Id
:=
4286 Make_Defining_Identifier
(Loc
, Name_R
);
4288 RPC_Receiver_Decl
:=
4289 Make_Subprogram_Declaration
(Loc
,
4290 Build_RPC_Receiver_Specification
(
4291 RPC_Receiver
=> Make_Defining_Identifier
(Loc
,
4292 New_Internal_Name
('R')),
4293 Request_Parameter
=> RPC_Receiver_Request
));
4296 end Build_Stub_Type
;
4298 --------------------------------------
4299 -- Build_Subprogram_Receiving_Stubs --
4300 --------------------------------------
4302 function Build_Subprogram_Receiving_Stubs
4303 (Vis_Decl
: Node_Id
;
4304 Asynchronous
: Boolean;
4305 Dynamically_Asynchronous
: Boolean := False;
4306 Stub_Type
: Entity_Id
:= Empty
;
4307 RACW_Type
: Entity_Id
:= Empty
;
4308 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
4310 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
4312 Request_Parameter
: Node_Id
;
4315 Decls
: constant List_Id
:= New_List
;
4316 -- All the parameters will get declared before calling the real
4317 -- subprograms. Also the out parameters will be declared.
4319 Statements
: constant List_Id
:= New_List
;
4321 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4322 -- Statements concerning extra formal parameters
4324 After_Statements
: constant List_Id
:= New_List
;
4325 -- Statements to be executed after the subprogram call
4327 Inner_Decls
: List_Id
:= No_List
;
4328 -- In case of a function, the inner declarations are needed since
4329 -- the result may be unconstrained.
4331 Excep_Handlers
: List_Id
:= No_List
;
4332 Excep_Choice
: Entity_Id
;
4333 Excep_Code
: List_Id
;
4335 Parameter_List
: constant List_Id
:= New_List
;
4336 -- List of parameters to be passed to the subprogram
4338 Current_Parameter
: Node_Id
;
4340 Ordered_Parameters_List
: constant List_Id
:=
4341 Build_Ordered_Parameters_List
4342 (Specification
(Vis_Decl
));
4344 Subp_Spec
: Node_Id
;
4345 -- Subprogram specification
4347 Called_Subprogram
: Node_Id
;
4348 -- The subprogram to call
4350 Null_Raise_Statement
: Node_Id
;
4352 Dynamic_Async
: Entity_Id
;
4355 if Present
(RACW_Type
) then
4356 Called_Subprogram
:=
4357 New_Occurrence_Of
(Parent_Primitive
, Loc
);
4359 Called_Subprogram
:=
4361 Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
4364 Request_Parameter
:=
4365 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4367 if Dynamically_Asynchronous
then
4369 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
4371 Dynamic_Async
:= Empty
;
4374 if not Asynchronous
or Dynamically_Asynchronous
then
4376 -- The first statement after the subprogram call is a statement to
4377 -- writes a Null_Occurrence into the result stream.
4379 Null_Raise_Statement
:=
4380 Make_Attribute_Reference
(Loc
,
4382 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4383 Attribute_Name
=> Name_Write
,
4384 Expressions
=> New_List
(
4385 Make_Selected_Component
(Loc
,
4386 Prefix
=> Request_Parameter
,
4387 Selector_Name
=> Name_Result
),
4388 New_Occurrence_Of
(RTE
(RE_Null_Occurrence
), Loc
)));
4390 if Dynamically_Asynchronous
then
4391 Null_Raise_Statement
:=
4392 Make_Implicit_If_Statement
(Vis_Decl
,
4394 Make_Op_Not
(Loc
, New_Occurrence_Of
(Dynamic_Async
, Loc
)),
4395 Then_Statements
=> New_List
(Null_Raise_Statement
));
4398 Append_To
(After_Statements
, Null_Raise_Statement
);
4401 -- Loop through every parameter and get its value from the stream. If
4402 -- the parameter is unconstrained, then the parameter is read using
4403 -- 'Input at the point of declaration.
4405 Current_Parameter
:= First
(Ordered_Parameters_List
);
4406 while Present
(Current_Parameter
) loop
4409 Constrained
: Boolean;
4411 Object
: constant Entity_Id
:=
4412 Make_Defining_Identifier
(Loc
,
4413 New_Internal_Name
('P'));
4415 Expr
: Node_Id
:= Empty
;
4417 Is_Controlling_Formal
: constant Boolean :=
4418 Is_RACW_Controlling_Formal
4419 (Current_Parameter
, Stub_Type
);
4422 Set_Ekind
(Object
, E_Variable
);
4424 if Is_Controlling_Formal
then
4426 -- We have a controlling formal parameter. Read its address
4427 -- rather than a real object. The address is in Unsigned_64
4430 Etyp
:= RTE
(RE_Unsigned_64
);
4432 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
4436 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
4438 if In_Present
(Current_Parameter
)
4439 or else not Out_Present
(Current_Parameter
)
4440 or else not Constrained
4441 or else Is_Controlling_Formal
4443 -- If an input parameter is contrained, then its reading is
4444 -- deferred until the beginning of the subprogram body. If
4445 -- it is unconstrained, then an expression is built for
4446 -- the object declaration and the variable is set using
4447 -- 'Input instead of 'Read.
4449 if Constrained
and then not Is_Controlling_Formal
then
4450 Append_To
(Statements
,
4451 Make_Attribute_Reference
(Loc
,
4452 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4453 Attribute_Name
=> Name_Read
,
4454 Expressions
=> New_List
(
4455 Make_Selected_Component
(Loc
,
4456 Prefix
=> Request_Parameter
,
4457 Selector_Name
=> Name_Params
),
4458 New_Occurrence_Of
(Object
, Loc
))));
4461 Expr
:= Input_With_Tag_Check
(Loc
,
4463 Stream
=> Make_Selected_Component
(Loc
,
4464 Prefix
=> Request_Parameter
,
4465 Selector_Name
=> Name_Params
));
4466 Append_To
(Decls
, Expr
);
4467 Expr
:= Make_Function_Call
(Loc
,
4468 New_Occurrence_Of
(Defining_Unit_Name
4469 (Specification
(Expr
)), Loc
));
4473 -- If we do not have to output the current parameter, then it
4474 -- can well be flagged as constant. This may allow further
4475 -- optimizations done by the back end.
4478 Make_Object_Declaration
(Loc
,
4479 Defining_Identifier
=> Object
,
4480 Constant_Present
=> not Constrained
4481 and then not Out_Present
(Current_Parameter
),
4482 Object_Definition
=>
4483 New_Occurrence_Of
(Etyp
, Loc
),
4484 Expression
=> Expr
));
4486 -- An out parameter may be written back using a 'Write
4487 -- attribute instead of a 'Output because it has been
4488 -- constrained by the parameter given to the caller. Note that
4489 -- out controlling arguments in the case of a RACW are not put
4490 -- back in the stream because the pointer on them has not
4493 if Out_Present
(Current_Parameter
)
4495 Etype
(Parameter_Type
(Current_Parameter
)) /= Stub_Type
4497 Append_To
(After_Statements
,
4498 Make_Attribute_Reference
(Loc
,
4499 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4500 Attribute_Name
=> Name_Write
,
4501 Expressions
=> New_List
(
4502 Make_Selected_Component
(Loc
,
4503 Prefix
=> Request_Parameter
,
4504 Selector_Name
=> Name_Result
),
4505 New_Occurrence_Of
(Object
, Loc
))));
4508 -- For RACW controlling formals, the Etyp of Object is always
4509 -- an RACW, even if the parameter is not of an anonymous access
4510 -- type. In such case, we need to dereference it at call time.
4512 if Is_Controlling_Formal
then
4513 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
4516 Append_To
(Parameter_List
,
4517 Make_Parameter_Association
(Loc
,
4520 Defining_Identifier
(Current_Parameter
), Loc
),
4521 Explicit_Actual_Parameter
=>
4522 Make_Explicit_Dereference
(Loc
,
4523 Unchecked_Convert_To
(RACW_Type
,
4524 OK_Convert_To
(RTE
(RE_Address
),
4525 New_Occurrence_Of
(Object
, Loc
))))));
4528 Append_To
(Parameter_List
,
4529 Make_Parameter_Association
(Loc
,
4532 Defining_Identifier
(Current_Parameter
), Loc
),
4533 Explicit_Actual_Parameter
=>
4534 Unchecked_Convert_To
(RACW_Type
,
4535 OK_Convert_To
(RTE
(RE_Address
),
4536 New_Occurrence_Of
(Object
, Loc
)))));
4540 Append_To
(Parameter_List
,
4541 Make_Parameter_Association
(Loc
,
4544 Defining_Identifier
(Current_Parameter
), Loc
),
4545 Explicit_Actual_Parameter
=>
4546 New_Occurrence_Of
(Object
, Loc
)));
4549 -- If the current parameter needs an extra formal, then read it
4550 -- from the stream and set the corresponding semantic field in
4551 -- the variable. If the kind of the parameter identifier is
4552 -- E_Void, then this is a compiler generated parameter that
4553 -- doesn't need an extra constrained status.
4555 -- The case of Extra_Accessibility should also be handled ???
4557 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
4560 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
4562 Present
(Extra_Constrained
4563 (Defining_Identifier
(Current_Parameter
)))
4566 Extra_Parameter
: constant Entity_Id
:=
4568 (Defining_Identifier
4569 (Current_Parameter
));
4571 Formal_Entity
: constant Entity_Id
:=
4572 Make_Defining_Identifier
4573 (Loc
, Chars
(Extra_Parameter
));
4575 Formal_Type
: constant Entity_Id
:=
4576 Etype
(Extra_Parameter
);
4580 Make_Object_Declaration
(Loc
,
4581 Defining_Identifier
=> Formal_Entity
,
4582 Object_Definition
=>
4583 New_Occurrence_Of
(Formal_Type
, Loc
)));
4585 Append_To
(Extra_Formal_Statements
,
4586 Make_Attribute_Reference
(Loc
,
4587 Prefix
=> New_Occurrence_Of
(
4589 Attribute_Name
=> Name_Read
,
4590 Expressions
=> New_List
(
4591 Make_Selected_Component
(Loc
,
4592 Prefix
=> Request_Parameter
,
4593 Selector_Name
=> Name_Params
),
4594 New_Occurrence_Of
(Formal_Entity
, Loc
))));
4595 Set_Extra_Constrained
(Object
, Formal_Entity
);
4600 Next
(Current_Parameter
);
4603 -- Append the formal statements list at the end of regular statements
4605 Append_List_To
(Statements
, Extra_Formal_Statements
);
4607 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
4609 -- The remote subprogram is a function. We build an inner block to
4610 -- be able to hold a potentially unconstrained result in a
4614 Etyp
: constant Entity_Id
:=
4615 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
4616 Result
: constant Node_Id
:=
4617 Make_Defining_Identifier
(Loc
,
4618 New_Internal_Name
('R'));
4620 Inner_Decls
:= New_List
(
4621 Make_Object_Declaration
(Loc
,
4622 Defining_Identifier
=> Result
,
4623 Constant_Present
=> True,
4624 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
4626 Make_Function_Call
(Loc
,
4627 Name
=> Called_Subprogram
,
4628 Parameter_Associations
=> Parameter_List
)));
4630 Append_To
(After_Statements
,
4631 Make_Attribute_Reference
(Loc
,
4632 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4633 Attribute_Name
=> Name_Output
,
4634 Expressions
=> New_List
(
4635 Make_Selected_Component
(Loc
,
4636 Prefix
=> Request_Parameter
,
4637 Selector_Name
=> Name_Result
),
4638 New_Occurrence_Of
(Result
, Loc
))));
4641 Append_To
(Statements
,
4642 Make_Block_Statement
(Loc
,
4643 Declarations
=> Inner_Decls
,
4644 Handled_Statement_Sequence
=>
4645 Make_Handled_Sequence_Of_Statements
(Loc
,
4646 Statements
=> After_Statements
)));
4649 -- The remote subprogram is a procedure. We do not need any inner
4650 -- block in this case.
4652 if Dynamically_Asynchronous
then
4654 Make_Object_Declaration
(Loc
,
4655 Defining_Identifier
=> Dynamic_Async
,
4656 Object_Definition
=>
4657 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
4659 Append_To
(Statements
,
4660 Make_Attribute_Reference
(Loc
,
4661 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4662 Attribute_Name
=> Name_Read
,
4663 Expressions
=> New_List
(
4664 Make_Selected_Component
(Loc
,
4665 Prefix
=> Request_Parameter
,
4666 Selector_Name
=> Name_Params
),
4667 New_Occurrence_Of
(Dynamic_Async
, Loc
))));
4670 Append_To
(Statements
,
4671 Make_Procedure_Call_Statement
(Loc
,
4672 Name
=> Called_Subprogram
,
4673 Parameter_Associations
=> Parameter_List
));
4675 Append_List_To
(Statements
, After_Statements
);
4678 if Asynchronous
and then not Dynamically_Asynchronous
then
4680 -- For an asynchronous procedure, add a null exception handler
4682 Excep_Handlers
:= New_List
(
4683 Make_Exception_Handler
(Loc
,
4684 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
4685 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
4688 -- In the other cases, if an exception is raised, then the
4689 -- exception occurrence is copied into the output stream and
4690 -- no other output parameter is written.
4693 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
4695 Excep_Code
:= New_List
(
4696 Make_Attribute_Reference
(Loc
,
4698 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4699 Attribute_Name
=> Name_Write
,
4700 Expressions
=> New_List
(
4701 Make_Selected_Component
(Loc
,
4702 Prefix
=> Request_Parameter
,
4703 Selector_Name
=> Name_Result
),
4704 New_Occurrence_Of
(Excep_Choice
, Loc
))));
4706 if Dynamically_Asynchronous
then
4707 Excep_Code
:= New_List
(
4708 Make_Implicit_If_Statement
(Vis_Decl
,
4709 Condition
=> Make_Op_Not
(Loc
,
4710 New_Occurrence_Of
(Dynamic_Async
, Loc
)),
4711 Then_Statements
=> Excep_Code
));
4714 Excep_Handlers
:= New_List
(
4715 Make_Exception_Handler
(Loc
,
4716 Choice_Parameter
=> Excep_Choice
,
4717 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
4718 Statements
=> Excep_Code
));
4723 Make_Procedure_Specification
(Loc
,
4724 Defining_Unit_Name
=>
4725 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
4727 Parameter_Specifications
=> New_List
(
4728 Make_Parameter_Specification
(Loc
,
4729 Defining_Identifier
=> Request_Parameter
,
4731 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
4734 Make_Subprogram_Body
(Loc
,
4735 Specification
=> Subp_Spec
,
4736 Declarations
=> Decls
,
4737 Handled_Statement_Sequence
=>
4738 Make_Handled_Sequence_Of_Statements
(Loc
,
4739 Statements
=> Statements
,
4740 Exception_Handlers
=> Excep_Handlers
));
4741 end Build_Subprogram_Receiving_Stubs
;
4747 function Result
return Node_Id
is
4749 return Make_Identifier
(Loc
, Name_V
);
4752 ----------------------
4753 -- Stream_Parameter --
4754 ----------------------
4756 function Stream_Parameter
return Node_Id
is
4758 return Make_Identifier
(Loc
, Name_S
);
4759 end Stream_Parameter
;
4763 -----------------------------
4764 -- Make_Selected_Component --
4765 -----------------------------
4767 function Make_Selected_Component
4770 Selector_Name
: Name_Id
) return Node_Id
4773 return Make_Selected_Component
(Loc
,
4774 Prefix
=> New_Occurrence_Of
(Prefix
, Loc
),
4775 Selector_Name
=> Make_Identifier
(Loc
, Selector_Name
));
4776 end Make_Selected_Component
;
4778 -----------------------
4779 -- Get_Subprogram_Id --
4780 -----------------------
4782 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
is
4784 return Get_Subprogram_Ids
(Def
).Str_Identifier
;
4785 end Get_Subprogram_Id
;
4787 -----------------------
4788 -- Get_Subprogram_Id --
4789 -----------------------
4791 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
is
4793 return Get_Subprogram_Ids
(Def
).Int_Identifier
;
4794 end Get_Subprogram_Id
;
4796 ------------------------
4797 -- Get_Subprogram_Ids --
4798 ------------------------
4800 function Get_Subprogram_Ids
4801 (Def
: Entity_Id
) return Subprogram_Identifiers
4803 Result
: Subprogram_Identifiers
:=
4804 Subprogram_Identifier_Table
.Get
(Def
);
4806 Current_Declaration
: Node_Id
;
4807 Current_Subp
: Entity_Id
;
4808 Current_Subp_Str
: String_Id
;
4809 Current_Subp_Number
: Int
:= First_RCI_Subprogram_Id
;
4812 if Result
.Str_Identifier
= No_String
then
4814 -- We are looking up this subprogram's identifier outside of the
4815 -- context of generating calling or receiving stubs. Hence we are
4816 -- processing an 'Access attribute_reference for an RCI subprogram,
4817 -- for the purpose of obtaining a RAS value.
4820 (Is_Remote_Call_Interface
(Scope
(Def
))
4822 (Nkind
(Parent
(Def
)) = N_Procedure_Specification
4824 Nkind
(Parent
(Def
)) = N_Function_Specification
));
4826 Current_Declaration
:=
4827 First
(Visible_Declarations
4828 (Package_Specification_Of_Scope
(Scope
(Def
))));
4829 while Present
(Current_Declaration
) loop
4830 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
4831 and then Comes_From_Source
(Current_Declaration
)
4833 Current_Subp
:= Defining_Unit_Name
(Specification
(
4834 Current_Declaration
));
4835 Assign_Subprogram_Identifier
4836 (Current_Subp
, Current_Subp_Number
, Current_Subp_Str
);
4838 if Current_Subp
= Def
then
4839 Result
:= (Current_Subp_Str
, Current_Subp_Number
);
4842 Current_Subp_Number
:= Current_Subp_Number
+ 1;
4845 Next
(Current_Declaration
);
4849 pragma Assert
(Result
.Str_Identifier
/= No_String
);
4851 end Get_Subprogram_Ids
;
4857 function Hash
(F
: Entity_Id
) return Hash_Index
is
4859 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
4862 function Hash
(F
: Name_Id
) return Hash_Index
is
4864 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
4867 --------------------------
4868 -- Input_With_Tag_Check --
4869 --------------------------
4871 function Input_With_Tag_Check
4873 Var_Type
: Entity_Id
;
4874 Stream
: Node_Id
) return Node_Id
4878 Make_Subprogram_Body
(Loc
,
4879 Specification
=> Make_Function_Specification
(Loc
,
4880 Defining_Unit_Name
=>
4881 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S')),
4882 Result_Definition
=> New_Occurrence_Of
(Var_Type
, Loc
)),
4883 Declarations
=> No_List
,
4884 Handled_Statement_Sequence
=>
4885 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
4886 Make_Tag_Check
(Loc
,
4887 Make_Return_Statement
(Loc
,
4888 Make_Attribute_Reference
(Loc
,
4889 Prefix
=> New_Occurrence_Of
(Var_Type
, Loc
),
4890 Attribute_Name
=> Name_Input
,
4892 New_List
(Stream
)))))));
4893 end Input_With_Tag_Check
;
4895 --------------------------------
4896 -- Is_RACW_Controlling_Formal --
4897 --------------------------------
4899 function Is_RACW_Controlling_Formal
4900 (Parameter
: Node_Id
;
4901 Stub_Type
: Entity_Id
) return Boolean
4906 -- If the kind of the parameter is E_Void, then it is not a
4907 -- controlling formal (this can happen in the context of RAS).
4909 if Ekind
(Defining_Identifier
(Parameter
)) = E_Void
then
4913 -- If the parameter is not a controlling formal, then it cannot
4914 -- be possibly a RACW_Controlling_Formal.
4916 if not Is_Controlling_Formal
(Defining_Identifier
(Parameter
)) then
4920 Typ
:= Parameter_Type
(Parameter
);
4921 return (Nkind
(Typ
) = N_Access_Definition
4922 and then Etype
(Subtype_Mark
(Typ
)) = Stub_Type
)
4923 or else Etype
(Typ
) = Stub_Type
;
4924 end Is_RACW_Controlling_Formal
;
4926 --------------------
4927 -- Make_Tag_Check --
4928 --------------------
4930 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
is
4931 Occ
: constant Entity_Id
:=
4932 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
4935 return Make_Block_Statement
(Loc
,
4936 Handled_Statement_Sequence
=>
4937 Make_Handled_Sequence_Of_Statements
(Loc
,
4938 Statements
=> New_List
(N
),
4940 Exception_Handlers
=> New_List
(
4941 Make_Exception_Handler
(Loc
,
4942 Choice_Parameter
=> Occ
,
4944 Exception_Choices
=>
4945 New_List
(New_Occurrence_Of
(RTE
(RE_Tag_Error
), Loc
)),
4948 New_List
(Make_Procedure_Call_Statement
(Loc
,
4950 (RTE
(RE_Raise_Program_Error_Unknown_Tag
), Loc
),
4951 New_List
(New_Occurrence_Of
(Occ
, Loc
))))))));
4954 ----------------------------
4955 -- Need_Extra_Constrained --
4956 ----------------------------
4958 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean is
4959 Etyp
: constant Entity_Id
:= Etype
(Parameter_Type
(Parameter
));
4961 return Out_Present
(Parameter
)
4962 and then Has_Discriminants
(Etyp
)
4963 and then not Is_Constrained
(Etyp
)
4964 and then not Is_Indefinite_Subtype
(Etyp
);
4965 end Need_Extra_Constrained
;
4967 ------------------------------------
4968 -- Pack_Entity_Into_Stream_Access --
4969 ------------------------------------
4971 function Pack_Entity_Into_Stream_Access
4975 Etyp
: Entity_Id
:= Empty
) return Node_Id
4980 if Present
(Etyp
) then
4983 Typ
:= Etype
(Object
);
4987 Pack_Node_Into_Stream_Access
(Loc
,
4989 Object
=> New_Occurrence_Of
(Object
, Loc
),
4991 end Pack_Entity_Into_Stream_Access
;
4993 ---------------------------
4994 -- Pack_Node_Into_Stream --
4995 ---------------------------
4997 function Pack_Node_Into_Stream
5001 Etyp
: Entity_Id
) return Node_Id
5003 Write_Attribute
: Name_Id
:= Name_Write
;
5006 if not Is_Constrained
(Etyp
) then
5007 Write_Attribute
:= Name_Output
;
5011 Make_Attribute_Reference
(Loc
,
5012 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5013 Attribute_Name
=> Write_Attribute
,
5014 Expressions
=> New_List
(
5015 Make_Attribute_Reference
(Loc
,
5016 Prefix
=> New_Occurrence_Of
(Stream
, Loc
),
5017 Attribute_Name
=> Name_Access
),
5019 end Pack_Node_Into_Stream
;
5021 ----------------------------------
5022 -- Pack_Node_Into_Stream_Access --
5023 ----------------------------------
5025 function Pack_Node_Into_Stream_Access
5029 Etyp
: Entity_Id
) return Node_Id
5031 Write_Attribute
: Name_Id
:= Name_Write
;
5034 if not Is_Constrained
(Etyp
) then
5035 Write_Attribute
:= Name_Output
;
5039 Make_Attribute_Reference
(Loc
,
5040 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5041 Attribute_Name
=> Write_Attribute
,
5042 Expressions
=> New_List
(
5045 end Pack_Node_Into_Stream_Access
;
5047 ---------------------
5048 -- PolyORB_Support --
5049 ---------------------
5051 package body PolyORB_Support
is
5053 -- Local subprograms
5055 procedure Add_RACW_Read_Attribute
5056 (RACW_Type
: Entity_Id
;
5057 Stub_Type
: Entity_Id
;
5058 Stub_Type_Access
: Entity_Id
;
5059 Declarations
: List_Id
);
5060 -- Add Read attribute in Decls for the RACW type. The Read attribute
5061 -- is added right after the RACW_Type declaration while the body is
5062 -- inserted after Declarations.
5064 procedure Add_RACW_Write_Attribute
5065 (RACW_Type
: Entity_Id
;
5066 Stub_Type
: Entity_Id
;
5067 Stub_Type_Access
: Entity_Id
;
5068 Declarations
: List_Id
);
5069 -- Same thing for the Write attribute
5071 procedure Add_RACW_From_Any
5072 (RACW_Type
: Entity_Id
;
5073 Stub_Type
: Entity_Id
;
5074 Stub_Type_Access
: Entity_Id
;
5075 Declarations
: List_Id
);
5076 -- Add the From_Any TSS for this RACW type
5078 procedure Add_RACW_To_Any
5079 (Designated_Type
: Entity_Id
;
5080 RACW_Type
: Entity_Id
;
5081 Stub_Type
: Entity_Id
;
5082 Stub_Type_Access
: Entity_Id
;
5083 Declarations
: List_Id
);
5084 -- Add the To_Any TSS for this RACW type
5086 procedure Add_RACW_TypeCode
5087 (Designated_Type
: Entity_Id
;
5088 RACW_Type
: Entity_Id
;
5089 Declarations
: List_Id
);
5090 -- Add the TypeCode TSS for this RACW type
5092 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
);
5093 -- Add the From_Any TSS for this RAS type
5095 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
);
5096 -- Add the To_Any TSS for this RAS type
5098 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
);
5099 -- Add the TypeCode TSS for this RAS type
5101 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
5102 -- Add a subprogram body for RAS Access TSS
5104 -------------------------------------
5105 -- Add_Obj_RPC_Receiver_Completion --
5106 -------------------------------------
5108 procedure Add_Obj_RPC_Receiver_Completion
5111 RPC_Receiver
: Entity_Id
;
5112 Stub_Elements
: Stub_Structure
)
5114 Desig
: constant Entity_Id
:=
5115 Etype
(Designated_Type
(Stub_Elements
.RACW_Type
));
5118 Make_Procedure_Call_Statement
(Loc
,
5121 RTE
(RE_Register_Obj_Receiving_Stub
), Loc
),
5123 Parameter_Associations
=> New_List
(
5127 Make_String_Literal
(Loc
,
5128 Full_Qualified_Name
(Desig
)),
5132 Make_Attribute_Reference
(Loc
,
5135 Defining_Unit_Name
(Parent
(RPC_Receiver
)), Loc
),
5141 Make_Attribute_Reference
(Loc
,
5144 Defining_Identifier
(
5145 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5148 end Add_Obj_RPC_Receiver_Completion
;
5150 -----------------------
5151 -- Add_RACW_Features --
5152 -----------------------
5154 procedure Add_RACW_Features
5155 (RACW_Type
: Entity_Id
;
5157 Stub_Type
: Entity_Id
;
5158 Stub_Type_Access
: Entity_Id
;
5159 RPC_Receiver_Decl
: Node_Id
;
5160 Declarations
: List_Id
)
5162 pragma Warnings
(Off
);
5163 pragma Unreferenced
(RPC_Receiver_Decl
);
5164 pragma Warnings
(On
);
5168 (RACW_Type
=> RACW_Type
,
5169 Stub_Type
=> Stub_Type
,
5170 Stub_Type_Access
=> Stub_Type_Access
,
5171 Declarations
=> Declarations
);
5174 (Designated_Type
=> Desig
,
5175 RACW_Type
=> RACW_Type
,
5176 Stub_Type
=> Stub_Type
,
5177 Stub_Type_Access
=> Stub_Type_Access
,
5178 Declarations
=> Declarations
);
5180 -- In the PolyORB case, the RACW 'Read and 'Write attributes
5181 -- are implemented in terms of the From_Any and To_Any TSSs,
5182 -- so these TSSs must be expanded before 'Read and 'Write.
5184 Add_RACW_Write_Attribute
5185 (RACW_Type
=> RACW_Type
,
5186 Stub_Type
=> Stub_Type
,
5187 Stub_Type_Access
=> Stub_Type_Access
,
5188 Declarations
=> Declarations
);
5190 Add_RACW_Read_Attribute
5191 (RACW_Type
=> RACW_Type
,
5192 Stub_Type
=> Stub_Type
,
5193 Stub_Type_Access
=> Stub_Type_Access
,
5194 Declarations
=> Declarations
);
5197 (Designated_Type
=> Desig
,
5198 RACW_Type
=> RACW_Type
,
5199 Declarations
=> Declarations
);
5200 end Add_RACW_Features
;
5202 -----------------------
5203 -- Add_RACW_From_Any --
5204 -----------------------
5206 procedure Add_RACW_From_Any
5207 (RACW_Type
: Entity_Id
;
5208 Stub_Type
: Entity_Id
;
5209 Stub_Type_Access
: Entity_Id
;
5210 Declarations
: List_Id
)
5212 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5213 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5215 Fnam
: constant Entity_Id
:=
5216 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F'));
5218 Func_Spec
: Node_Id
;
5219 Func_Decl
: Node_Id
;
5220 Func_Body
: Node_Id
;
5223 Statements
: List_Id
;
5224 Stub_Statements
: List_Id
;
5225 Local_Statements
: List_Id
;
5226 -- Various parts of the subprogram
5228 Any_Parameter
: constant Entity_Id
:=
5229 Make_Defining_Identifier
(Loc
, Name_A
);
5230 Reference
: constant Entity_Id
:=
5231 Make_Defining_Identifier
5232 (Loc
, New_Internal_Name
('R'));
5233 Is_Local
: constant Entity_Id
:=
5234 Make_Defining_Identifier
5235 (Loc
, New_Internal_Name
('L'));
5236 Addr
: constant Entity_Id
:=
5237 Make_Defining_Identifier
5238 (Loc
, New_Internal_Name
('A'));
5239 Local_Stub
: constant Entity_Id
:=
5240 Make_Defining_Identifier
5241 (Loc
, New_Internal_Name
('L'));
5242 Stubbed_Result
: constant Entity_Id
:=
5243 Make_Defining_Identifier
5244 (Loc
, New_Internal_Name
('S'));
5246 Stub_Condition
: Node_Id
;
5247 -- An expression that determines whether we create a stub for the
5248 -- newly-unpacked RACW. Normally we create a stub only for remote
5249 -- objects, but in the case of an RACW used to implement a RAS,
5250 -- we also create a stub for local subprograms if a pragma
5251 -- All_Calls_Remote applies.
5253 Asynchronous_Flag
: constant Entity_Id
:=
5254 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5255 -- The flag object declared in Add_RACW_Asynchronous_Flag
5258 -- Object declarations
5261 Make_Object_Declaration
(Loc
,
5262 Defining_Identifier
=>
5264 Object_Definition
=>
5265 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5267 Make_Function_Call
(Loc
,
5269 New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
5270 Parameter_Associations
=> New_List
(
5271 New_Occurrence_Of
(Any_Parameter
, Loc
)))),
5273 Make_Object_Declaration
(Loc
,
5274 Defining_Identifier
=> Local_Stub
,
5275 Aliased_Present
=> True,
5276 Object_Definition
=> New_Occurrence_Of
(Stub_Type
, Loc
)),
5278 Make_Object_Declaration
(Loc
,
5279 Defining_Identifier
=> Stubbed_Result
,
5280 Object_Definition
=>
5281 New_Occurrence_Of
(Stub_Type_Access
, Loc
),
5283 Make_Attribute_Reference
(Loc
,
5285 New_Occurrence_Of
(Local_Stub
, Loc
),
5287 Name_Unchecked_Access
)),
5289 Make_Object_Declaration
(Loc
,
5290 Defining_Identifier
=> Is_Local
,
5291 Object_Definition
=>
5292 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
5294 Make_Object_Declaration
(Loc
,
5295 Defining_Identifier
=> Addr
,
5296 Object_Definition
=>
5297 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
5299 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
5301 Set_Etype
(Stubbed_Result
, Stub_Type_Access
);
5303 -- If the ref Is_Nil, return a null pointer
5305 Statements
:= New_List
(
5306 Make_Implicit_If_Statement
(RACW_Type
,
5308 Make_Function_Call
(Loc
,
5310 New_Occurrence_Of
(RTE
(RE_Is_Nil
), Loc
),
5311 Parameter_Associations
=> New_List
(
5312 New_Occurrence_Of
(Reference
, Loc
))),
5313 Then_Statements
=> New_List
(
5314 Make_Return_Statement
(Loc
,
5316 Make_Null
(Loc
)))));
5318 Append_To
(Statements
,
5319 Make_Procedure_Call_Statement
(Loc
,
5321 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
5322 Parameter_Associations
=> New_List
(
5323 New_Occurrence_Of
(Reference
, Loc
),
5324 New_Occurrence_Of
(Is_Local
, Loc
),
5325 New_Occurrence_Of
(Addr
, Loc
))));
5327 -- If the object is located on another partition, then a stub object
5328 -- will be created with all the information needed to rebuild the
5329 -- real object at the other end. This stanza is always used in the
5330 -- case of RAS types, for which a stub is required even for local
5333 Stub_Statements
:= New_List
(
5334 Make_Assignment_Statement
(Loc
,
5335 Name
=> Make_Selected_Component
(Loc
,
5336 Prefix
=> Stubbed_Result
,
5337 Selector_Name
=> Name_Target
),
5339 Make_Function_Call
(Loc
,
5341 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
5342 Parameter_Associations
=> New_List
(
5343 New_Occurrence_Of
(Reference
, Loc
)))),
5345 Make_Procedure_Call_Statement
(Loc
,
5347 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
5348 Parameter_Associations
=> New_List
(
5349 Make_Selected_Component
(Loc
,
5350 Prefix
=> Stubbed_Result
,
5351 Selector_Name
=> Name_Target
))),
5353 Make_Assignment_Statement
(Loc
,
5354 Name
=> Make_Selected_Component
(Loc
,
5355 Prefix
=> Stubbed_Result
,
5356 Selector_Name
=> Name_Asynchronous
),
5358 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)));
5360 -- ??? Issue with asynchronous calls here: the Asynchronous
5361 -- flag is set on the stub type if, and only if, the RACW type
5362 -- has a pragma Asynchronous. This is incorrect for RACWs that
5363 -- implement RAS types, because in that case the /designated
5364 -- subprogram/ (not the type) might be asynchronous, and
5365 -- that causes the stub to need to be asynchronous too.
5366 -- A solution is to transport a RAS as a struct containing
5367 -- a RACW and an asynchronous flag, and to properly alter
5368 -- the Asynchronous component in the stub type in the RAS's
5371 Append_List_To
(Stub_Statements
,
5372 Build_Get_Unique_RP_Call
(Loc
, Stubbed_Result
, Stub_Type
));
5374 -- Distinguish between the local and remote cases, and execute the
5375 -- appropriate piece of code.
5377 Stub_Condition
:= New_Occurrence_Of
(Is_Local
, Loc
);
5380 Stub_Condition
:= Make_And_Then
(Loc
,
5384 Make_Selected_Component
(Loc
,
5386 Unchecked_Convert_To
(
5387 RTE
(RE_RAS_Proxy_Type_Access
),
5388 New_Occurrence_Of
(Addr
, Loc
)),
5390 Make_Identifier
(Loc
,
5391 Name_All_Calls_Remote
)));
5394 Local_Statements
:= New_List
(
5395 Make_Return_Statement
(Loc
,
5397 Unchecked_Convert_To
(RACW_Type
,
5398 New_Occurrence_Of
(Addr
, Loc
))));
5400 Append_To
(Statements
,
5401 Make_Implicit_If_Statement
(RACW_Type
,
5404 Then_Statements
=> Local_Statements
,
5405 Else_Statements
=> Stub_Statements
));
5407 Append_To
(Statements
,
5408 Make_Return_Statement
(Loc
,
5409 Expression
=> Unchecked_Convert_To
(RACW_Type
,
5410 New_Occurrence_Of
(Stubbed_Result
, Loc
))));
5413 Make_Function_Specification
(Loc
,
5414 Defining_Unit_Name
=>
5416 Parameter_Specifications
=> New_List
(
5417 Make_Parameter_Specification
(Loc
,
5418 Defining_Identifier
=>
5421 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
5422 Result_Definition
=> New_Occurrence_Of
(RACW_Type
, Loc
));
5424 -- NOTE: The usage occurrences of RACW_Parameter must
5425 -- refer to the entity in the declaration spec, not those
5426 -- of the body spec.
5428 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5431 Make_Subprogram_Body
(Loc
,
5433 Copy_Specification
(Loc
, Func_Spec
),
5434 Declarations
=> Decls
,
5435 Handled_Statement_Sequence
=>
5436 Make_Handled_Sequence_Of_Statements
(Loc
,
5437 Statements
=> Statements
));
5439 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5440 Append_To
(Declarations
, Func_Body
);
5442 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_From_Any
);
5443 end Add_RACW_From_Any
;
5445 -----------------------------
5446 -- Add_RACW_Read_Attribute --
5447 -----------------------------
5449 procedure Add_RACW_Read_Attribute
5450 (RACW_Type
: Entity_Id
;
5451 Stub_Type
: Entity_Id
;
5452 Stub_Type_Access
: Entity_Id
;
5453 Declarations
: List_Id
)
5455 pragma Warnings
(Off
);
5456 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
5457 pragma Warnings
(On
);
5458 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5460 Proc_Decl
: Node_Id
;
5461 Attr_Decl
: Node_Id
;
5463 Body_Node
: Node_Id
;
5466 Statements
: List_Id
;
5467 -- Various parts of the procedure
5469 Procedure_Name
: constant Name_Id
:=
5470 New_Internal_Name
('R');
5471 Source_Ref
: constant Entity_Id
:=
5472 Make_Defining_Identifier
5473 (Loc
, New_Internal_Name
('R'));
5474 Asynchronous_Flag
: constant Entity_Id
:=
5475 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5476 pragma Assert
(Present
(Asynchronous_Flag
));
5478 function Stream_Parameter
return Node_Id
;
5479 function Result
return Node_Id
;
5480 -- Functions to create occurrences of the formal parameter names
5486 function Result
return Node_Id
is
5488 return Make_Identifier
(Loc
, Name_V
);
5491 ----------------------
5492 -- Stream_Parameter --
5493 ----------------------
5495 function Stream_Parameter
return Node_Id
is
5497 return Make_Identifier
(Loc
, Name_S
);
5498 end Stream_Parameter
;
5500 -- Start of processing for Add_RACW_Read_Attribute
5503 -- Generate object declarations
5506 Make_Object_Declaration
(Loc
,
5507 Defining_Identifier
=> Source_Ref
,
5508 Object_Definition
=>
5509 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)));
5511 Statements
:= New_List
(
5512 Make_Attribute_Reference
(Loc
,
5514 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5515 Attribute_Name
=> Name_Read
,
5516 Expressions
=> New_List
(
5518 New_Occurrence_Of
(Source_Ref
, Loc
))),
5519 Make_Assignment_Statement
(Loc
,
5523 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
5525 Make_Function_Call
(Loc
,
5527 New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
5528 Parameter_Associations
=> New_List
(
5529 New_Occurrence_Of
(Source_Ref
, Loc
))),
5532 Build_Stream_Procedure
5533 (Loc
, RACW_Type
, Body_Node
,
5534 Make_Defining_Identifier
(Loc
, Procedure_Name
),
5535 Statements
, Outp
=> True);
5536 Set_Declarations
(Body_Node
, Decls
);
5538 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
5539 Copy_Specification
(Loc
, Specification
(Body_Node
)));
5542 Make_Attribute_Definition_Clause
(Loc
,
5543 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
5547 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
5549 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
5550 Insert_After
(Proc_Decl
, Attr_Decl
);
5551 Append_To
(Declarations
, Body_Node
);
5552 end Add_RACW_Read_Attribute
;
5554 ---------------------
5555 -- Add_RACW_To_Any --
5556 ---------------------
5558 procedure Add_RACW_To_Any
5559 (Designated_Type
: Entity_Id
;
5560 RACW_Type
: Entity_Id
;
5561 Stub_Type
: Entity_Id
;
5562 Stub_Type_Access
: Entity_Id
;
5563 Declarations
: List_Id
)
5565 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5567 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5571 Stub_Elements
: constant Stub_Structure
:=
5572 Stubs_Table
.Get
(Designated_Type
);
5573 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5575 Func_Spec
: Node_Id
;
5576 Func_Decl
: Node_Id
;
5577 Func_Body
: Node_Id
;
5580 Statements
: List_Id
;
5581 Null_Statements
: List_Id
;
5582 Local_Statements
: List_Id
:= No_List
;
5583 Stub_Statements
: List_Id
;
5585 -- Various parts of the subprogram
5587 RACW_Parameter
: constant Entity_Id
5588 := Make_Defining_Identifier
(Loc
, Name_R
);
5590 Reference
: constant Entity_Id
:=
5591 Make_Defining_Identifier
5592 (Loc
, New_Internal_Name
('R'));
5593 Any
: constant Entity_Id
:=
5594 Make_Defining_Identifier
5595 (Loc
, New_Internal_Name
('A'));
5598 -- Object declarations
5601 Make_Object_Declaration
(Loc
,
5602 Defining_Identifier
=>
5604 Object_Definition
=>
5605 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
5606 Make_Object_Declaration
(Loc
,
5607 Defining_Identifier
=>
5609 Object_Definition
=>
5610 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
5612 -- If the object is null, nothing to do (Reference is already
5615 Null_Statements
:= New_List
(Make_Null_Statement
(Loc
));
5619 -- If the object is a RAS designating a local subprogram,
5620 -- we already have a target reference.
5622 Local_Statements
:= New_List
(
5623 Make_Procedure_Call_Statement
(Loc
,
5625 New_Occurrence_Of
(RTE
(RE_Set_Ref
), Loc
),
5626 Parameter_Associations
=> New_List
(
5627 New_Occurrence_Of
(Reference
, Loc
),
5628 Make_Selected_Component
(Loc
,
5630 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
5631 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5632 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)))));
5635 -- If the object is a local RACW object, use Get_Reference now
5636 -- to obtain a reference.
5638 Local_Statements
:= New_List
(
5639 Make_Procedure_Call_Statement
(Loc
,
5641 New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
5642 Parameter_Associations
=> New_List
(
5643 Unchecked_Convert_To
(
5645 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5646 Make_String_Literal
(Loc
,
5647 Full_Qualified_Name
(Designated_Type
)),
5648 Make_Attribute_Reference
(Loc
,
5651 Defining_Identifier
(
5652 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5655 New_Occurrence_Of
(Reference
, Loc
))));
5658 -- If the object is located on another partition, use the target
5661 Stub_Statements
:= New_List
(
5662 Make_Procedure_Call_Statement
(Loc
,
5664 New_Occurrence_Of
(RTE
(RE_Set_Ref
), Loc
),
5665 Parameter_Associations
=> New_List
(
5666 New_Occurrence_Of
(Reference
, Loc
),
5667 Make_Selected_Component
(Loc
,
5668 Prefix
=> Unchecked_Convert_To
(Stub_Type_Access
,
5669 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5671 Make_Identifier
(Loc
, Name_Target
)))));
5673 -- Distinguish between the null, local and remote cases,
5674 -- and execute the appropriate piece of code.
5677 Make_Implicit_If_Statement
(RACW_Type
,
5680 Left_Opnd
=> New_Occurrence_Of
(RACW_Parameter
, Loc
),
5681 Right_Opnd
=> Make_Null
(Loc
)),
5682 Then_Statements
=> Null_Statements
,
5683 Elsif_Parts
=> New_List
(
5684 Make_Elsif_Part
(Loc
,
5688 Make_Attribute_Reference
(Loc
,
5690 New_Occurrence_Of
(RACW_Parameter
, Loc
),
5691 Attribute_Name
=> Name_Tag
),
5693 Make_Attribute_Reference
(Loc
,
5694 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
5695 Attribute_Name
=> Name_Tag
)),
5696 Then_Statements
=> Local_Statements
)),
5697 Else_Statements
=> Stub_Statements
);
5699 Statements
:= New_List
(
5701 Make_Assignment_Statement
(Loc
,
5703 New_Occurrence_Of
(Any
, Loc
),
5705 Make_Function_Call
(Loc
,
5706 Name
=> New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
5707 Parameter_Associations
=> New_List
(
5708 New_Occurrence_Of
(Reference
, Loc
)))),
5709 Make_Procedure_Call_Statement
(Loc
,
5711 New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
5712 Parameter_Associations
=> New_List
(
5713 New_Occurrence_Of
(Any
, Loc
),
5714 Make_Selected_Component
(Loc
,
5716 Defining_Identifier
(
5717 Stub_Elements
.RPC_Receiver_Decl
),
5718 Selector_Name
=> Name_Obj_TypeCode
))),
5719 Make_Return_Statement
(Loc
,
5721 New_Occurrence_Of
(Any
, Loc
)));
5723 Fnam
:= Make_Defining_Identifier
(
5724 Loc
, New_Internal_Name
('T'));
5727 Make_Function_Specification
(Loc
,
5728 Defining_Unit_Name
=>
5730 Parameter_Specifications
=> New_List
(
5731 Make_Parameter_Specification
(Loc
,
5732 Defining_Identifier
=>
5735 New_Occurrence_Of
(RACW_Type
, Loc
))),
5736 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
5738 -- NOTE: The usage occurrences of RACW_Parameter must
5739 -- refer to the entity in the declaration spec, not in
5742 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5745 Make_Subprogram_Body
(Loc
,
5747 Copy_Specification
(Loc
, Func_Spec
),
5748 Declarations
=> Decls
,
5749 Handled_Statement_Sequence
=>
5750 Make_Handled_Sequence_Of_Statements
(Loc
,
5751 Statements
=> Statements
));
5753 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5754 Append_To
(Declarations
, Func_Body
);
5756 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_To_Any
);
5757 end Add_RACW_To_Any
;
5759 -----------------------
5760 -- Add_RACW_TypeCode --
5761 -----------------------
5763 procedure Add_RACW_TypeCode
5764 (Designated_Type
: Entity_Id
;
5765 RACW_Type
: Entity_Id
;
5766 Declarations
: List_Id
)
5768 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5772 Stub_Elements
: constant Stub_Structure
:=
5773 Stubs_Table
.Get
(Designated_Type
);
5774 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5776 Func_Spec
: Node_Id
;
5777 Func_Decl
: Node_Id
;
5778 Func_Body
: Node_Id
;
5782 Make_Defining_Identifier
(Loc
,
5783 Chars
=> New_Internal_Name
('T'));
5785 -- The spec for this subprogram has a dummy 'access RACW'
5786 -- argument, which serves only for overloading purposes.
5789 Make_Function_Specification
(Loc
,
5790 Defining_Unit_Name
=>
5792 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
5794 -- NOTE: The usage occurrences of RACW_Parameter must
5795 -- refer to the entity in the declaration spec, not those
5796 -- of the body spec.
5798 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5801 Make_Subprogram_Body
(Loc
,
5803 Copy_Specification
(Loc
, Func_Spec
),
5804 Declarations
=> Empty_List
,
5805 Handled_Statement_Sequence
=>
5806 Make_Handled_Sequence_Of_Statements
(Loc
,
5807 Statements
=> New_List
(
5808 Make_Return_Statement
(Loc
,
5810 Make_Selected_Component
(Loc
,
5812 Defining_Identifier
(
5813 Stub_Elements
.RPC_Receiver_Decl
),
5814 Selector_Name
=> Name_Obj_TypeCode
)))));
5816 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5817 Append_To
(Declarations
, Func_Body
);
5819 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_TypeCode
);
5820 end Add_RACW_TypeCode
;
5822 ------------------------------
5823 -- Add_RACW_Write_Attribute --
5824 ------------------------------
5826 procedure Add_RACW_Write_Attribute
5827 (RACW_Type
: Entity_Id
;
5828 Stub_Type
: Entity_Id
;
5829 Stub_Type_Access
: Entity_Id
;
5830 Declarations
: List_Id
)
5832 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5833 pragma Warnings
(Off
);
5834 pragma Unreferenced
(
5838 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5839 pragma Unreferenced
(Is_RAS
);
5840 pragma Warnings
(On
);
5842 Body_Node
: Node_Id
;
5843 Proc_Decl
: Node_Id
;
5844 Attr_Decl
: Node_Id
;
5846 Statements
: List_Id
;
5847 Procedure_Name
: constant Name_Id
:= New_Internal_Name
('R');
5849 function Stream_Parameter
return Node_Id
;
5850 function Object
return Node_Id
;
5851 -- Functions to create occurrences of the formal parameter names
5857 function Object
return Node_Id
is
5858 Object_Ref
: constant Node_Id
:=
5859 Make_Identifier
(Loc
, Name_V
);
5862 -- Etype must be set for Build_To_Any_Call
5864 Set_Etype
(Object_Ref
, RACW_Type
);
5869 ----------------------
5870 -- Stream_Parameter --
5871 ----------------------
5873 function Stream_Parameter
return Node_Id
is
5875 return Make_Identifier
(Loc
, Name_S
);
5876 end Stream_Parameter
;
5878 -- Start of processing for Add_RACW_Write_Attribute
5881 Statements
:= New_List
(
5882 Pack_Node_Into_Stream_Access
(Loc
,
5883 Stream
=> Stream_Parameter
,
5885 Make_Function_Call
(Loc
,
5887 New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
5888 Parameter_Associations
=> New_List
(
5889 PolyORB_Support
.Helpers
.Build_To_Any_Call
5890 (Object
, Declarations
))),
5891 Etyp
=> RTE
(RE_Object_Ref
)));
5893 Build_Stream_Procedure
5894 (Loc
, RACW_Type
, Body_Node
,
5895 Make_Defining_Identifier
(Loc
, Procedure_Name
),
5896 Statements
, Outp
=> False);
5899 Make_Subprogram_Declaration
(Loc
,
5900 Copy_Specification
(Loc
, Specification
(Body_Node
)));
5903 Make_Attribute_Definition_Clause
(Loc
,
5904 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
5905 Chars
=> Name_Write
,
5908 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
5910 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
5911 Insert_After
(Proc_Decl
, Attr_Decl
);
5912 Append_To
(Declarations
, Body_Node
);
5913 end Add_RACW_Write_Attribute
;
5915 -----------------------
5916 -- Add_RAST_Features --
5917 -----------------------
5919 procedure Add_RAST_Features
5920 (Vis_Decl
: Node_Id
;
5921 RAS_Type
: Entity_Id
)
5924 Add_RAS_Access_TSS
(Vis_Decl
);
5926 Add_RAS_From_Any
(RAS_Type
);
5927 Add_RAS_TypeCode
(RAS_Type
);
5929 -- To_Any uses TypeCode, and therefore needs to be generated last
5931 Add_RAS_To_Any
(RAS_Type
);
5932 end Add_RAST_Features
;
5934 ------------------------
5935 -- Add_RAS_Access_TSS --
5936 ------------------------
5938 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
5939 Loc
: constant Source_Ptr
:= Sloc
(N
);
5941 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
5942 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
5943 -- Ras_Type is the access to subprogram type; Fat_Type is the
5944 -- corresponding record type.
5946 RACW_Type
: constant Entity_Id
:=
5947 Underlying_RACW_Type
(Ras_Type
);
5948 Desig
: constant Entity_Id
:=
5949 Etype
(Designated_Type
(RACW_Type
));
5951 Stub_Elements
: constant Stub_Structure
:=
5952 Stubs_Table
.Get
(Desig
);
5953 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5955 Proc
: constant Entity_Id
:=
5956 Make_Defining_Identifier
(Loc
,
5957 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
5959 Proc_Spec
: Node_Id
;
5961 -- Formal parameters
5963 Package_Name
: constant Entity_Id
:=
5964 Make_Defining_Identifier
(Loc
,
5969 Subp_Id
: constant Entity_Id
:=
5970 Make_Defining_Identifier
(Loc
,
5973 -- Target subprogram
5975 Asynch_P
: constant Entity_Id
:=
5976 Make_Defining_Identifier
(Loc
,
5977 Chars
=> Name_Asynchronous
);
5978 -- Is the procedure to which the 'Access applies asynchronous?
5980 All_Calls_Remote
: constant Entity_Id
:=
5981 Make_Defining_Identifier
(Loc
,
5982 Chars
=> Name_All_Calls_Remote
);
5983 -- True if an All_Calls_Remote pragma applies to the RCI unit
5984 -- that contains the subprogram.
5986 -- Common local variables
5988 Proc_Decls
: List_Id
;
5989 Proc_Statements
: List_Id
;
5991 Subp_Ref
: constant Entity_Id
:=
5992 Make_Defining_Identifier
(Loc
, Name_R
);
5993 -- Reference that designates the target subprogram (returned
5994 -- by Get_RAS_Info).
5996 Is_Local
: constant Entity_Id
:=
5997 Make_Defining_Identifier
(Loc
, Name_L
);
5998 Local_Addr
: constant Entity_Id
:=
5999 Make_Defining_Identifier
(Loc
, Name_A
);
6000 -- For the call to Get_Local_Address
6002 -- Additional local variables for the remote case
6004 Local_Stub
: constant Entity_Id
:=
6005 Make_Defining_Identifier
(Loc
,
6006 Chars
=> New_Internal_Name
('L'));
6008 Stub_Ptr
: constant Entity_Id
:=
6009 Make_Defining_Identifier
(Loc
,
6010 Chars
=> New_Internal_Name
('S'));
6013 (Field_Name
: Name_Id
;
6014 Value
: Node_Id
) return Node_Id
;
6015 -- Construct an assignment that sets the named component in the
6023 (Field_Name
: Name_Id
;
6024 Value
: Node_Id
) return Node_Id
6028 Make_Assignment_Statement
(Loc
,
6030 Make_Selected_Component
(Loc
,
6032 Selector_Name
=> Field_Name
),
6033 Expression
=> Value
);
6036 -- Start of processing for Add_RAS_Access_TSS
6039 Proc_Decls
:= New_List
(
6041 -- Common declarations
6043 Make_Object_Declaration
(Loc
,
6044 Defining_Identifier
=> Subp_Ref
,
6045 Object_Definition
=>
6046 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
6048 Make_Object_Declaration
(Loc
,
6049 Defining_Identifier
=> Is_Local
,
6050 Object_Definition
=>
6051 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6053 Make_Object_Declaration
(Loc
,
6054 Defining_Identifier
=> Local_Addr
,
6055 Object_Definition
=>
6056 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
6058 Make_Object_Declaration
(Loc
,
6059 Defining_Identifier
=> Local_Stub
,
6060 Aliased_Present
=> True,
6061 Object_Definition
=>
6062 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
6064 Make_Object_Declaration
(Loc
,
6065 Defining_Identifier
=>
6067 Object_Definition
=>
6068 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
6070 Make_Attribute_Reference
(Loc
,
6071 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
6072 Attribute_Name
=> Name_Unchecked_Access
)));
6074 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
6075 -- Build_Get_Unique_RP_Call needs this information
6077 -- Get_RAS_Info (Pkg, Subp, R);
6078 -- Obtain a reference to the target subprogram
6080 Proc_Statements
:= New_List
(
6081 Make_Procedure_Call_Statement
(Loc
,
6083 New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
6084 Parameter_Associations
=> New_List
(
6085 New_Occurrence_Of
(Package_Name
, Loc
),
6086 New_Occurrence_Of
(Subp_Id
, Loc
),
6087 New_Occurrence_Of
(Subp_Ref
, Loc
))),
6089 -- Get_Local_Address (R, L, A);
6090 -- Determine whether the subprogram is local (L), and if so
6091 -- obtain the local address of its proxy (A).
6093 Make_Procedure_Call_Statement
(Loc
,
6095 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6096 Parameter_Associations
=> New_List
(
6097 New_Occurrence_Of
(Subp_Ref
, Loc
),
6098 New_Occurrence_Of
(Is_Local
, Loc
),
6099 New_Occurrence_Of
(Local_Addr
, Loc
))));
6101 -- Note: Here we assume that the Fat_Type is a record containing just
6102 -- an access to a proxy or stub object.
6104 Append_To
(Proc_Statements
,
6108 Make_Implicit_If_Statement
(N
,
6110 New_Occurrence_Of
(Is_Local
, Loc
),
6112 Then_Statements
=> New_List
(
6114 -- if A.Target = null then
6116 Make_Implicit_If_Statement
(N
,
6119 Make_Selected_Component
(Loc
,
6121 Unchecked_Convert_To
(
6122 RTE
(RE_RAS_Proxy_Type_Access
),
6123 New_Occurrence_Of
(Local_Addr
, Loc
)),
6125 Make_Identifier
(Loc
, Name_Target
)),
6128 Then_Statements
=> New_List
(
6130 -- A.Target := Entity_Of (Ref);
6132 Make_Assignment_Statement
(Loc
,
6134 Make_Selected_Component
(Loc
,
6136 Unchecked_Convert_To
(
6137 RTE
(RE_RAS_Proxy_Type_Access
),
6138 New_Occurrence_Of
(Local_Addr
, Loc
)),
6140 Make_Identifier
(Loc
, Name_Target
)),
6142 Make_Function_Call
(Loc
,
6144 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6145 Parameter_Associations
=> New_List
(
6146 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6148 -- Inc_Usage (A.Target);
6150 Make_Procedure_Call_Statement
(Loc
,
6152 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6153 Parameter_Associations
=> New_List
(
6154 Make_Selected_Component
(Loc
,
6156 Unchecked_Convert_To
(
6157 RTE
(RE_RAS_Proxy_Type_Access
),
6158 New_Occurrence_Of
(Local_Addr
, Loc
)),
6159 Selector_Name
=> Make_Identifier
(Loc
,
6163 -- if not All_Calls_Remote then
6164 -- return Fat_Type!(A);
6167 Make_Implicit_If_Statement
(N
,
6170 New_Occurrence_Of
(All_Calls_Remote
, Loc
)),
6172 Then_Statements
=> New_List
(
6173 Make_Return_Statement
(Loc
,
6174 Unchecked_Convert_To
(Fat_Type
,
6175 New_Occurrence_Of
(Local_Addr
, Loc
))))))));
6177 Append_List_To
(Proc_Statements
, New_List
(
6179 -- Stub.Target := Entity_Of (Ref);
6181 Set_Field
(Name_Target
,
6182 Make_Function_Call
(Loc
,
6184 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6185 Parameter_Associations
=> New_List
(
6186 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6188 -- Inc_Usage (Stub.Target);
6190 Make_Procedure_Call_Statement
(Loc
,
6192 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6193 Parameter_Associations
=> New_List
(
6194 Make_Selected_Component
(Loc
,
6196 Selector_Name
=> Name_Target
))),
6198 -- E.4.1(9) A remote call is asynchronous if it is a call to
6199 -- a procedure, or a call through a value of an access-to-procedure
6200 -- type, to which a pragma Asynchronous applies.
6202 -- Parameter Asynch_P is true when the procedure is asynchronous;
6203 -- Expression Asynch_T is true when the type is asynchronous.
6205 Set_Field
(Name_Asynchronous
,
6207 New_Occurrence_Of
(Asynch_P
, Loc
),
6208 New_Occurrence_Of
(Boolean_Literals
(
6209 Is_Asynchronous
(Ras_Type
)), Loc
)))));
6211 Append_List_To
(Proc_Statements
,
6212 Build_Get_Unique_RP_Call
(Loc
,
6213 Stub_Ptr
, Stub_Elements
.Stub_Type
));
6215 Append_To
(Proc_Statements
,
6216 Make_Return_Statement
(Loc
,
6218 Unchecked_Convert_To
(Fat_Type
,
6219 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
6222 Make_Function_Specification
(Loc
,
6223 Defining_Unit_Name
=> Proc
,
6224 Parameter_Specifications
=> New_List
(
6225 Make_Parameter_Specification
(Loc
,
6226 Defining_Identifier
=> Package_Name
,
6228 New_Occurrence_Of
(Standard_String
, Loc
)),
6230 Make_Parameter_Specification
(Loc
,
6231 Defining_Identifier
=> Subp_Id
,
6233 New_Occurrence_Of
(Standard_String
, Loc
)),
6235 Make_Parameter_Specification
(Loc
,
6236 Defining_Identifier
=> Asynch_P
,
6238 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6240 Make_Parameter_Specification
(Loc
,
6241 Defining_Identifier
=> All_Calls_Remote
,
6243 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
6245 Result_Definition
=>
6246 New_Occurrence_Of
(Fat_Type
, Loc
));
6248 -- Set the kind and return type of the function to prevent
6249 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6251 Set_Ekind
(Proc
, E_Function
);
6252 Set_Etype
(Proc
, Fat_Type
);
6255 Make_Subprogram_Body
(Loc
,
6256 Specification
=> Proc_Spec
,
6257 Declarations
=> Proc_Decls
,
6258 Handled_Statement_Sequence
=>
6259 Make_Handled_Sequence_Of_Statements
(Loc
,
6260 Statements
=> Proc_Statements
)));
6262 Set_TSS
(Fat_Type
, Proc
);
6263 end Add_RAS_Access_TSS
;
6265 ----------------------
6266 -- Add_RAS_From_Any --
6267 ----------------------
6269 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
) is
6270 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6272 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6273 Make_TSS_Name
(RAS_Type
, TSS_From_Any
));
6275 Func_Spec
: Node_Id
;
6277 Statements
: List_Id
;
6279 Any_Parameter
: constant Entity_Id
:=
6280 Make_Defining_Identifier
(Loc
, Name_A
);
6283 Statements
:= New_List
(
6284 Make_Return_Statement
(Loc
,
6286 Make_Aggregate
(Loc
,
6287 Component_Associations
=> New_List
(
6288 Make_Component_Association
(Loc
,
6289 Choices
=> New_List
(
6290 Make_Identifier
(Loc
, Name_Ras
)),
6292 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
6293 Underlying_RACW_Type
(RAS_Type
),
6294 New_Occurrence_Of
(Any_Parameter
, Loc
),
6298 Make_Function_Specification
(Loc
,
6299 Defining_Unit_Name
=>
6301 Parameter_Specifications
=> New_List
(
6302 Make_Parameter_Specification
(Loc
,
6303 Defining_Identifier
=>
6306 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
6307 Result_Definition
=> New_Occurrence_Of
(RAS_Type
, Loc
));
6310 Make_Subprogram_Body
(Loc
,
6311 Specification
=> Func_Spec
,
6312 Declarations
=> No_List
,
6313 Handled_Statement_Sequence
=>
6314 Make_Handled_Sequence_Of_Statements
(Loc
,
6315 Statements
=> Statements
)));
6316 Set_TSS
(RAS_Type
, Fnam
);
6317 end Add_RAS_From_Any
;
6319 --------------------
6320 -- Add_RAS_To_Any --
6321 --------------------
6323 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
) is
6324 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6326 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6327 Make_TSS_Name
(RAS_Type
, TSS_To_Any
));
6330 Statements
: List_Id
;
6332 Func_Spec
: Node_Id
;
6334 Any
: constant Entity_Id
:=
6335 Make_Defining_Identifier
(Loc
,
6336 Chars
=> New_Internal_Name
('A'));
6337 RAS_Parameter
: constant Entity_Id
:=
6338 Make_Defining_Identifier
(Loc
,
6339 Chars
=> New_Internal_Name
('R'));
6340 RACW_Parameter
: constant Node_Id
:=
6341 Make_Selected_Component
(Loc
,
6342 Prefix
=> RAS_Parameter
,
6343 Selector_Name
=> Name_Ras
);
6346 -- Object declarations
6348 Set_Etype
(RACW_Parameter
, Underlying_RACW_Type
(RAS_Type
));
6350 Make_Object_Declaration
(Loc
,
6351 Defining_Identifier
=>
6353 Object_Definition
=>
6354 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
6356 PolyORB_Support
.Helpers
.Build_To_Any_Call
6357 (RACW_Parameter
, No_List
)));
6359 Statements
:= New_List
(
6360 Make_Procedure_Call_Statement
(Loc
,
6362 New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
6363 Parameter_Associations
=> New_List
(
6364 New_Occurrence_Of
(Any
, Loc
),
6365 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
6367 Make_Return_Statement
(Loc
,
6369 New_Occurrence_Of
(Any
, Loc
)));
6372 Make_Function_Specification
(Loc
,
6373 Defining_Unit_Name
=>
6375 Parameter_Specifications
=> New_List
(
6376 Make_Parameter_Specification
(Loc
,
6377 Defining_Identifier
=>
6380 New_Occurrence_Of
(RAS_Type
, Loc
))),
6381 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
6384 Make_Subprogram_Body
(Loc
,
6385 Specification
=> Func_Spec
,
6386 Declarations
=> Decls
,
6387 Handled_Statement_Sequence
=>
6388 Make_Handled_Sequence_Of_Statements
(Loc
,
6389 Statements
=> Statements
)));
6390 Set_TSS
(RAS_Type
, Fnam
);
6393 ----------------------
6394 -- Add_RAS_TypeCode --
6395 ----------------------
6397 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
) is
6398 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6400 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6401 Make_TSS_Name
(RAS_Type
, TSS_TypeCode
));
6403 Func_Spec
: Node_Id
;
6405 Decls
: constant List_Id
:= New_List
;
6406 Name_String
, Repo_Id_String
: String_Id
;
6410 Make_Function_Specification
(Loc
,
6411 Defining_Unit_Name
=>
6413 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6415 PolyORB_Support
.Helpers
.Build_Name_And_Repository_Id
6416 (RAS_Type
, Name_Str
=> Name_String
, Repo_Id_Str
=> Repo_Id_String
);
6419 Make_Subprogram_Body
(Loc
,
6420 Specification
=> Func_Spec
,
6421 Declarations
=> Decls
,
6422 Handled_Statement_Sequence
=>
6423 Make_Handled_Sequence_Of_Statements
(Loc
,
6424 Statements
=> New_List
(
6425 Make_Return_Statement
(Loc
,
6427 Make_Function_Call
(Loc
,
6429 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
6430 Parameter_Associations
=> New_List
(
6431 New_Occurrence_Of
(RTE
(RE_TC_Object
), Loc
),
6432 Make_Aggregate
(Loc
,
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
, Name_String
))),
6440 Make_Function_Call
(Loc
,
6441 Name
=> New_Occurrence_Of
(
6442 RTE
(RE_TA_String
), Loc
),
6443 Parameter_Associations
=> New_List
(
6444 Make_String_Literal
(Loc
,
6445 Repo_Id_String
))))))))))));
6446 Set_TSS
(RAS_Type
, Fnam
);
6447 end Add_RAS_TypeCode
;
6449 -----------------------------------------
6450 -- Add_Receiving_Stubs_To_Declarations --
6451 -----------------------------------------
6453 procedure Add_Receiving_Stubs_To_Declarations
6454 (Pkg_Spec
: Node_Id
;
6457 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
6459 Pkg_RPC_Receiver
: constant Entity_Id
:=
6460 Make_Defining_Identifier
(Loc
,
6461 New_Internal_Name
('H'));
6462 Pkg_RPC_Receiver_Object
: Node_Id
;
6464 Pkg_RPC_Receiver_Body
: Node_Id
;
6465 Pkg_RPC_Receiver_Decls
: List_Id
;
6466 Pkg_RPC_Receiver_Statements
: List_Id
;
6467 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
6468 -- A Pkg_RPC_Receiver is built to decode the request
6471 -- Request object received from neutral layer
6473 Subp_Id
: Entity_Id
;
6474 -- Subprogram identifier as received from the neutral
6475 -- distribution core.
6477 Subp_Index
: Entity_Id
;
6478 -- Internal index as determined by matching either the
6479 -- method name from the request structure, or the local
6480 -- subprogram address (in case of a RAS).
6482 Is_Local
: constant Entity_Id
:=
6483 Make_Defining_Identifier
(Loc
, New_Internal_Name
('L'));
6484 Local_Address
: constant Entity_Id
:=
6485 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
6486 -- Address of a local subprogram designated by a
6487 -- reference corresponding to a RAS.
6489 Dispatch_On_Address
: constant List_Id
:= New_List
;
6490 Dispatch_On_Name
: constant List_Id
:= New_List
;
6492 Current_Declaration
: Node_Id
;
6493 Current_Stubs
: Node_Id
;
6494 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
6496 Subp_Info_Array
: constant Entity_Id
:=
6497 Make_Defining_Identifier
(Loc
,
6498 Chars
=> New_Internal_Name
('I'));
6500 Subp_Info_List
: constant List_Id
:= New_List
;
6502 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
6504 All_Calls_Remote_E
: Entity_Id
;
6506 procedure Append_Stubs_To
6507 (RPC_Receiver_Cases
: List_Id
;
6508 Declaration
: Node_Id
;
6511 Subp_Dist_Name
: Entity_Id
;
6512 Subp_Proxy_Addr
: Entity_Id
);
6513 -- Add one case to the specified RPC receiver case list associating
6514 -- Subprogram_Number with the subprogram declared by Declaration, for
6515 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6516 -- subprogram index. Subp_Dist_Name is the string used to call the
6517 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6518 -- object, used in the context of calls through remote
6519 -- access-to-subprogram types.
6521 ---------------------
6522 -- Append_Stubs_To --
6523 ---------------------
6525 procedure Append_Stubs_To
6526 (RPC_Receiver_Cases
: List_Id
;
6527 Declaration
: Node_Id
;
6530 Subp_Dist_Name
: Entity_Id
;
6531 Subp_Proxy_Addr
: Entity_Id
)
6533 Case_Stmts
: List_Id
;
6535 Case_Stmts
:= New_List
(
6536 Make_Procedure_Call_Statement
(Loc
,
6539 Defining_Entity
(Stubs
), Loc
),
6540 Parameter_Associations
=>
6541 New_List
(New_Occurrence_Of
(Request
, Loc
))));
6542 if Nkind
(Specification
(Declaration
))
6543 = N_Function_Specification
6545 Is_Asynchronous
(Defining_Entity
(Specification
(Declaration
)))
6547 Append_To
(Case_Stmts
, Make_Return_Statement
(Loc
));
6550 Append_To
(RPC_Receiver_Cases
,
6551 Make_Case_Statement_Alternative
(Loc
,
6553 New_List
(Make_Integer_Literal
(Loc
, Subp_Number
)),
6557 Append_To
(Dispatch_On_Name
,
6558 Make_Elsif_Part
(Loc
,
6560 Make_Function_Call
(Loc
,
6562 New_Occurrence_Of
(RTE
(RE_Caseless_String_Eq
), Loc
),
6563 Parameter_Associations
=> New_List
(
6564 New_Occurrence_Of
(Subp_Id
, Loc
),
6565 New_Occurrence_Of
(Subp_Dist_Name
, Loc
))),
6566 Then_Statements
=> New_List
(
6567 Make_Assignment_Statement
(Loc
,
6568 New_Occurrence_Of
(Subp_Index
, Loc
),
6569 Make_Integer_Literal
(Loc
,
6572 Append_To
(Dispatch_On_Address
,
6573 Make_Elsif_Part
(Loc
,
6577 New_Occurrence_Of
(Local_Address
, Loc
),
6579 New_Occurrence_Of
(Subp_Proxy_Addr
, Loc
)),
6580 Then_Statements
=> New_List
(
6581 Make_Assignment_Statement
(Loc
,
6582 New_Occurrence_Of
(Subp_Index
, Loc
),
6583 Make_Integer_Literal
(Loc
,
6585 end Append_Stubs_To
;
6587 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6590 -- Building receiving stubs consist in several operations:
6592 -- - a package RPC receiver must be built. This subprogram
6593 -- will get a Subprogram_Id from the incoming stream
6594 -- and will dispatch the call to the right subprogram
6596 -- - a receiving stub for any subprogram visible in the package
6597 -- spec. This stub will read all the parameters from the stream,
6598 -- and put the result as well as the exception occurrence in the
6601 -- - a dummy package with an empty spec and a body made of an
6602 -- elaboration part, whose job is to register the receiving
6603 -- part of this RCI package on the name server. This is done
6604 -- by calling System.Partition_Interface.Register_Receiving_Stub
6606 Build_RPC_Receiver_Body
(
6607 RPC_Receiver
=> Pkg_RPC_Receiver
,
6610 Subp_Index
=> Subp_Index
,
6611 Stmts
=> Pkg_RPC_Receiver_Statements
,
6612 Decl
=> Pkg_RPC_Receiver_Body
);
6613 Pkg_RPC_Receiver_Decls
:= Declarations
(Pkg_RPC_Receiver_Body
);
6615 -- Extract local address information from the target reference:
6616 -- if non-null, that means that this is a reference that denotes
6617 -- one particular operation, and hence that the operation name
6618 -- must not be taken into account for dispatching.
6620 Append_To
(Pkg_RPC_Receiver_Decls
,
6621 Make_Object_Declaration
(Loc
,
6622 Defining_Identifier
=>
6624 Object_Definition
=>
6625 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
6626 Append_To
(Pkg_RPC_Receiver_Decls
,
6627 Make_Object_Declaration
(Loc
,
6628 Defining_Identifier
=>
6630 Object_Definition
=>
6631 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6632 Append_To
(Pkg_RPC_Receiver_Statements
,
6633 Make_Procedure_Call_Statement
(Loc
,
6635 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6636 Parameter_Associations
=> New_List
(
6637 Make_Selected_Component
(Loc
,
6639 Selector_Name
=> Name_Target
),
6640 New_Occurrence_Of
(Is_Local
, Loc
),
6641 New_Occurrence_Of
(Local_Address
, Loc
))));
6643 -- Determine whether the reference that was used to make
6644 -- the call was the base RCI reference (in which case
6645 -- Local_Address is 0, and the method identifier from the
6646 -- request must be used to determine which subprogram is
6647 -- called) or a reference identifying one particular subprogram
6648 -- (in which case Local_Address is the address of that
6649 -- subprogram, and the method name from the request is
6651 -- In each case, cascaded elsifs are used to determine the
6652 -- proper subprogram index. Using hash tables might be
6655 Append_To
(Pkg_RPC_Receiver_Statements
,
6656 Make_Implicit_If_Statement
(Pkg_Spec
,
6659 Left_Opnd
=> New_Occurrence_Of
(Local_Address
, Loc
),
6660 Right_Opnd
=> New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)),
6661 Then_Statements
=> New_List
(
6662 Make_Implicit_If_Statement
(Pkg_Spec
,
6664 New_Occurrence_Of
(Standard_False
, Loc
),
6665 Then_Statements
=> New_List
(
6666 Make_Null_Statement
(Loc
)),
6668 Dispatch_On_Address
)),
6669 Else_Statements
=> New_List
(
6670 Make_Implicit_If_Statement
(Pkg_Spec
,
6672 New_Occurrence_Of
(Standard_False
, Loc
),
6673 Then_Statements
=> New_List
(
6674 Make_Null_Statement
(Loc
)),
6676 Dispatch_On_Name
))));
6678 -- For each subprogram, the receiving stub will be built and a
6679 -- case statement will be made on the Subprogram_Id to dispatch
6680 -- to the right subprogram.
6682 All_Calls_Remote_E
:= Boolean_Literals
(
6683 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
6685 Overload_Counter_Table
.Reset
;
6686 Reserve_NamingContext_Methods
;
6688 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
6689 while Present
(Current_Declaration
) loop
6690 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
6691 and then Comes_From_Source
(Current_Declaration
)
6694 Loc
: constant Source_Ptr
:=
6695 Sloc
(Current_Declaration
);
6696 -- While specifically processing Current_Declaration, use
6697 -- its Sloc as the location of all generated nodes.
6699 Subp_Def
: constant Entity_Id
:=
6701 (Specification
(Current_Declaration
));
6703 Subp_Val
: String_Id
;
6705 Subp_Dist_Name
: constant Entity_Id
:=
6706 Make_Defining_Identifier
(Loc
,
6708 Related_Id
=> Chars
(Subp_Def
),
6710 Suffix_Index
=> -1));
6712 Proxy_Object_Addr
: Entity_Id
;
6715 pragma Assert
(Current_Subprogram_Number
=
6716 Get_Subprogram_Id
(Subp_Def
));
6718 -- Build receiving stub
6721 Build_Subprogram_Receiving_Stubs
6722 (Vis_Decl
=> Current_Declaration
,
6724 Nkind
(Specification
(Current_Declaration
)) =
6725 N_Procedure_Specification
6726 and then Is_Asynchronous
(Subp_Def
));
6728 Append_To
(Decls
, Current_Stubs
);
6729 Analyze
(Current_Stubs
);
6733 Add_RAS_Proxy_And_Analyze
(Decls
,
6735 Current_Declaration
,
6736 All_Calls_Remote_E
=>
6738 Proxy_Object_Addr
=>
6741 -- Compute distribution identifier
6743 Assign_Subprogram_Identifier
(
6745 Current_Subprogram_Number
,
6749 Make_Object_Declaration
(Loc
,
6750 Defining_Identifier
=> Subp_Dist_Name
,
6751 Constant_Present
=> True,
6752 Object_Definition
=> New_Occurrence_Of
(
6753 Standard_String
, Loc
),
6755 Make_String_Literal
(Loc
, Subp_Val
)));
6756 Analyze
(Last
(Decls
));
6758 -- Add subprogram descriptor (RCI_Subp_Info) to the
6759 -- subprograms table for this receiver. The aggregate
6760 -- below must be kept consistent with the declaration
6761 -- of type RCI_Subp_Info in System.Partition_Interface.
6763 Append_To
(Subp_Info_List
,
6764 Make_Component_Association
(Loc
,
6765 Choices
=> New_List
(
6766 Make_Integer_Literal
(Loc
,
6767 Current_Subprogram_Number
)),
6769 Make_Aggregate
(Loc
,
6770 Expressions
=> New_List
(
6771 Make_Attribute_Reference
(Loc
,
6774 Subp_Dist_Name
, Loc
),
6775 Attribute_Name
=> Name_Address
),
6776 Make_Attribute_Reference
(Loc
,
6779 Subp_Dist_Name
, Loc
),
6780 Attribute_Name
=> Name_Length
),
6781 New_Occurrence_Of
(Proxy_Object_Addr
, Loc
)))));
6783 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
6784 Declaration
=> Current_Declaration
,
6785 Stubs
=> Current_Stubs
,
6786 Subp_Number
=> Current_Subprogram_Number
,
6787 Subp_Dist_Name
=> Subp_Dist_Name
,
6788 Subp_Proxy_Addr
=> Proxy_Object_Addr
);
6791 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
6794 Next
(Current_Declaration
);
6797 -- If we receive an invalid Subprogram_Id, it is best to do nothing
6798 -- rather than raising an exception since we do not want someone
6799 -- to crash a remote partition by sending invalid subprogram ids.
6800 -- This is consistent with the other parts of the case statement
6801 -- since even in presence of incorrect parameters in the stream,
6802 -- every exception will be caught and (if the subprogram is not an
6803 -- APC) put into the result stream and sent away.
6805 Append_To
(Pkg_RPC_Receiver_Cases
,
6806 Make_Case_Statement_Alternative
(Loc
,
6808 New_List
(Make_Others_Choice
(Loc
)),
6810 New_List
(Make_Null_Statement
(Loc
))));
6812 Append_To
(Pkg_RPC_Receiver_Statements
,
6813 Make_Case_Statement
(Loc
,
6815 New_Occurrence_Of
(Subp_Index
, Loc
),
6816 Alternatives
=> Pkg_RPC_Receiver_Cases
));
6819 Make_Object_Declaration
(Loc
,
6820 Defining_Identifier
=> Subp_Info_Array
,
6821 Constant_Present
=> True,
6822 Aliased_Present
=> True,
6823 Object_Definition
=>
6824 Make_Subtype_Indication
(Loc
,
6826 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
6828 Make_Index_Or_Discriminant_Constraint
(Loc
,
6831 Low_Bound
=> Make_Integer_Literal
(Loc
,
6832 First_RCI_Subprogram_Id
),
6834 Make_Integer_Literal
(Loc
,
6835 First_RCI_Subprogram_Id
6836 + List_Length
(Subp_Info_List
) - 1))))),
6838 Make_Aggregate
(Loc
,
6839 Component_Associations
=> Subp_Info_List
)));
6840 Analyze
(Last
(Decls
));
6842 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
6843 Analyze
(Last
(Decls
));
6845 Pkg_RPC_Receiver_Object
:=
6846 Make_Object_Declaration
(Loc
,
6847 Defining_Identifier
=>
6848 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
6849 Aliased_Present
=> True,
6850 Object_Definition
=>
6851 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
6852 Append_To
(Decls
, Pkg_RPC_Receiver_Object
);
6853 Analyze
(Last
(Decls
));
6855 Get_Library_Unit_Name_String
(Pkg_Spec
);
6856 Append_To
(Register_Pkg_Actuals
,
6858 Make_String_Literal
(Loc
,
6859 Strval
=> String_From_Name_Buffer
));
6861 Append_To
(Register_Pkg_Actuals
,
6863 Make_Attribute_Reference
(Loc
,
6866 (Defining_Entity
(Pkg_Spec
), Loc
),
6870 Append_To
(Register_Pkg_Actuals
,
6872 Make_Attribute_Reference
(Loc
,
6874 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
6875 Attribute_Name
=> Name_Access
));
6877 Append_To
(Register_Pkg_Actuals
,
6879 Make_Attribute_Reference
(Loc
,
6882 Defining_Identifier
(
6883 Pkg_RPC_Receiver_Object
), Loc
),
6887 Append_To
(Register_Pkg_Actuals
,
6889 Make_Attribute_Reference
(Loc
,
6891 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
6895 Append_To
(Register_Pkg_Actuals
,
6897 Make_Attribute_Reference
(Loc
,
6899 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
6903 Append_To
(Register_Pkg_Actuals
,
6904 -- Is_All_Calls_Remote
6905 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
));
6908 Make_Procedure_Call_Statement
(Loc
,
6910 New_Occurrence_Of
(RTE
(RE_Register_Pkg_Receiving_Stub
), Loc
),
6911 Parameter_Associations
=> Register_Pkg_Actuals
));
6912 Analyze
(Last
(Decls
));
6914 end Add_Receiving_Stubs_To_Declarations
;
6916 ---------------------------------
6917 -- Build_General_Calling_Stubs --
6918 ---------------------------------
6920 procedure Build_General_Calling_Stubs
6922 Statements
: List_Id
;
6923 Target_Object
: Node_Id
;
6924 Subprogram_Id
: Node_Id
;
6925 Asynchronous
: Node_Id
:= Empty
;
6926 Is_Known_Asynchronous
: Boolean := False;
6927 Is_Known_Non_Asynchronous
: Boolean := False;
6928 Is_Function
: Boolean;
6930 Stub_Type
: Entity_Id
:= Empty
;
6931 RACW_Type
: Entity_Id
:= Empty
;
6934 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
6936 Arguments
: Node_Id
;
6937 -- Name of the named values list used to transmit parameters
6938 -- to the remote package
6941 -- The request object constructed by these stubs
6944 -- Name of the result named value (in non-APC cases) which get the
6945 -- result of the remote subprogram.
6947 Result_TC
: Node_Id
;
6948 -- Typecode expression for the result of the request (void
6949 -- typecode for procedures).
6951 Exception_Return_Parameter
: Node_Id
;
6952 -- Name of the parameter which will hold the exception sent by the
6953 -- remote subprogram.
6955 Current_Parameter
: Node_Id
;
6956 -- Current parameter being handled
6958 Ordered_Parameters_List
: constant List_Id
:=
6959 Build_Ordered_Parameters_List
(Spec
);
6961 Asynchronous_P
: Node_Id
;
6962 -- A Boolean expression indicating whether this call is asynchronous
6964 Asynchronous_Statements
: List_Id
:= No_List
;
6965 Non_Asynchronous_Statements
: List_Id
:= No_List
;
6966 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
6968 Extra_Formal_Statements
: constant List_Id
:= New_List
;
6969 -- List of statements for extra formal parameters. It will appear
6970 -- after the regular statements for writing out parameters.
6972 After_Statements
: constant List_Id
:= New_List
;
6973 -- Statements to be executed after call returns (to assign
6974 -- in out or out parameter values).
6977 -- The type of the formal parameter being processed
6979 Is_Controlling_Formal
: Boolean;
6980 Is_First_Controlling_Formal
: Boolean;
6981 First_Controlling_Formal_Seen
: Boolean := False;
6982 -- Controlling formal parameters of distributed object
6983 -- primitives require special handling, and the first
6984 -- such parameter needs even more.
6987 -- ??? document general form of stub subprograms for the PolyORB case
6989 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
6992 Make_Object_Declaration
(Loc
,
6993 Defining_Identifier
=> Request
,
6994 Aliased_Present
=> False,
6995 Object_Definition
=>
6996 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
)));
6999 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
7002 Result_TC
:= PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
7003 Etype
(Result_Definition
(Spec
)), Decls
);
7005 Result_TC
:= New_Occurrence_Of
(RTE
(RE_TC_Void
), Loc
);
7009 Make_Object_Declaration
(Loc
,
7010 Defining_Identifier
=> Result
,
7011 Aliased_Present
=> False,
7012 Object_Definition
=>
7013 New_Occurrence_Of
(RTE
(RE_NamedValue
), Loc
),
7015 Make_Aggregate
(Loc
,
7016 Component_Associations
=> New_List
(
7017 Make_Component_Association
(Loc
,
7018 Choices
=> New_List
(
7019 Make_Identifier
(Loc
, Name_Name
)),
7021 New_Occurrence_Of
(RTE
(RE_Result_Name
), Loc
)),
7022 Make_Component_Association
(Loc
,
7023 Choices
=> New_List
(
7024 Make_Identifier
(Loc
, Name_Argument
)),
7026 Make_Function_Call
(Loc
,
7028 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7029 Parameter_Associations
=> New_List
(
7031 Make_Component_Association
(Loc
,
7032 Choices
=> New_List
(
7033 Make_Identifier
(Loc
, Name_Arg_Modes
)),
7035 Make_Integer_Literal
(Loc
, 0))))));
7037 if not Is_Known_Asynchronous
then
7038 Exception_Return_Parameter
:=
7039 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
7042 Make_Object_Declaration
(Loc
,
7043 Defining_Identifier
=> Exception_Return_Parameter
,
7044 Object_Definition
=>
7045 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
7048 Exception_Return_Parameter
:= Empty
;
7051 -- Initialize and fill in arguments list
7054 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
7055 Declare_Create_NVList
(Loc
, Arguments
, Decls
, Statements
);
7057 Current_Parameter
:= First
(Ordered_Parameters_List
);
7058 while Present
(Current_Parameter
) loop
7060 if Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
) then
7061 Is_Controlling_Formal
:= True;
7062 Is_First_Controlling_Formal
:=
7063 not First_Controlling_Formal_Seen
;
7064 First_Controlling_Formal_Seen
:= True;
7066 Is_Controlling_Formal
:= False;
7067 Is_First_Controlling_Formal
:= False;
7070 if Is_Controlling_Formal
then
7072 -- In the case of a controlling formal argument, we send
7078 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7081 -- The first controlling formal parameter is treated
7082 -- specially: it is used to set the target object of
7085 if not Is_First_Controlling_Formal
then
7088 Constrained
: constant Boolean :=
7089 Is_Constrained
(Etyp
)
7090 or else Is_Elementary_Type
(Etyp
);
7092 Any
: constant Entity_Id
:=
7093 Make_Defining_Identifier
(Loc
,
7094 New_Internal_Name
('A'));
7096 Actual_Parameter
: Node_Id
:=
7098 Defining_Identifier
(
7099 Current_Parameter
), Loc
);
7104 if Is_Controlling_Formal
then
7106 -- For a controlling formal parameter (other
7107 -- than the first one), use the corresponding
7108 -- RACW. If the parameter is not an anonymous
7109 -- access parameter, that involves taking
7110 -- its 'Unrestricted_Access.
7112 if Nkind
(Parameter_Type
(Current_Parameter
))
7113 = N_Access_Definition
7115 Actual_Parameter
:= OK_Convert_To
7116 (Etyp
, Actual_Parameter
);
7118 Actual_Parameter
:= OK_Convert_To
(Etyp
,
7119 Make_Attribute_Reference
(Loc
,
7123 Name_Unrestricted_Access
));
7128 if In_Present
(Current_Parameter
)
7129 or else not Out_Present
(Current_Parameter
)
7130 or else not Constrained
7131 or else Is_Controlling_Formal
7133 -- The parameter has an input value, is constrained
7134 -- at runtime by an input value, or is a controlling
7135 -- formal parameter (always passed as a reference)
7136 -- other than the first one.
7138 Expr
:= PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7139 Actual_Parameter
, Decls
);
7141 Expr
:= Make_Function_Call
(Loc
,
7143 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7144 Parameter_Associations
=> New_List
(
7145 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
7150 Make_Object_Declaration
(Loc
,
7151 Defining_Identifier
=>
7153 Aliased_Present
=> False,
7154 Object_Definition
=>
7155 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7159 Append_To
(Statements
,
7160 Add_Parameter_To_NVList
(Loc
,
7161 Parameter
=> Current_Parameter
,
7162 NVList
=> Arguments
,
7163 Constrained
=> Constrained
,
7166 if Out_Present
(Current_Parameter
)
7167 and then not Is_Controlling_Formal
7169 Append_To
(After_Statements
,
7170 Make_Assignment_Statement
(Loc
,
7173 Defining_Identifier
(Current_Parameter
), Loc
),
7175 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7176 Etype
(Parameter_Type
(Current_Parameter
)),
7177 New_Occurrence_Of
(Any
, Loc
),
7184 -- If the current parameter has a dynamic constrained status,
7185 -- then this status is transmitted as well.
7186 -- This should be done for accessibility as well ???
7188 if Nkind
(Parameter_Type
(Current_Parameter
))
7189 /= N_Access_Definition
7190 and then Need_Extra_Constrained
(Current_Parameter
)
7192 -- In this block, we do not use the extra formal that has been
7193 -- created because it does not exist at the time of expansion
7194 -- when building calling stubs for remote access to subprogram
7195 -- types. We create an extra variable of this type and push it
7196 -- in the stream after the regular parameters.
7199 Extra_Any_Parameter
: constant Entity_Id
:=
7200 Make_Defining_Identifier
7201 (Loc
, New_Internal_Name
('P'));
7205 Make_Object_Declaration
(Loc
,
7206 Defining_Identifier
=>
7207 Extra_Any_Parameter
,
7208 Aliased_Present
=> False,
7209 Object_Definition
=>
7210 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7212 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7213 Make_Attribute_Reference
(Loc
,
7216 Defining_Identifier
(Current_Parameter
), Loc
),
7217 Attribute_Name
=> Name_Constrained
),
7219 Append_To
(Extra_Formal_Statements
,
7220 Add_Parameter_To_NVList
(Loc
,
7221 Parameter
=> Extra_Any_Parameter
,
7222 NVList
=> Arguments
,
7223 Constrained
=> True,
7224 Any
=> Extra_Any_Parameter
));
7228 Next
(Current_Parameter
);
7231 -- Append the formal statements list to the statements
7233 Append_List_To
(Statements
, Extra_Formal_Statements
);
7235 Append_To
(Statements
,
7236 Make_Procedure_Call_Statement
(Loc
,
7238 New_Occurrence_Of
(RTE
(RE_Request_Create
), Loc
),
7239 Parameter_Associations
=> New_List
(
7242 New_Occurrence_Of
(Arguments
, Loc
),
7243 New_Occurrence_Of
(Result
, Loc
),
7244 New_Occurrence_Of
(RTE
(RE_Nil_Exc_List
), Loc
))));
7246 Append_To
(Parameter_Associations
(Last
(Statements
)),
7247 New_Occurrence_Of
(Request
, Loc
));
7250 not (Is_Known_Non_Asynchronous
and Is_Known_Asynchronous
));
7251 if Is_Known_Non_Asynchronous
or Is_Known_Asynchronous
then
7252 Asynchronous_P
:= New_Occurrence_Of
(
7253 Boolean_Literals
(Is_Known_Asynchronous
), Loc
);
7255 pragma Assert
(Present
(Asynchronous
));
7256 Asynchronous_P
:= New_Copy_Tree
(Asynchronous
);
7257 -- The expression node Asynchronous will be used to build
7258 -- an 'if' statement at the end of Build_General_Calling_Stubs:
7259 -- we need to make a copy here.
7262 Append_To
(Parameter_Associations
(Last
(Statements
)),
7263 Make_Indexed_Component
(Loc
,
7266 RTE
(RE_Asynchronous_P_To_Sync_Scope
), Loc
),
7267 Expressions
=> New_List
(Asynchronous_P
)));
7269 Append_To
(Statements
,
7270 Make_Procedure_Call_Statement
(Loc
,
7272 New_Occurrence_Of
(RTE
(RE_Request_Invoke
), Loc
),
7273 Parameter_Associations
=> New_List
(
7274 New_Occurrence_Of
(Request
, Loc
))));
7276 Non_Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7277 Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7279 if not Is_Known_Asynchronous
then
7281 -- Reraise an exception occurrence from the completed request.
7282 -- If the exception occurrence is empty, this is a no-op.
7284 Append_To
(Non_Asynchronous_Statements
,
7285 Make_Procedure_Call_Statement
(Loc
,
7287 New_Occurrence_Of
(RTE
(RE_Request_Raise_Occurrence
), Loc
),
7288 Parameter_Associations
=> New_List
(
7289 New_Occurrence_Of
(Request
, Loc
))));
7293 -- If this is a function call, then read the value and
7296 Append_To
(Non_Asynchronous_Statements
,
7297 Make_Tag_Check
(Loc
,
7298 Make_Return_Statement
(Loc
,
7299 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7300 Etype
(Result_Definition
(Spec
)),
7301 Make_Selected_Component
(Loc
,
7303 Selector_Name
=> Name_Argument
),
7308 Append_List_To
(Non_Asynchronous_Statements
,
7311 if Is_Known_Asynchronous
then
7312 Append_List_To
(Statements
, Asynchronous_Statements
);
7314 elsif Is_Known_Non_Asynchronous
then
7315 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
7318 pragma Assert
(Present
(Asynchronous
));
7319 Append_To
(Statements
,
7320 Make_Implicit_If_Statement
(Nod
,
7321 Condition
=> Asynchronous
,
7322 Then_Statements
=> Asynchronous_Statements
,
7323 Else_Statements
=> Non_Asynchronous_Statements
));
7325 end Build_General_Calling_Stubs
;
7327 -----------------------
7328 -- Build_Stub_Target --
7329 -----------------------
7331 function Build_Stub_Target
7334 RCI_Locator
: Entity_Id
;
7335 Controlling_Parameter
: Entity_Id
) return RPC_Target
7337 Target_Info
: RPC_Target
(PCS_Kind
=> Name_PolyORB_DSA
);
7338 Target_Reference
: constant Entity_Id
:=
7339 Make_Defining_Identifier
(Loc
,
7340 New_Internal_Name
('T'));
7342 if Present
(Controlling_Parameter
) then
7344 Make_Object_Declaration
(Loc
,
7345 Defining_Identifier
=> Target_Reference
,
7346 Object_Definition
=>
7347 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
7349 Make_Function_Call
(Loc
,
7351 New_Occurrence_Of
(RTE
(RE_Make_Ref
), Loc
),
7352 Parameter_Associations
=> New_List
(
7353 Make_Selected_Component
(Loc
,
7354 Prefix
=> Controlling_Parameter
,
7355 Selector_Name
=> Name_Target
)))));
7356 -- Controlling_Parameter has the same components
7357 -- as System.Partition_Interface.RACW_Stub_Type.
7359 Target_Info
.Object
:= New_Occurrence_Of
(Target_Reference
, Loc
);
7362 Target_Info
.Object
:=
7363 Make_Selected_Component
(Loc
,
7365 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
7367 Make_Identifier
(Loc
, Name_Get_RCI_Package_Ref
));
7370 end Build_Stub_Target
;
7372 ---------------------
7373 -- Build_Stub_Type --
7374 ---------------------
7376 procedure Build_Stub_Type
7377 (RACW_Type
: Entity_Id
;
7378 Stub_Type
: Entity_Id
;
7379 Stub_Type_Decl
: out Node_Id
;
7380 RPC_Receiver_Decl
: out Node_Id
)
7382 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
7383 pragma Warnings
(Off
);
7384 pragma Unreferenced
(RACW_Type
);
7385 pragma Warnings
(On
);
7389 Make_Full_Type_Declaration
(Loc
,
7390 Defining_Identifier
=> Stub_Type
,
7392 Make_Record_Definition
(Loc
,
7393 Tagged_Present
=> True,
7394 Limited_Present
=> True,
7396 Make_Component_List
(Loc
,
7397 Component_Items
=> New_List
(
7399 Make_Component_Declaration
(Loc
,
7400 Defining_Identifier
=>
7401 Make_Defining_Identifier
(Loc
, Name_Target
),
7402 Component_Definition
=>
7403 Make_Component_Definition
(Loc
,
7406 Subtype_Indication
=>
7407 New_Occurrence_Of
(RTE
(RE_Entity_Ptr
), Loc
))),
7409 Make_Component_Declaration
(Loc
,
7410 Defining_Identifier
=>
7411 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
7412 Component_Definition
=>
7413 Make_Component_Definition
(Loc
,
7414 Aliased_Present
=> False,
7415 Subtype_Indication
=>
7417 Standard_Boolean
, Loc
)))))));
7419 RPC_Receiver_Decl
:=
7420 Make_Object_Declaration
(Loc
,
7421 Defining_Identifier
=> Make_Defining_Identifier
(Loc
,
7422 New_Internal_Name
('R')),
7423 Aliased_Present
=> True,
7424 Object_Definition
=>
7425 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7426 end Build_Stub_Type
;
7428 -----------------------------
7429 -- Build_RPC_Receiver_Body --
7430 -----------------------------
7432 procedure Build_RPC_Receiver_Body
7433 (RPC_Receiver
: Entity_Id
;
7434 Request
: out Entity_Id
;
7435 Subp_Id
: out Entity_Id
;
7436 Subp_Index
: out Entity_Id
;
7437 Stmts
: out List_Id
;
7440 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
7442 RPC_Receiver_Spec
: Node_Id
;
7443 RPC_Receiver_Decls
: List_Id
;
7446 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
7448 RPC_Receiver_Spec
:=
7449 Build_RPC_Receiver_Specification
(
7450 RPC_Receiver
=> RPC_Receiver
,
7451 Request_Parameter
=> Request
);
7453 Subp_Id
:= Make_Defining_Identifier
(Loc
, Name_P
);
7454 Subp_Index
:= Make_Defining_Identifier
(Loc
, Name_I
);
7456 RPC_Receiver_Decls
:= New_List
(
7457 Make_Object_Renaming_Declaration
(Loc
,
7458 Defining_Identifier
=> Subp_Id
,
7459 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
7461 Make_Explicit_Dereference
(Loc
,
7463 Make_Selected_Component
(Loc
,
7465 Selector_Name
=> Name_Operation
))),
7467 Make_Object_Declaration
(Loc
,
7468 Defining_Identifier
=> Subp_Index
,
7469 Object_Definition
=>
7470 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7472 Make_Attribute_Reference
(Loc
,
7474 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7475 Attribute_Name
=> Name_Last
)));
7480 Make_Subprogram_Body
(Loc
,
7481 Specification
=> RPC_Receiver_Spec
,
7482 Declarations
=> RPC_Receiver_Decls
,
7483 Handled_Statement_Sequence
=>
7484 Make_Handled_Sequence_Of_Statements
(Loc
,
7485 Statements
=> Stmts
));
7486 end Build_RPC_Receiver_Body
;
7488 --------------------------------------
7489 -- Build_Subprogram_Receiving_Stubs --
7490 --------------------------------------
7492 function Build_Subprogram_Receiving_Stubs
7493 (Vis_Decl
: Node_Id
;
7494 Asynchronous
: Boolean;
7495 Dynamically_Asynchronous
: Boolean := False;
7496 Stub_Type
: Entity_Id
:= Empty
;
7497 RACW_Type
: Entity_Id
:= Empty
;
7498 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
7500 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
7502 Request_Parameter
: Node_Id
;
7505 Outer_Decls
: constant List_Id
:= New_List
;
7506 -- At the outermost level, an NVList and Any's are
7507 -- declared for all parameters. The Dynamic_Async
7508 -- flag also needs to be declared there to be visible
7509 -- from the exception handling code.
7511 Outer_Statements
: constant List_Id
:= New_List
;
7512 -- Statements that occur prior to the declaration of the actual
7513 -- parameter variables.
7515 Decls
: constant List_Id
:= New_List
;
7516 -- All the parameters will get declared before calling the real
7517 -- subprograms. Also the out parameters will be declared.
7518 -- At this level, parameters may be unconstrained.
7520 Statements
: constant List_Id
:= New_List
;
7522 Extra_Formal_Statements
: constant List_Id
:= New_List
;
7523 -- Statements concerning extra formal parameters
7525 After_Statements
: constant List_Id
:= New_List
;
7526 -- Statements to be executed after the subprogram call
7528 Inner_Decls
: List_Id
:= No_List
;
7529 -- In case of a function, the inner declarations are needed since
7530 -- the result may be unconstrained.
7532 Excep_Handlers
: List_Id
:= No_List
;
7534 Parameter_List
: constant List_Id
:= New_List
;
7535 -- List of parameters to be passed to the subprogram
7537 First_Controlling_Formal_Seen
: Boolean := False;
7539 Current_Parameter
: Node_Id
;
7541 Ordered_Parameters_List
: constant List_Id
:=
7542 Build_Ordered_Parameters_List
7543 (Specification
(Vis_Decl
));
7545 Arguments
: Node_Id
;
7546 -- Name of the named values list used to retrieve parameters
7548 Subp_Spec
: Node_Id
;
7549 -- Subprogram specification
7551 Called_Subprogram
: Node_Id
;
7552 -- The subprogram to call
7555 if Present
(RACW_Type
) then
7556 Called_Subprogram
:=
7557 New_Occurrence_Of
(Parent_Primitive
, Loc
);
7559 Called_Subprogram
:=
7561 Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
7564 Request_Parameter
:=
7565 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
7568 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
7569 Declare_Create_NVList
(Loc
, Arguments
, Outer_Decls
, Outer_Statements
);
7571 -- Loop through every parameter and get its value from the stream. If
7572 -- the parameter is unconstrained, then the parameter is read using
7573 -- 'Input at the point of declaration.
7575 Current_Parameter
:= First
(Ordered_Parameters_List
);
7576 while Present
(Current_Parameter
) loop
7579 Constrained
: Boolean;
7580 Any
: Entity_Id
:= Empty
;
7581 Object
: constant Entity_Id
:=
7582 Make_Defining_Identifier
(Loc
,
7583 New_Internal_Name
('P'));
7584 Expr
: Node_Id
:= Empty
;
7586 Is_Controlling_Formal
: constant Boolean
7587 := Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
);
7589 Is_First_Controlling_Formal
: Boolean := False;
7591 Set_Ekind
(Object
, E_Variable
);
7593 if Is_Controlling_Formal
then
7595 -- Controlling formals in distributed object primitive
7596 -- operations are handled specially:
7597 -- - the first controlling formal is used as the
7598 -- target of the call;
7599 -- - the remaining controlling formals are transmitted
7603 Is_First_Controlling_Formal
:=
7604 not First_Controlling_Formal_Seen
;
7605 First_Controlling_Formal_Seen
:= True;
7607 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7611 Is_Constrained
(Etyp
)
7612 or else Is_Elementary_Type
(Etyp
);
7614 if not Is_First_Controlling_Formal
then
7615 Any
:= Make_Defining_Identifier
(Loc
,
7616 New_Internal_Name
('A'));
7617 Append_To
(Outer_Decls
,
7618 Make_Object_Declaration
(Loc
,
7619 Defining_Identifier
=>
7621 Object_Definition
=>
7622 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7624 Make_Function_Call
(Loc
,
7626 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7627 Parameter_Associations
=> New_List
(
7628 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
7629 Etyp
, Outer_Decls
)))));
7631 Append_To
(Outer_Statements
,
7632 Add_Parameter_To_NVList
(Loc
,
7633 Parameter
=> Current_Parameter
,
7634 NVList
=> Arguments
,
7635 Constrained
=> Constrained
,
7639 if Is_First_Controlling_Formal
then
7641 Addr
: constant Entity_Id
:=
7642 Make_Defining_Identifier
(Loc
,
7643 New_Internal_Name
('A'));
7644 Is_Local
: constant Entity_Id
:=
7645 Make_Defining_Identifier
(Loc
,
7646 New_Internal_Name
('L'));
7649 -- Special case: obtain the first controlling
7650 -- formal from the target of the remote call,
7651 -- instead of the argument list.
7653 Append_To
(Outer_Decls
,
7654 Make_Object_Declaration
(Loc
,
7655 Defining_Identifier
=>
7657 Object_Definition
=>
7658 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
7659 Append_To
(Outer_Decls
,
7660 Make_Object_Declaration
(Loc
,
7661 Defining_Identifier
=>
7663 Object_Definition
=>
7664 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7665 Append_To
(Outer_Statements
,
7666 Make_Procedure_Call_Statement
(Loc
,
7669 RTE
(RE_Get_Local_Address
), Loc
),
7670 Parameter_Associations
=> New_List
(
7671 Make_Selected_Component
(Loc
,
7674 Request_Parameter
, Loc
),
7676 Make_Identifier
(Loc
, Name_Target
)),
7677 New_Occurrence_Of
(Is_Local
, Loc
),
7678 New_Occurrence_Of
(Addr
, Loc
))));
7680 Expr
:= Unchecked_Convert_To
(RACW_Type
,
7681 New_Occurrence_Of
(Addr
, Loc
));
7684 elsif In_Present
(Current_Parameter
)
7685 or else not Out_Present
(Current_Parameter
)
7686 or else not Constrained
7688 -- If an input parameter is contrained, then its reading is
7689 -- deferred until the beginning of the subprogram body. If
7690 -- it is unconstrained, then an expression is built for
7691 -- the object declaration and the variable is set using
7692 -- 'Input instead of 'Read.
7694 Expr
:= PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7695 Etyp
, New_Occurrence_Of
(Any
, Loc
), Decls
);
7699 Append_To
(Statements
,
7700 Make_Assignment_Statement
(Loc
,
7702 New_Occurrence_Of
(Object
, Loc
),
7708 -- Expr will be used to initialize (and constrain)
7709 -- the parameter when it is declared.
7714 -- If we do not have to output the current parameter, then
7715 -- it can well be flagged as constant. This may allow further
7716 -- optimizations done by the back end.
7719 Make_Object_Declaration
(Loc
,
7720 Defining_Identifier
=> Object
,
7721 Constant_Present
=> not Constrained
7722 and then not Out_Present
(Current_Parameter
),
7723 Object_Definition
=>
7724 New_Occurrence_Of
(Etyp
, Loc
),
7725 Expression
=> Expr
));
7726 Set_Etype
(Object
, Etyp
);
7728 -- An out parameter may be written back using a 'Write
7729 -- attribute instead of a 'Output because it has been
7730 -- constrained by the parameter given to the caller. Note that
7731 -- out controlling arguments in the case of a RACW are not put
7732 -- back in the stream because the pointer on them has not
7735 if Out_Present
(Current_Parameter
)
7736 and then not Is_Controlling_Formal
7738 Append_To
(After_Statements
,
7739 Make_Procedure_Call_Statement
(Loc
,
7741 New_Occurrence_Of
(RTE
(RE_Copy_Any_Value
), Loc
),
7742 Parameter_Associations
=> New_List
(
7743 New_Occurrence_Of
(Any
, Loc
),
7744 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7745 New_Occurrence_Of
(Object
, Loc
),
7749 -- For RACW controlling formals, the Etyp of Object is always
7750 -- an RACW, even if the parameter is not of an anonymous access
7751 -- type. In such case, we need to dereference it at call time.
7753 if Is_Controlling_Formal
then
7754 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7757 Append_To
(Parameter_List
,
7758 Make_Parameter_Association
(Loc
,
7761 Defining_Identifier
(Current_Parameter
), Loc
),
7762 Explicit_Actual_Parameter
=>
7763 Make_Explicit_Dereference
(Loc
,
7764 Unchecked_Convert_To
(RACW_Type
,
7765 OK_Convert_To
(RTE
(RE_Address
),
7766 New_Occurrence_Of
(Object
, Loc
))))));
7769 Append_To
(Parameter_List
,
7770 Make_Parameter_Association
(Loc
,
7773 Defining_Identifier
(Current_Parameter
), Loc
),
7774 Explicit_Actual_Parameter
=>
7775 Unchecked_Convert_To
(RACW_Type
,
7776 OK_Convert_To
(RTE
(RE_Address
),
7777 New_Occurrence_Of
(Object
, Loc
)))));
7781 Append_To
(Parameter_List
,
7782 Make_Parameter_Association
(Loc
,
7785 Defining_Identifier
(Current_Parameter
), Loc
),
7786 Explicit_Actual_Parameter
=>
7787 New_Occurrence_Of
(Object
, Loc
)));
7790 -- If the current parameter needs an extra formal, then read it
7791 -- from the stream and set the corresponding semantic field in
7792 -- the variable. If the kind of the parameter identifier is
7793 -- E_Void, then this is a compiler generated parameter that
7794 -- doesn't need an extra constrained status.
7796 -- The case of Extra_Accessibility should also be handled ???
7798 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7801 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
7803 Present
(Extra_Constrained
7804 (Defining_Identifier
(Current_Parameter
)))
7807 Extra_Parameter
: constant Entity_Id
:=
7809 (Defining_Identifier
7810 (Current_Parameter
));
7811 Extra_Any
: constant Entity_Id
:=
7812 Make_Defining_Identifier
7813 (Loc
, New_Internal_Name
('A'));
7814 Formal_Entity
: constant Entity_Id
:=
7815 Make_Defining_Identifier
7816 (Loc
, Chars
(Extra_Parameter
));
7818 Formal_Type
: constant Entity_Id
:=
7819 Etype
(Extra_Parameter
);
7821 Append_To
(Outer_Decls
,
7822 Make_Object_Declaration
(Loc
,
7823 Defining_Identifier
=>
7825 Object_Definition
=>
7826 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
7828 Append_To
(Outer_Statements
,
7829 Add_Parameter_To_NVList
(Loc
,
7830 Parameter
=> Extra_Parameter
,
7831 NVList
=> Arguments
,
7832 Constrained
=> True,
7836 Make_Object_Declaration
(Loc
,
7837 Defining_Identifier
=> Formal_Entity
,
7838 Object_Definition
=>
7839 New_Occurrence_Of
(Formal_Type
, Loc
)));
7841 Append_To
(Extra_Formal_Statements
,
7842 Make_Assignment_Statement
(Loc
,
7844 New_Occurrence_Of
(Extra_Parameter
, Loc
),
7846 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7847 Etype
(Extra_Parameter
),
7848 New_Occurrence_Of
(Extra_Any
, Loc
),
7850 Set_Extra_Constrained
(Object
, Formal_Entity
);
7856 Next
(Current_Parameter
);
7859 Append_To
(Outer_Statements
,
7860 Make_Procedure_Call_Statement
(Loc
,
7862 New_Occurrence_Of
(RTE
(RE_Request_Arguments
), Loc
),
7863 Parameter_Associations
=> New_List
(
7864 New_Occurrence_Of
(Request_Parameter
, Loc
),
7865 New_Occurrence_Of
(Arguments
, Loc
))));
7867 Append_List_To
(Statements
, Extra_Formal_Statements
);
7869 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
7871 -- The remote subprogram is a function. We build an inner block to
7872 -- be able to hold a potentially unconstrained result in a
7876 Etyp
: constant Entity_Id
:=
7877 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
7878 Result
: constant Node_Id
:=
7879 Make_Defining_Identifier
(Loc
,
7880 New_Internal_Name
('R'));
7882 Inner_Decls
:= New_List
(
7883 Make_Object_Declaration
(Loc
,
7884 Defining_Identifier
=> Result
,
7885 Constant_Present
=> True,
7886 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
7888 Make_Function_Call
(Loc
,
7889 Name
=> Called_Subprogram
,
7890 Parameter_Associations
=> Parameter_List
)));
7892 Set_Etype
(Result
, Etyp
);
7893 Append_To
(After_Statements
,
7894 Make_Procedure_Call_Statement
(Loc
,
7896 New_Occurrence_Of
(RTE
(RE_Set_Result
), Loc
),
7897 Parameter_Associations
=> New_List
(
7898 New_Occurrence_Of
(Request_Parameter
, Loc
),
7899 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7900 New_Occurrence_Of
(Result
, Loc
),
7902 -- A DSA function does not have out or inout arguments
7905 Append_To
(Statements
,
7906 Make_Block_Statement
(Loc
,
7907 Declarations
=> Inner_Decls
,
7908 Handled_Statement_Sequence
=>
7909 Make_Handled_Sequence_Of_Statements
(Loc
,
7910 Statements
=> After_Statements
)));
7913 -- The remote subprogram is a procedure. We do not need any inner
7914 -- block in this case. No specific processing is required here for
7915 -- the dynamically asynchronous case: the indication of whether
7916 -- call is asynchronous or not is managed by the Sync_Scope
7917 -- attibute of the request, and is handled entirely in the
7920 Append_To
(After_Statements
,
7921 Make_Procedure_Call_Statement
(Loc
,
7923 New_Occurrence_Of
(RTE
(RE_Request_Set_Out
), Loc
),
7924 Parameter_Associations
=> New_List
(
7925 New_Occurrence_Of
(Request_Parameter
, Loc
))));
7927 Append_To
(Statements
,
7928 Make_Procedure_Call_Statement
(Loc
,
7929 Name
=> Called_Subprogram
,
7930 Parameter_Associations
=> Parameter_List
));
7932 Append_List_To
(Statements
, After_Statements
);
7936 Make_Procedure_Specification
(Loc
,
7937 Defining_Unit_Name
=>
7938 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
7940 Parameter_Specifications
=> New_List
(
7941 Make_Parameter_Specification
(Loc
,
7942 Defining_Identifier
=> Request_Parameter
,
7944 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
7946 -- An exception raised during the execution of an incoming
7947 -- remote subprogram call and that needs to be sent back
7948 -- to the caller is propagated by the receiving stubs, and
7949 -- will be handled by the caller (the distribution runtime).
7951 if Asynchronous
and then not Dynamically_Asynchronous
then
7953 -- For an asynchronous procedure, add a null exception handler
7955 Excep_Handlers
:= New_List
(
7956 Make_Exception_Handler
(Loc
,
7957 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7958 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
7962 -- In the other cases, if an exception is raised, then the
7963 -- exception occurrence is propagated.
7968 Append_To
(Outer_Statements
,
7969 Make_Block_Statement
(Loc
,
7972 Handled_Statement_Sequence
=>
7973 Make_Handled_Sequence_Of_Statements
(Loc
,
7974 Statements
=> Statements
)));
7977 Make_Subprogram_Body
(Loc
,
7978 Specification
=> Subp_Spec
,
7979 Declarations
=> Outer_Decls
,
7980 Handled_Statement_Sequence
=>
7981 Make_Handled_Sequence_Of_Statements
(Loc
,
7982 Statements
=> Outer_Statements
,
7983 Exception_Handlers
=> Excep_Handlers
));
7984 end Build_Subprogram_Receiving_Stubs
;
7989 package body Helpers
is
7991 -----------------------
7992 -- Local Subprograms --
7993 -----------------------
7995 function Find_Numeric_Representation
7996 (Typ
: Entity_Id
) return Entity_Id
;
7997 -- Given a numeric type Typ, return the smallest integer or floarting
7998 -- point type from Standard, or the smallest unsigned (modular) type
7999 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8001 function Make_Stream_Procedure_Function_Name
8004 Nam
: Name_Id
) return Entity_Id
;
8005 -- Return the name to be assigned for stream subprogram Nam of Typ.
8006 -- (copied from exp_strm.adb, should be shared???)
8008 ------------------------------------------------------------
8009 -- Common subprograms for building various tree fragments --
8010 ------------------------------------------------------------
8012 function Build_Get_Aggregate_Element
8016 Idx
: Node_Id
) return Node_Id
;
8017 -- Build a call to Get_Aggregate_Element on Any
8018 -- for typecode TC, returning the Idx'th element.
8021 Subprogram
: Entity_Id
;
8022 -- Reference location for constructed nodes
8025 -- For 'Range and Etype
8028 -- For the construction of the innermost element expression
8030 with procedure Add_Process_Element
8033 Counter
: Entity_Id
;
8036 procedure Append_Array_Traversal
8039 Counter
: Entity_Id
:= Empty
;
8041 -- Build nested loop statements that iterate over the elements of an
8042 -- array Arry. The statement(s) built by Add_Process_Element are
8043 -- executed for each element; Indices is the list of indices to be
8044 -- used in the construction of the indexed component that denotes the
8045 -- current element. Subprogram is the entity for the subprogram for
8046 -- which this iterator is generated. The generated statements are
8047 -- appended to Stmts.
8051 -- The record entity being dealt with
8053 with procedure Add_Process_Element
8055 Container
: Node_Or_Entity_Id
;
8056 Counter
: in out Int
;
8059 -- Rec is the instance of the record type, or Empty.
8060 -- Field is either the N_Defining_Identifier for a component,
8061 -- or an N_Variant_Part.
8063 procedure Append_Record_Traversal
8066 Container
: Node_Or_Entity_Id
;
8067 Counter
: in out Int
);
8068 -- Process component list Clist. Individual fields are passed
8069 -- to Field_Processing. Each variant part is also processed.
8070 -- Container is the outer Any (for From_Any/To_Any),
8071 -- the outer typecode (for TC) to which the operation applies.
8073 -----------------------------
8074 -- Append_Record_Traversal --
8075 -----------------------------
8077 procedure Append_Record_Traversal
8080 Container
: Node_Or_Entity_Id
;
8081 Counter
: in out Int
)
8083 CI
: constant List_Id
:= Component_Items
(Clist
);
8084 VP
: constant Node_Id
:= Variant_Part
(Clist
);
8086 Item
: Node_Id
:= First
(CI
);
8090 while Present
(Item
) loop
8091 Def
:= Defining_Identifier
(Item
);
8092 if not Is_Internal_Name
(Chars
(Def
)) then
8094 (Stmts
, Container
, Counter
, Rec
, Def
);
8099 if Present
(VP
) then
8100 Add_Process_Element
(Stmts
, Container
, Counter
, Rec
, VP
);
8102 end Append_Record_Traversal
;
8104 -------------------------
8105 -- Build_From_Any_Call --
8106 -------------------------
8108 function Build_From_Any_Call
8111 Decls
: List_Id
) return Node_Id
8113 Loc
: constant Source_Ptr
:= Sloc
(N
);
8115 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
8117 Fnam
: Entity_Id
:= Empty
;
8118 Lib_RE
: RE_Id
:= RE_Null
;
8122 -- First simple case where the From_Any function is present
8123 -- in the type's TSS.
8125 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_From_Any
);
8127 if Sloc
(U_Type
) <= Standard_Location
then
8128 U_Type
:= Base_Type
(U_Type
);
8131 -- Check first for Boolean and Character. These are enumeration
8132 -- types, but we treat them specially, since they may require
8133 -- special handling in the transfer protocol. However, this
8134 -- special handling only applies if they have standard
8135 -- representation, otherwise they are treated like any other
8136 -- enumeration type.
8138 if Present
(Fnam
) then
8141 elsif U_Type
= Standard_Boolean
then
8144 elsif U_Type
= Standard_Character
then
8147 elsif U_Type
= Standard_Wide_Character
then
8150 elsif U_Type
= Standard_Wide_Wide_Character
then
8151 Lib_RE
:= RE_FA_WWC
;
8153 -- Floating point types
8155 elsif U_Type
= Standard_Short_Float
then
8158 elsif U_Type
= Standard_Float
then
8161 elsif U_Type
= Standard_Long_Float
then
8164 elsif U_Type
= Standard_Long_Long_Float
then
8165 Lib_RE
:= RE_FA_LLF
;
8169 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
8170 Lib_RE
:= RE_FA_SSI
;
8172 elsif U_Type
= Etype
(Standard_Short_Integer
) then
8175 elsif U_Type
= Etype
(Standard_Integer
) then
8178 elsif U_Type
= Etype
(Standard_Long_Integer
) then
8181 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
8182 Lib_RE
:= RE_FA_LLI
;
8184 -- Unsigned integer types
8186 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
8187 Lib_RE
:= RE_FA_SSU
;
8189 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
8192 elsif U_Type
= RTE
(RE_Unsigned
) then
8195 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
8198 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
8199 Lib_RE
:= RE_FA_LLU
;
8201 elsif U_Type
= Standard_String
then
8202 Lib_RE
:= RE_FA_String
;
8204 -- Other (non-primitive) types
8210 Build_From_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
8211 Append_To
(Decls
, Decl
);
8215 -- Call the function
8217 if Lib_RE
/= RE_Null
then
8218 pragma Assert
(No
(Fnam
));
8219 Fnam
:= RTE
(Lib_RE
);
8223 Make_Function_Call
(Loc
,
8224 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
8225 Parameter_Associations
=> New_List
(N
));
8226 end Build_From_Any_Call
;
8228 -----------------------------
8229 -- Build_From_Any_Function --
8230 -----------------------------
8232 procedure Build_From_Any_Function
8236 Fnam
: out Entity_Id
)
8239 Decls
: constant List_Id
:= New_List
;
8240 Stms
: constant List_Id
:= New_List
;
8241 Any_Parameter
: constant Entity_Id
8242 := Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
8244 Fnam
:= Make_Stream_Procedure_Function_Name
(Loc
,
8245 Typ
, Name_uFrom_Any
);
8248 Make_Function_Specification
(Loc
,
8249 Defining_Unit_Name
=> Fnam
,
8250 Parameter_Specifications
=> New_List
(
8251 Make_Parameter_Specification
(Loc
,
8252 Defining_Identifier
=>
8255 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
8256 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
8258 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8261 (not (Is_Remote_Access_To_Class_Wide_Type
(Typ
)));
8263 if Is_Derived_Type
(Typ
)
8264 and then not Is_Tagged_Type
(Typ
)
8267 Make_Return_Statement
(Loc
,
8271 Build_From_Any_Call
(
8273 New_Occurrence_Of
(Any_Parameter
, Loc
),
8276 elsif Is_Record_Type
(Typ
)
8277 and then not Is_Derived_Type
(Typ
)
8278 and then not Is_Tagged_Type
(Typ
)
8280 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
8282 Make_Return_Statement
(Loc
,
8286 Build_From_Any_Call
(
8288 New_Occurrence_Of
(Any_Parameter
, Loc
),
8292 Disc
: Entity_Id
:= Empty
;
8293 Discriminant_Associations
: List_Id
;
8294 Rdef
: constant Node_Id
:=
8295 Type_Definition
(Declaration_Node
(Typ
));
8296 Component_Counter
: Int
:= 0;
8298 -- The returned object
8300 Res
: constant Entity_Id
:=
8301 Make_Defining_Identifier
(Loc
,
8302 New_Internal_Name
('R'));
8304 Res_Definition
: Node_Id
:= New_Occurrence_Of
(Typ
, Loc
);
8306 procedure FA_Rec_Add_Process_Element
8309 Counter
: in out Int
;
8313 procedure FA_Append_Record_Traversal
is
8314 new Append_Record_Traversal
8316 Add_Process_Element
=> FA_Rec_Add_Process_Element
);
8318 --------------------------------
8319 -- FA_Rec_Add_Process_Element --
8320 --------------------------------
8322 procedure FA_Rec_Add_Process_Element
8325 Counter
: in out Int
;
8330 if Nkind
(Field
) = N_Defining_Identifier
then
8332 -- A regular component
8335 Make_Assignment_Statement
(Loc
,
8336 Name
=> Make_Selected_Component
(Loc
,
8338 New_Occurrence_Of
(Rec
, Loc
),
8340 New_Occurrence_Of
(Field
, Loc
)),
8342 Build_From_Any_Call
(Etype
(Field
),
8343 Build_Get_Aggregate_Element
(Loc
,
8345 Tc
=> Build_TypeCode_Call
(Loc
,
8346 Etype
(Field
), Decls
),
8347 Idx
=> Make_Integer_Literal
(Loc
,
8356 Struct_Counter
: Int
:= 0;
8358 Block_Decls
: constant List_Id
:= New_List
;
8359 Block_Stmts
: constant List_Id
:= New_List
;
8362 Alt_List
: constant List_Id
:= New_List
;
8363 Choice_List
: List_Id
;
8365 Struct_Any
: constant Entity_Id
:=
8366 Make_Defining_Identifier
(Loc
,
8367 New_Internal_Name
('S'));
8371 Make_Object_Declaration
(Loc
,
8372 Defining_Identifier
=>
8376 Object_Definition
=>
8377 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8379 Make_Function_Call
(Loc
,
8380 Name
=> New_Occurrence_Of
(
8381 RTE
(RE_Extract_Union_Value
), Loc
),
8382 Parameter_Associations
=> New_List
(
8383 Build_Get_Aggregate_Element
(Loc
,
8385 Tc
=> Make_Function_Call
(Loc
,
8386 Name
=> New_Occurrence_Of
(
8387 RTE
(RE_Any_Member_Type
), Loc
),
8388 Parameter_Associations
=>
8390 New_Occurrence_Of
(Any
, Loc
),
8391 Make_Integer_Literal
(Loc
,
8393 Idx
=> Make_Integer_Literal
(Loc
,
8397 Make_Block_Statement
(Loc
,
8400 Handled_Statement_Sequence
=>
8401 Make_Handled_Sequence_Of_Statements
(Loc
,
8402 Statements
=> Block_Stmts
)));
8404 Append_To
(Block_Stmts
,
8405 Make_Case_Statement
(Loc
,
8407 Make_Selected_Component
(Loc
,
8410 Chars
(Name
(Field
))),
8414 Variant
:= First_Non_Pragma
(Variants
(Field
));
8416 while Present
(Variant
) loop
8417 Choice_List
:= New_Copy_List_Tree
8418 (Discrete_Choices
(Variant
));
8420 VP_Stmts
:= New_List
;
8421 FA_Append_Record_Traversal
(
8423 Clist
=> Component_List
(Variant
),
8424 Container
=> Struct_Any
,
8425 Counter
=> Struct_Counter
);
8427 Append_To
(Alt_List
,
8428 Make_Case_Statement_Alternative
(Loc
,
8429 Discrete_Choices
=> Choice_List
,
8432 Next_Non_Pragma
(Variant
);
8436 Counter
:= Counter
+ 1;
8437 end FA_Rec_Add_Process_Element
;
8440 -- First all discriminants
8442 if Has_Discriminants
(Typ
) then
8443 Disc
:= First_Discriminant
(Typ
);
8444 Discriminant_Associations
:= New_List
;
8446 while Present
(Disc
) loop
8448 Disc_Var_Name
: constant Entity_Id
:=
8449 Make_Defining_Identifier
(Loc
, Chars
(Disc
));
8450 Disc_Type
: constant Entity_Id
:=
8454 Make_Object_Declaration
(Loc
,
8455 Defining_Identifier
=>
8457 Constant_Present
=> True,
8458 Object_Definition
=>
8459 New_Occurrence_Of
(Disc_Type
, Loc
),
8461 Build_From_Any_Call
(Etype
(Disc
),
8462 Build_Get_Aggregate_Element
(Loc
,
8463 Any
=> Any_Parameter
,
8464 Tc
=> Build_TypeCode_Call
8465 (Loc
, Etype
(Disc
), Decls
),
8466 Idx
=> Make_Integer_Literal
8467 (Loc
, Component_Counter
)),
8469 Component_Counter
:= Component_Counter
+ 1;
8471 Append_To
(Discriminant_Associations
,
8472 Make_Discriminant_Association
(Loc
,
8473 Selector_Names
=> New_List
(
8474 New_Occurrence_Of
(Disc
, Loc
)),
8476 New_Occurrence_Of
(Disc_Var_Name
, Loc
)));
8478 Next_Discriminant
(Disc
);
8481 Res_Definition
:= Make_Subtype_Indication
(Loc
,
8482 Subtype_Mark
=> Res_Definition
,
8484 Make_Index_Or_Discriminant_Constraint
(Loc
,
8485 Discriminant_Associations
));
8488 -- Now we have all the discriminants in variables, we can
8489 -- declared a constrained object. Note that we are not
8490 -- initializing (non-discriminant) components directly in
8491 -- the object declarations, because which fields to
8492 -- initialize depends (at run time) on the discriminant
8496 Make_Object_Declaration
(Loc
,
8497 Defining_Identifier
=>
8499 Object_Definition
=>
8502 -- ... then all components
8504 FA_Append_Record_Traversal
(Stms
,
8505 Clist
=> Component_List
(Rdef
),
8506 Container
=> Any_Parameter
,
8507 Counter
=> Component_Counter
);
8510 Make_Return_Statement
(Loc
,
8511 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
8515 elsif Is_Array_Type
(Typ
) then
8517 Constrained
: constant Boolean := Is_Constrained
(Typ
);
8519 procedure FA_Ary_Add_Process_Element
8522 Counter
: Entity_Id
;
8524 -- Assign the current element (as identified by Counter) of
8525 -- Any to the variable denoted by name Datum, and advance
8526 -- Counter by 1. If Datum is not an Any, a call to From_Any
8527 -- for its type is inserted.
8529 --------------------------------
8530 -- FA_Ary_Add_Process_Element --
8531 --------------------------------
8533 procedure FA_Ary_Add_Process_Element
8536 Counter
: Entity_Id
;
8539 Assignment
: constant Node_Id
:=
8540 Make_Assignment_Statement
(Loc
,
8542 Expression
=> Empty
);
8544 Element_Any
: constant Node_Id
:=
8545 Build_Get_Aggregate_Element
(Loc
,
8547 Tc
=> Build_TypeCode_Call
(Loc
,
8548 Etype
(Datum
), Decls
),
8549 Idx
=> New_Occurrence_Of
(Counter
, Loc
));
8552 -- Note: here we *prepend* statements to Stmts, so
8553 -- we must do it in reverse order.
8556 Make_Assignment_Statement
(Loc
,
8558 New_Occurrence_Of
(Counter
, Loc
),
8562 New_Occurrence_Of
(Counter
, Loc
),
8564 Make_Integer_Literal
(Loc
, 1))));
8566 if Nkind
(Datum
) /= N_Attribute_Reference
then
8568 -- We ignore the value of the length of each
8569 -- dimension, since the target array has already
8570 -- been constrained anyway.
8572 if Etype
(Datum
) /= RTE
(RE_Any
) then
8573 Set_Expression
(Assignment
,
8574 Build_From_Any_Call
(
8575 Component_Type
(Typ
),
8579 Set_Expression
(Assignment
, Element_Any
);
8581 Prepend_To
(Stmts
, Assignment
);
8583 end FA_Ary_Add_Process_Element
;
8585 Counter
: constant Entity_Id
:=
8586 Make_Defining_Identifier
(Loc
, Name_J
);
8588 Initial_Counter_Value
: Int
:= 0;
8590 Component_TC
: constant Entity_Id
:=
8591 Make_Defining_Identifier
(Loc
, Name_T
);
8593 Res
: constant Entity_Id
:=
8594 Make_Defining_Identifier
(Loc
, Name_R
);
8596 procedure Append_From_Any_Array_Iterator
is
8597 new Append_Array_Traversal
(
8600 Indices
=> New_List
,
8601 Add_Process_Element
=> FA_Ary_Add_Process_Element
);
8603 Res_Subtype_Indication
: Node_Id
:=
8604 New_Occurrence_Of
(Typ
, Loc
);
8607 if not Constrained
then
8609 Ndim
: constant Int
:= Number_Dimensions
(Typ
);
8612 Indx
: Node_Id
:= First_Index
(Typ
);
8615 Ranges
: constant List_Id
:= New_List
;
8618 for J
in 1 .. Ndim
loop
8619 Lnam
:= New_External_Name
('L', J
);
8620 Hnam
:= New_External_Name
('H', J
);
8621 Indt
:= Etype
(Indx
);
8624 Make_Object_Declaration
(Loc
,
8625 Defining_Identifier
=>
8626 Make_Defining_Identifier
(Loc
, Lnam
),
8629 Object_Definition
=>
8630 New_Occurrence_Of
(Indt
, Loc
),
8632 Build_From_Any_Call
(
8634 Build_Get_Aggregate_Element
(Loc
,
8635 Any
=> Any_Parameter
,
8636 Tc
=> Build_TypeCode_Call
(Loc
,
8638 Idx
=> Make_Integer_Literal
(Loc
, J
- 1)),
8642 Make_Object_Declaration
(Loc
,
8643 Defining_Identifier
=>
8644 Make_Defining_Identifier
(Loc
, Hnam
),
8647 Object_Definition
=>
8648 New_Occurrence_Of
(Indt
, Loc
),
8649 Expression
=> Make_Attribute_Reference
(Loc
,
8651 New_Occurrence_Of
(Indt
, Loc
),
8652 Attribute_Name
=> Name_Val
,
8653 Expressions
=> New_List
(
8654 Make_Op_Subtract
(Loc
,
8658 Make_Attribute_Reference
(Loc
,
8660 New_Occurrence_Of
(Indt
, Loc
),
8663 Expressions
=> New_List
(
8664 Make_Identifier
(Loc
, Lnam
))),
8666 Make_Function_Call
(Loc
,
8667 Name
=> New_Occurrence_Of
(RTE
(
8668 RE_Get_Nested_Sequence_Length
),
8670 Parameter_Associations
=>
8673 Any_Parameter
, Loc
),
8674 Make_Integer_Literal
(Loc
,
8677 Make_Integer_Literal
(Loc
, 1))))));
8681 Low_Bound
=> Make_Identifier
(Loc
, Lnam
),
8682 High_Bound
=> Make_Identifier
(Loc
, Hnam
)));
8687 -- Now we have all the necessary bound information:
8688 -- apply the set of range constraints to the
8689 -- (unconstrained) nominal subtype of Res.
8691 Initial_Counter_Value
:= Ndim
;
8692 Res_Subtype_Indication
:= Make_Subtype_Indication
(Loc
,
8694 Res_Subtype_Indication
,
8696 Make_Index_Or_Discriminant_Constraint
(Loc
,
8697 Constraints
=> Ranges
));
8702 Make_Object_Declaration
(Loc
,
8703 Defining_Identifier
=> Res
,
8704 Object_Definition
=> Res_Subtype_Indication
));
8705 Set_Etype
(Res
, Typ
);
8708 Make_Object_Declaration
(Loc
,
8709 Defining_Identifier
=> Counter
,
8710 Object_Definition
=>
8711 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
8713 Make_Integer_Literal
(Loc
, Initial_Counter_Value
)));
8716 Make_Object_Declaration
(Loc
,
8717 Defining_Identifier
=> Component_TC
,
8718 Constant_Present
=> True,
8719 Object_Definition
=>
8720 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
),
8722 Build_TypeCode_Call
(Loc
,
8723 Component_Type
(Typ
), Decls
)));
8725 Append_From_Any_Array_Iterator
(Stms
,
8726 Any_Parameter
, Counter
);
8729 Make_Return_Statement
(Loc
,
8730 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
8733 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
8735 Make_Return_Statement
(Loc
,
8737 Unchecked_Convert_To
(
8739 Build_From_Any_Call
(
8740 Find_Numeric_Representation
(Typ
),
8741 New_Occurrence_Of
(Any_Parameter
, Loc
),
8745 -- Default: type is represented as an opaque sequence of bytes
8748 Strm
: constant Entity_Id
:=
8749 Make_Defining_Identifier
(Loc
,
8750 Chars
=> New_Internal_Name
('S'));
8751 Res
: constant Entity_Id
:=
8752 Make_Defining_Identifier
(Loc
,
8753 Chars
=> New_Internal_Name
('R'));
8756 -- Strm : Buffer_Stream_Type;
8759 Make_Object_Declaration
(Loc
,
8760 Defining_Identifier
=>
8764 Object_Definition
=>
8765 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
8767 -- Any_To_BS (Strm, A);
8770 Make_Procedure_Call_Statement
(Loc
,
8772 New_Occurrence_Of
(RTE
(RE_Any_To_BS
), Loc
),
8773 Parameter_Associations
=> New_List
(
8774 New_Occurrence_Of
(Any_Parameter
, Loc
),
8775 New_Occurrence_Of
(Strm
, Loc
))));
8778 -- Res : constant T := T'Input (Strm);
8780 -- Release_Buffer (Strm);
8784 Append_To
(Stms
, Make_Block_Statement
(Loc
,
8785 Declarations
=> New_List
(
8786 Make_Object_Declaration
(Loc
,
8787 Defining_Identifier
=> Res
,
8788 Constant_Present
=> True,
8789 Object_Definition
=>
8790 New_Occurrence_Of
(Typ
, Loc
),
8792 Make_Attribute_Reference
(Loc
,
8793 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
8794 Attribute_Name
=> Name_Input
,
8795 Expressions
=> New_List
(
8796 Make_Attribute_Reference
(Loc
,
8797 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
8798 Attribute_Name
=> Name_Access
))))),
8800 Handled_Statement_Sequence
=>
8801 Make_Handled_Sequence_Of_Statements
(Loc
,
8802 Statements
=> New_List
(
8803 Make_Procedure_Call_Statement
(Loc
,
8805 New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
8806 Parameter_Associations
=>
8808 New_Occurrence_Of
(Strm
, Loc
))),
8809 Make_Return_Statement
(Loc
,
8810 Expression
=> New_Occurrence_Of
(Res
, Loc
))))));
8816 Make_Subprogram_Body
(Loc
,
8817 Specification
=> Spec
,
8818 Declarations
=> Decls
,
8819 Handled_Statement_Sequence
=>
8820 Make_Handled_Sequence_Of_Statements
(Loc
,
8821 Statements
=> Stms
));
8822 end Build_From_Any_Function
;
8824 ---------------------------------
8825 -- Build_Get_Aggregate_Element --
8826 ---------------------------------
8828 function Build_Get_Aggregate_Element
8832 Idx
: Node_Id
) return Node_Id
8835 return Make_Function_Call
(Loc
,
8838 RTE
(RE_Get_Aggregate_Element
), Loc
),
8839 Parameter_Associations
=> New_List
(
8840 New_Occurrence_Of
(Any
, Loc
),
8843 end Build_Get_Aggregate_Element
;
8845 -------------------------
8846 -- Build_Reposiroty_Id --
8847 -------------------------
8849 procedure Build_Name_And_Repository_Id
8851 Name_Str
: out String_Id
;
8852 Repo_Id_Str
: out String_Id
)
8856 Store_String_Chars
("DSA:");
8857 Get_Library_Unit_Name_String
(Scope
(E
));
8858 Store_String_Chars
(
8859 Name_Buffer
(Name_Buffer
'First
8860 .. Name_Buffer
'First + Name_Len
- 1));
8861 Store_String_Char
('.');
8862 Get_Name_String
(Chars
(E
));
8863 Store_String_Chars
(
8864 Name_Buffer
(Name_Buffer
'First
8865 .. Name_Buffer
'First + Name_Len
- 1));
8866 Store_String_Chars
(":1.0");
8867 Repo_Id_Str
:= End_String
;
8868 Name_Str
:= String_From_Name_Buffer
;
8869 end Build_Name_And_Repository_Id
;
8871 -----------------------
8872 -- Build_To_Any_Call --
8873 -----------------------
8875 function Build_To_Any_Call
8877 Decls
: List_Id
) return Node_Id
8879 Loc
: constant Source_Ptr
:= Sloc
(N
);
8881 Typ
: Entity_Id
:= Etype
(N
);
8884 Fnam
: Entity_Id
:= Empty
;
8885 Lib_RE
: RE_Id
:= RE_Null
;
8888 -- If N is a selected component, then maybe its Etype
8889 -- has not been set yet: try to use the Etype of the
8890 -- selector_name in that case.
8892 if No
(Typ
) and then Nkind
(N
) = N_Selected_Component
then
8893 Typ
:= Etype
(Selector_Name
(N
));
8895 pragma Assert
(Present
(Typ
));
8897 -- The full view, if Typ is private; the completion,
8898 -- if Typ is incomplete.
8900 U_Type
:= Underlying_Type
(Typ
);
8902 -- First simple case where the To_Any function is present
8903 -- in the type's TSS.
8905 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_To_Any
);
8907 -- Check first for Boolean and Character. These are enumeration
8908 -- types, but we treat them specially, since they may require
8909 -- special handling in the transfer protocol. However, this
8910 -- special handling only applies if they have standard
8911 -- representation, otherwise they are treated like any other
8912 -- enumeration type.
8914 if Sloc
(U_Type
) <= Standard_Location
then
8915 U_Type
:= Base_Type
(U_Type
);
8918 if Present
(Fnam
) then
8921 elsif U_Type
= Standard_Boolean
then
8924 elsif U_Type
= Standard_Character
then
8927 elsif U_Type
= Standard_Wide_Character
then
8930 elsif U_Type
= Standard_Wide_Wide_Character
then
8931 Lib_RE
:= RE_TA_WWC
;
8933 -- Floating point types
8935 elsif U_Type
= Standard_Short_Float
then
8938 elsif U_Type
= Standard_Float
then
8941 elsif U_Type
= Standard_Long_Float
then
8944 elsif U_Type
= Standard_Long_Long_Float
then
8945 Lib_RE
:= RE_TA_LLF
;
8949 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
8950 Lib_RE
:= RE_TA_SSI
;
8952 elsif U_Type
= Etype
(Standard_Short_Integer
) then
8955 elsif U_Type
= Etype
(Standard_Integer
) then
8958 elsif U_Type
= Etype
(Standard_Long_Integer
) then
8961 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
8962 Lib_RE
:= RE_TA_LLI
;
8964 -- Unsigned integer types
8966 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
8967 Lib_RE
:= RE_TA_SSU
;
8969 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
8972 elsif U_Type
= RTE
(RE_Unsigned
) then
8975 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
8978 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
8979 Lib_RE
:= RE_TA_LLU
;
8981 elsif U_Type
= Standard_String
then
8982 Lib_RE
:= RE_TA_String
;
8984 elsif U_Type
= Underlying_Type
(RTE
(RE_TypeCode
)) then
8987 -- Other (non-primitive) types
8993 Build_To_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
8994 Append_To
(Decls
, Decl
);
8998 -- Call the function
9000 if Lib_RE
/= RE_Null
then
9001 pragma Assert
(No
(Fnam
));
9002 Fnam
:= RTE
(Lib_RE
);
9006 Make_Function_Call
(Loc
,
9007 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
9008 Parameter_Associations
=> New_List
(N
));
9009 end Build_To_Any_Call
;
9011 ---------------------------
9012 -- Build_To_Any_Function --
9013 ---------------------------
9015 procedure Build_To_Any_Function
9019 Fnam
: out Entity_Id
)
9022 Decls
: constant List_Id
:= New_List
;
9023 Stms
: constant List_Id
:= New_List
;
9025 Expr_Parameter
: constant Entity_Id
:=
9026 Make_Defining_Identifier
(Loc
, Name_E
);
9028 Any
: constant Entity_Id
:=
9029 Make_Defining_Identifier
(Loc
, Name_A
);
9032 Result_TC
: Node_Id
:= Build_TypeCode_Call
(Loc
, Typ
, Decls
);
9035 Fnam
:= Make_Stream_Procedure_Function_Name
(Loc
,
9039 Make_Function_Specification
(Loc
,
9040 Defining_Unit_Name
=> Fnam
,
9041 Parameter_Specifications
=> New_List
(
9042 Make_Parameter_Specification
(Loc
,
9043 Defining_Identifier
=>
9046 New_Occurrence_Of
(Typ
, Loc
))),
9047 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9048 Set_Etype
(Expr_Parameter
, Typ
);
9051 Make_Object_Declaration
(Loc
,
9052 Defining_Identifier
=>
9054 Object_Definition
=>
9055 New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9057 if Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9059 Rt_Type
: constant Entity_Id
9061 Expr
: constant Node_Id
9064 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9066 Set_Expression
(Any_Decl
, Build_To_Any_Call
(Expr
, Decls
));
9069 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9070 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
9072 Rt_Type
: constant Entity_Id
9074 Expr
: constant Node_Id
9077 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9080 Set_Expression
(Any_Decl
,
9081 Build_To_Any_Call
(Expr
, Decls
));
9086 Disc
: Entity_Id
:= Empty
;
9087 Rdef
: constant Node_Id
:=
9088 Type_Definition
(Declaration_Node
(Typ
));
9090 Elements
: constant List_Id
:= New_List
;
9092 procedure TA_Rec_Add_Process_Element
9094 Container
: Node_Or_Entity_Id
;
9095 Counter
: in out Int
;
9099 procedure TA_Append_Record_Traversal
is
9100 new Append_Record_Traversal
9101 (Rec
=> Expr_Parameter
,
9102 Add_Process_Element
=> TA_Rec_Add_Process_Element
);
9104 --------------------------------
9105 -- TA_Rec_Add_Process_Element --
9106 --------------------------------
9108 procedure TA_Rec_Add_Process_Element
9110 Container
: Node_Or_Entity_Id
;
9111 Counter
: in out Int
;
9115 Field_Ref
: Node_Id
;
9118 if Nkind
(Field
) = N_Defining_Identifier
then
9120 -- A regular component
9122 Field_Ref
:= Make_Selected_Component
(Loc
,
9123 Prefix
=> New_Occurrence_Of
(Rec
, Loc
),
9124 Selector_Name
=> New_Occurrence_Of
(Field
, Loc
));
9125 Set_Etype
(Field_Ref
, Etype
(Field
));
9128 Make_Procedure_Call_Statement
(Loc
,
9131 RTE
(RE_Add_Aggregate_Element
), Loc
),
9132 Parameter_Associations
=> New_List
(
9133 New_Occurrence_Of
(Any
, Loc
),
9134 Build_To_Any_Call
(Field_Ref
, Decls
))));
9141 Struct_Counter
: Int
:= 0;
9143 Block_Decls
: constant List_Id
:= New_List
;
9144 Block_Stmts
: constant List_Id
:= New_List
;
9147 Alt_List
: constant List_Id
:= New_List
;
9148 Choice_List
: List_Id
;
9150 Union_Any
: constant Entity_Id
:=
9151 Make_Defining_Identifier
(Loc
,
9152 New_Internal_Name
('U'));
9154 Struct_Any
: constant Entity_Id
:=
9155 Make_Defining_Identifier
(Loc
,
9156 New_Internal_Name
('S'));
9158 function Make_Discriminant_Reference
9160 -- Build a selected component for the
9161 -- discriminant of this variant part.
9163 ---------------------------------
9164 -- Make_Discriminant_Reference --
9165 ---------------------------------
9167 function Make_Discriminant_Reference
9170 Nod
: constant Node_Id
:=
9171 Make_Selected_Component
(Loc
,
9174 Chars
(Name
(Field
)));
9176 Set_Etype
(Nod
, Name
(Field
));
9178 end Make_Discriminant_Reference
;
9182 Make_Block_Statement
(Loc
,
9185 Handled_Statement_Sequence
=>
9186 Make_Handled_Sequence_Of_Statements
(Loc
,
9187 Statements
=> Block_Stmts
)));
9189 Append_To
(Block_Decls
,
9190 Make_Object_Declaration
(Loc
,
9191 Defining_Identifier
=> Union_Any
,
9192 Object_Definition
=>
9193 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9195 Make_Function_Call
(Loc
,
9196 Name
=> New_Occurrence_Of
(
9197 RTE
(RE_Create_Any
), Loc
),
9198 Parameter_Associations
=> New_List
(
9199 Make_Function_Call
(Loc
,
9202 RTE
(RE_Any_Member_Type
), Loc
),
9203 Parameter_Associations
=> New_List
(
9204 New_Occurrence_Of
(Container
, Loc
),
9205 Make_Integer_Literal
(Loc
,
9208 Append_To
(Block_Decls
,
9209 Make_Object_Declaration
(Loc
,
9210 Defining_Identifier
=> Struct_Any
,
9211 Object_Definition
=>
9212 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9214 Make_Function_Call
(Loc
,
9215 Name
=> New_Occurrence_Of
(
9216 RTE
(RE_Create_Any
), Loc
),
9217 Parameter_Associations
=> New_List
(
9218 Make_Function_Call
(Loc
,
9221 RTE
(RE_Any_Member_Type
), Loc
),
9222 Parameter_Associations
=> New_List
(
9223 New_Occurrence_Of
(Union_Any
, Loc
),
9224 Make_Integer_Literal
(Loc
,
9227 Append_To
(Block_Stmts
,
9228 Make_Case_Statement
(Loc
,
9230 Make_Discriminant_Reference
,
9234 Variant
:= First_Non_Pragma
(Variants
(Field
));
9235 while Present
(Variant
) loop
9236 Choice_List
:= New_Copy_List_Tree
9237 (Discrete_Choices
(Variant
));
9239 VP_Stmts
:= New_List
;
9240 TA_Append_Record_Traversal
(
9242 Clist
=> Component_List
(Variant
),
9243 Container
=> Struct_Any
,
9244 Counter
=> Struct_Counter
);
9246 -- Append discriminant value and inner struct
9247 -- to union aggregate.
9249 Append_To
(VP_Stmts
,
9250 Make_Procedure_Call_Statement
(Loc
,
9253 RTE
(RE_Add_Aggregate_Element
), Loc
),
9254 Parameter_Associations
=> New_List
(
9255 New_Occurrence_Of
(Union_Any
, Loc
),
9257 Make_Discriminant_Reference
,
9260 Append_To
(VP_Stmts
,
9261 Make_Procedure_Call_Statement
(Loc
,
9264 RTE
(RE_Add_Aggregate_Element
), Loc
),
9265 Parameter_Associations
=> New_List
(
9266 New_Occurrence_Of
(Union_Any
, Loc
),
9267 New_Occurrence_Of
(Struct_Any
, Loc
))));
9269 -- Append union to outer aggregate
9271 Append_To
(VP_Stmts
,
9272 Make_Procedure_Call_Statement
(Loc
,
9275 RTE
(RE_Add_Aggregate_Element
), Loc
),
9276 Parameter_Associations
=> New_List
(
9277 New_Occurrence_Of
(Container
, Loc
),
9278 Make_Function_Call
(Loc
,
9279 Name
=> New_Occurrence_Of
(
9280 RTE
(RE_Any_Aggregate_Build
), Loc
),
9281 Parameter_Associations
=> New_List
(
9283 Union_Any
, Loc
))))));
9285 Append_To
(Alt_List
,
9286 Make_Case_Statement_Alternative
(Loc
,
9287 Discrete_Choices
=> Choice_List
,
9290 Next_Non_Pragma
(Variant
);
9294 end TA_Rec_Add_Process_Element
;
9297 -- First all discriminants
9299 if Has_Discriminants
(Typ
) then
9300 Disc
:= First_Discriminant
(Typ
);
9302 while Present
(Disc
) loop
9303 Append_To
(Elements
,
9304 Make_Component_Association
(Loc
,
9305 Choices
=> New_List
(
9306 Make_Integer_Literal
(Loc
, Counter
)),
9309 Make_Selected_Component
(Loc
,
9310 Prefix
=> Expr_Parameter
,
9311 Selector_Name
=> Chars
(Disc
)),
9313 Counter
:= Counter
+ 1;
9314 Next_Discriminant
(Disc
);
9318 -- Make elements an empty array
9321 Dummy_Any
: constant Entity_Id
:=
9322 Make_Defining_Identifier
(Loc
,
9323 Chars
=> New_Internal_Name
('A'));
9327 Make_Object_Declaration
(Loc
,
9328 Defining_Identifier
=> Dummy_Any
,
9329 Object_Definition
=>
9330 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
9332 Append_To
(Elements
,
9333 Make_Component_Association
(Loc
,
9334 Choices
=> New_List
(
9337 Make_Integer_Literal
(Loc
, 1),
9339 Make_Integer_Literal
(Loc
, 0))),
9341 New_Occurrence_Of
(Dummy_Any
, Loc
)));
9345 Set_Expression
(Any_Decl
,
9346 Make_Function_Call
(Loc
,
9347 Name
=> New_Occurrence_Of
(
9348 RTE
(RE_Any_Aggregate_Build
), Loc
),
9349 Parameter_Associations
=> New_List
(
9351 Make_Aggregate
(Loc
,
9352 Component_Associations
=> Elements
))));
9355 -- ... then all components
9357 TA_Append_Record_Traversal
(Stms
,
9358 Clist
=> Component_List
(Rdef
),
9360 Counter
=> Counter
);
9364 elsif Is_Array_Type
(Typ
) then
9366 Constrained
: constant Boolean := Is_Constrained
(Typ
);
9368 procedure TA_Ary_Add_Process_Element
9371 Counter
: Entity_Id
;
9374 --------------------------------
9375 -- TA_Ary_Add_Process_Element --
9376 --------------------------------
9378 procedure TA_Ary_Add_Process_Element
9381 Counter
: Entity_Id
;
9384 pragma Warnings
(Off
);
9385 pragma Unreferenced
(Counter
);
9386 pragma Warnings
(On
);
9388 Element_Any
: Node_Id
;
9391 if Etype
(Datum
) = RTE
(RE_Any
) then
9392 Element_Any
:= Datum
;
9394 Element_Any
:= Build_To_Any_Call
(Datum
, Decls
);
9398 Make_Procedure_Call_Statement
(Loc
,
9399 Name
=> New_Occurrence_Of
(
9400 RTE
(RE_Add_Aggregate_Element
), Loc
),
9401 Parameter_Associations
=> New_List
(
9402 New_Occurrence_Of
(Any
, Loc
),
9404 end TA_Ary_Add_Process_Element
;
9406 procedure Append_To_Any_Array_Iterator
is
9407 new Append_Array_Traversal
(
9409 Arry
=> Expr_Parameter
,
9410 Indices
=> New_List
,
9411 Add_Process_Element
=> TA_Ary_Add_Process_Element
);
9416 Set_Expression
(Any_Decl
,
9417 Make_Function_Call
(Loc
,
9419 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
9420 Parameter_Associations
=> New_List
(Result_TC
)));
9423 if not Constrained
then
9424 Index
:= First_Index
(Typ
);
9425 for J
in 1 .. Number_Dimensions
(Typ
) loop
9427 Make_Procedure_Call_Statement
(Loc
,
9430 RTE
(RE_Add_Aggregate_Element
), Loc
),
9431 Parameter_Associations
=> New_List
(
9432 New_Occurrence_Of
(Any
, Loc
),
9434 OK_Convert_To
(Etype
(Index
),
9435 Make_Attribute_Reference
(Loc
,
9437 New_Occurrence_Of
(Expr_Parameter
, Loc
),
9438 Attribute_Name
=> Name_First
,
9439 Expressions
=> New_List
(
9440 Make_Integer_Literal
(Loc
, J
)))),
9446 Append_To_Any_Array_Iterator
(Stms
, Any
);
9449 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9450 Set_Expression
(Any_Decl
,
9453 Find_Numeric_Representation
(Typ
),
9454 New_Occurrence_Of
(Expr_Parameter
, Loc
)),
9458 -- Default: type is represented as an opaque sequence of bytes
9461 Strm
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
9462 New_Internal_Name
('S'));
9465 -- Strm : aliased Buffer_Stream_Type;
9468 Make_Object_Declaration
(Loc
,
9469 Defining_Identifier
=>
9473 Object_Definition
=>
9474 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
9476 -- Allocate_Buffer (Strm);
9479 Make_Procedure_Call_Statement
(Loc
,
9481 New_Occurrence_Of
(RTE
(RE_Allocate_Buffer
), Loc
),
9482 Parameter_Associations
=> New_List
(
9483 New_Occurrence_Of
(Strm
, Loc
))));
9485 -- T'Output (Strm'Access, E);
9488 Make_Attribute_Reference
(Loc
,
9489 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
9490 Attribute_Name
=> Name_Output
,
9491 Expressions
=> New_List
(
9492 Make_Attribute_Reference
(Loc
,
9493 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
9494 Attribute_Name
=> Name_Access
),
9495 New_Occurrence_Of
(Expr_Parameter
, Loc
))));
9497 -- BS_To_Any (Strm, A);
9500 Make_Procedure_Call_Statement
(Loc
,
9502 New_Occurrence_Of
(RTE
(RE_BS_To_Any
), Loc
),
9503 Parameter_Associations
=> New_List
(
9504 New_Occurrence_Of
(Strm
, Loc
),
9505 New_Occurrence_Of
(Any
, Loc
))));
9507 -- Release_Buffer (Strm);
9510 Make_Procedure_Call_Statement
(Loc
,
9512 New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
9513 Parameter_Associations
=> New_List
(
9514 New_Occurrence_Of
(Strm
, Loc
))));
9518 Append_To
(Decls
, Any_Decl
);
9520 if Present
(Result_TC
) then
9522 Make_Procedure_Call_Statement
(Loc
,
9523 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
9524 Parameter_Associations
=> New_List
(
9525 New_Occurrence_Of
(Any
, Loc
),
9530 Make_Return_Statement
(Loc
,
9531 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
9534 Make_Subprogram_Body
(Loc
,
9535 Specification
=> Spec
,
9536 Declarations
=> Decls
,
9537 Handled_Statement_Sequence
=>
9538 Make_Handled_Sequence_Of_Statements
(Loc
,
9539 Statements
=> Stms
));
9540 end Build_To_Any_Function
;
9542 -------------------------
9543 -- Build_TypeCode_Call --
9544 -------------------------
9546 function Build_TypeCode_Call
9549 Decls
: List_Id
) return Node_Id
9551 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
9552 -- The full view, if Typ is private; the completion,
9553 -- if Typ is incomplete.
9555 Fnam
: Entity_Id
:= Empty
;
9556 Lib_RE
: RE_Id
:= RE_Null
;
9561 -- Special case System.PolyORB.Interface.Any: its primitives have
9562 -- not been set yet, so can't call Find_Inherited_TSS.
9564 if Typ
= RTE
(RE_Any
) then
9565 Fnam
:= RTE
(RE_TC_Any
);
9568 -- First simple case where the TypeCode is present
9569 -- in the type's TSS.
9571 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_TypeCode
);
9575 if Sloc
(U_Type
) <= Standard_Location
then
9577 -- Do not try to build alias typecodes for subtypes from
9580 U_Type
:= Base_Type
(U_Type
);
9583 if U_Type
= Standard_Boolean
then
9586 elsif U_Type
= Standard_Character
then
9589 elsif U_Type
= Standard_Wide_Character
then
9592 elsif U_Type
= Standard_Wide_Wide_Character
then
9593 Lib_RE
:= RE_TC_WWC
;
9595 -- Floating point types
9597 elsif U_Type
= Standard_Short_Float
then
9600 elsif U_Type
= Standard_Float
then
9603 elsif U_Type
= Standard_Long_Float
then
9606 elsif U_Type
= Standard_Long_Long_Float
then
9607 Lib_RE
:= RE_TC_LLF
;
9609 -- Integer types (walk back to the base type)
9611 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
9612 Lib_RE
:= RE_TC_SSI
;
9614 elsif U_Type
= Etype
(Standard_Short_Integer
) then
9617 elsif U_Type
= Etype
(Standard_Integer
) then
9620 elsif U_Type
= Etype
(Standard_Long_Integer
) then
9623 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
9624 Lib_RE
:= RE_TC_LLI
;
9626 -- Unsigned integer types
9628 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
9629 Lib_RE
:= RE_TC_SSU
;
9631 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
9634 elsif U_Type
= RTE
(RE_Unsigned
) then
9637 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
9640 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
9641 Lib_RE
:= RE_TC_LLU
;
9643 elsif U_Type
= Standard_String
then
9644 Lib_RE
:= RE_TC_String
;
9646 -- Other (non-primitive) types
9652 Build_TypeCode_Function
(Loc
, U_Type
, Decl
, Fnam
);
9653 Append_To
(Decls
, Decl
);
9657 if Lib_RE
/= RE_Null
then
9658 Fnam
:= RTE
(Lib_RE
);
9662 -- Call the function
9665 Make_Function_Call
(Loc
, Name
=> New_Occurrence_Of
(Fnam
, Loc
));
9667 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
9669 Set_Etype
(Expr
, RTE
(RE_TypeCode
));
9672 end Build_TypeCode_Call
;
9674 -----------------------------
9675 -- Build_TypeCode_Function --
9676 -----------------------------
9678 procedure Build_TypeCode_Function
9682 Fnam
: out Entity_Id
)
9685 Decls
: constant List_Id
:= New_List
;
9686 Stms
: constant List_Id
:= New_List
;
9688 TCNam
: constant Entity_Id
:=
9689 Make_Stream_Procedure_Function_Name
(Loc
,
9690 Typ
, Name_uTypeCode
);
9692 Parameters
: List_Id
;
9694 procedure Add_String_Parameter
9696 Parameter_List
: List_Id
);
9697 -- Add a literal for S to Parameters
9699 procedure Add_TypeCode_Parameter
9701 Parameter_List
: List_Id
);
9702 -- Add the typecode for Typ to Parameters
9704 procedure Add_Long_Parameter
9705 (Expr_Node
: Node_Id
;
9706 Parameter_List
: List_Id
);
9707 -- Add a signed long integer expression to Parameters
9709 procedure Initialize_Parameter_List
9710 (Name_String
: String_Id
;
9711 Repo_Id_String
: String_Id
;
9712 Parameter_List
: out List_Id
);
9713 -- Return a list that contains the first two parameters
9714 -- for a parameterized typecode: name and repository id.
9716 function Make_Constructed_TypeCode
9718 Parameters
: List_Id
) return Node_Id
;
9719 -- Call TC_Build with the given kind and parameters
9721 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
);
9722 -- Make a return statement that calls TC_Build with the given
9723 -- typecode kind, and the constructed parameters list.
9725 procedure Return_Alias_TypeCode
(Base_TypeCode
: Node_Id
);
9726 -- Return a typecode that is a TC_Alias for the given typecode
9728 --------------------------
9729 -- Add_String_Parameter --
9730 --------------------------
9732 procedure Add_String_Parameter
9734 Parameter_List
: List_Id
)
9737 Append_To
(Parameter_List
,
9738 Make_Function_Call
(Loc
,
9740 New_Occurrence_Of
(RTE
(RE_TA_String
), Loc
),
9741 Parameter_Associations
=> New_List
(
9742 Make_String_Literal
(Loc
, S
))));
9743 end Add_String_Parameter
;
9745 ----------------------------
9746 -- Add_TypeCode_Parameter --
9747 ----------------------------
9749 procedure Add_TypeCode_Parameter
9751 Parameter_List
: List_Id
)
9754 Append_To
(Parameter_List
,
9755 Make_Function_Call
(Loc
,
9757 New_Occurrence_Of
(RTE
(RE_TA_TC
), Loc
),
9758 Parameter_Associations
=> New_List
(
9760 end Add_TypeCode_Parameter
;
9762 ------------------------
9763 -- Add_Long_Parameter --
9764 ------------------------
9766 procedure Add_Long_Parameter
9767 (Expr_Node
: Node_Id
;
9768 Parameter_List
: List_Id
)
9771 Append_To
(Parameter_List
,
9772 Make_Function_Call
(Loc
,
9774 New_Occurrence_Of
(RTE
(RE_TA_LI
), Loc
),
9775 Parameter_Associations
=> New_List
(Expr_Node
)));
9776 end Add_Long_Parameter
;
9778 -------------------------------
9779 -- Initialize_Parameter_List --
9780 -------------------------------
9782 procedure Initialize_Parameter_List
9783 (Name_String
: String_Id
;
9784 Repo_Id_String
: String_Id
;
9785 Parameter_List
: out List_Id
)
9788 Parameter_List
:= New_List
;
9789 Add_String_Parameter
(Name_String
, Parameter_List
);
9790 Add_String_Parameter
(Repo_Id_String
, Parameter_List
);
9791 end Initialize_Parameter_List
;
9793 ---------------------------
9794 -- Return_Alias_TypeCode --
9795 ---------------------------
9797 procedure Return_Alias_TypeCode
9798 (Base_TypeCode
: Node_Id
)
9801 Add_TypeCode_Parameter
(Base_TypeCode
, Parameters
);
9802 Return_Constructed_TypeCode
(RTE
(RE_TC_Alias
));
9803 end Return_Alias_TypeCode
;
9805 -------------------------------
9806 -- Make_Constructed_TypeCode --
9807 -------------------------------
9809 function Make_Constructed_TypeCode
9811 Parameters
: List_Id
) return Node_Id
9813 Constructed_TC
: constant Node_Id
:=
9814 Make_Function_Call
(Loc
,
9816 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
9817 Parameter_Associations
=> New_List
(
9818 New_Occurrence_Of
(Kind
, Loc
),
9819 Make_Aggregate
(Loc
,
9820 Expressions
=> Parameters
)));
9822 Set_Etype
(Constructed_TC
, RTE
(RE_TypeCode
));
9823 return Constructed_TC
;
9824 end Make_Constructed_TypeCode
;
9826 ---------------------------------
9827 -- Return_Constructed_TypeCode --
9828 ---------------------------------
9830 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
) is
9833 Make_Return_Statement
(Loc
,
9835 Make_Constructed_TypeCode
(Kind
, Parameters
)));
9836 end Return_Constructed_TypeCode
;
9842 procedure TC_Rec_Add_Process_Element
9845 Counter
: in out Int
;
9849 procedure TC_Append_Record_Traversal
is
9850 new Append_Record_Traversal
(
9852 Add_Process_Element
=> TC_Rec_Add_Process_Element
);
9854 --------------------------------
9855 -- TC_Rec_Add_Process_Element --
9856 --------------------------------
9858 procedure TC_Rec_Add_Process_Element
9861 Counter
: in out Int
;
9865 pragma Warnings
(Off
);
9866 pragma Unreferenced
(Any
, Counter
, Rec
);
9867 pragma Warnings
(On
);
9870 if Nkind
(Field
) = N_Defining_Identifier
then
9872 -- A regular component
9874 Add_TypeCode_Parameter
(
9875 Build_TypeCode_Call
(Loc
, Etype
(Field
), Decls
), Params
);
9876 Get_Name_String
(Chars
(Field
));
9877 Add_String_Parameter
(String_From_Name_Buffer
, Params
);
9884 Discriminant_Type
: constant Entity_Id
:=
9885 Etype
(Name
(Field
));
9887 Is_Enum
: constant Boolean :=
9888 Is_Enumeration_Type
(Discriminant_Type
);
9890 Union_TC_Params
: List_Id
;
9892 U_Name
: constant Name_Id
:=
9893 New_External_Name
(Chars
(Typ
), 'U', -1);
9895 Name_Str
: String_Id
;
9896 Struct_TC_Params
: List_Id
;
9900 Default
: constant Node_Id
:=
9901 Make_Integer_Literal
(Loc
, -1);
9903 Dummy_Counter
: Int
:= 0;
9905 procedure Add_Params_For_Variant_Components
;
9906 -- Add a struct TypeCode and a corresponding member name
9907 -- to the union parameter list.
9909 -- Ordering of declarations is a complete mess in this
9910 -- area, it is supposed to be types/varibles, then
9911 -- subprogram specs, then subprogram bodies ???
9913 ---------------------------------------
9914 -- Add_Params_For_Variant_Components --
9915 ---------------------------------------
9917 procedure Add_Params_For_Variant_Components
9919 S_Name
: constant Name_Id
:=
9920 New_External_Name
(U_Name
, 'S', -1);
9923 Get_Name_String
(S_Name
);
9924 Name_Str
:= String_From_Name_Buffer
;
9925 Initialize_Parameter_List
9926 (Name_Str
, Name_Str
, Struct_TC_Params
);
9928 -- Build struct parameters
9930 TC_Append_Record_Traversal
(Struct_TC_Params
,
9931 Component_List
(Variant
),
9935 Add_TypeCode_Parameter
9936 (Make_Constructed_TypeCode
9937 (RTE
(RE_TC_Struct
), Struct_TC_Params
),
9940 Add_String_Parameter
(Name_Str
, Union_TC_Params
);
9941 end Add_Params_For_Variant_Components
;
9944 Get_Name_String
(U_Name
);
9945 Name_Str
:= String_From_Name_Buffer
;
9947 Initialize_Parameter_List
9948 (Name_Str
, Name_Str
, Union_TC_Params
);
9950 Add_String_Parameter
(Name_Str
, Params
);
9952 -- Add union in enclosing parameter list
9954 Add_TypeCode_Parameter
9955 (Make_Constructed_TypeCode
9956 (RTE
(RE_TC_Union
), Union_TC_Params
),
9959 -- Build union parameters
9961 Add_TypeCode_Parameter
9962 (Discriminant_Type
, Union_TC_Params
);
9963 Add_Long_Parameter
(Default
, Union_TC_Params
);
9965 Variant
:= First_Non_Pragma
(Variants
(Field
));
9966 while Present
(Variant
) loop
9967 Choice
:= First
(Discrete_Choices
(Variant
));
9968 while Present
(Choice
) loop
9969 case Nkind
(Choice
) is
9972 L
: constant Uint
:=
9973 Expr_Value
(Low_Bound
(Choice
));
9974 H
: constant Uint
:=
9975 Expr_Value
(High_Bound
(Choice
));
9977 -- 3.8.1(8) guarantees that the bounds of
9978 -- this range are static.
9985 Expr
:= New_Occurrence_Of
(
9986 Get_Enum_Lit_From_Pos
(
9987 Discriminant_Type
, J
, Loc
), Loc
);
9990 Make_Integer_Literal
(Loc
, J
);
9992 Append_To
(Union_TC_Params
,
9993 Build_To_Any_Call
(Expr
, Decls
));
9994 Add_Params_For_Variant_Components
;
9999 when N_Others_Choice
=>
10000 Add_Long_Parameter
(
10001 Make_Integer_Literal
(Loc
, 0),
10003 Add_Params_For_Variant_Components
;
10006 Append_To
(Union_TC_Params
,
10007 Build_To_Any_Call
(Choice
, Decls
));
10008 Add_Params_For_Variant_Components
;
10014 Next_Non_Pragma
(Variant
);
10019 end TC_Rec_Add_Process_Element
;
10021 Type_Name_Str
: String_Id
;
10022 Type_Repo_Id_Str
: String_Id
;
10025 pragma Assert
(not Is_Itype
(Typ
));
10029 Make_Function_Specification
(Loc
,
10030 Defining_Unit_Name
=> Fnam
,
10031 Parameter_Specifications
=> Empty_List
,
10032 Result_Definition
=>
10033 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
10035 Build_Name_And_Repository_Id
(Typ
,
10036 Name_Str
=> Type_Name_Str
, Repo_Id_Str
=> Type_Repo_Id_Str
);
10037 Initialize_Parameter_List
10038 (Type_Name_Str
, Type_Repo_Id_Str
, Parameters
);
10040 if Is_Derived_Type
(Typ
)
10041 and then not Is_Tagged_Type
(Typ
)
10044 Parent_Type
: Entity_Id
:= Etype
(Typ
);
10047 if Is_Itype
(Parent_Type
) then
10049 -- Skip implicit base type
10051 Parent_Type
:= Etype
(Parent_Type
);
10054 Return_Alias_TypeCode
(
10055 Build_TypeCode_Call
(Loc
, Parent_Type
, Decls
));
10058 elsif Is_Integer_Type
(Typ
)
10059 or else Is_Unsigned_Type
(Typ
)
10061 Return_Alias_TypeCode
(
10062 Build_TypeCode_Call
(Loc
,
10063 Find_Numeric_Representation
(Typ
), Decls
));
10065 elsif Is_Record_Type
(Typ
)
10066 and then not Is_Tagged_Type
(Typ
)
10068 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
10069 Return_Alias_TypeCode
(
10070 Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10073 Disc
: Entity_Id
:= Empty
;
10074 Rdef
: constant Node_Id
:=
10075 Type_Definition
(Declaration_Node
(Typ
));
10076 Dummy_Counter
: Int
:= 0;
10078 -- First all discriminants
10080 if Has_Discriminants
(Typ
) then
10081 Disc
:= First_Discriminant
(Typ
);
10083 while Present
(Disc
) loop
10084 Add_TypeCode_Parameter
(
10085 Build_TypeCode_Call
(Loc
, Etype
(Disc
), Decls
),
10087 Get_Name_String
(Chars
(Disc
));
10088 Add_String_Parameter
(
10089 String_From_Name_Buffer
,
10091 Next_Discriminant
(Disc
);
10094 -- ... then all components
10096 TC_Append_Record_Traversal
10097 (Parameters
, Component_List
(Rdef
),
10098 Empty
, Dummy_Counter
);
10099 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10103 elsif Is_Array_Type
(Typ
) then
10105 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10106 Inner_TypeCode
: Node_Id
;
10107 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10108 Indx
: Node_Id
:= First_Index
(Typ
);
10111 Inner_TypeCode
:= Build_TypeCode_Call
(Loc
,
10112 Component_Type
(Typ
),
10115 for J
in 1 .. Ndim
loop
10116 if Constrained
then
10117 Inner_TypeCode
:= Make_Constructed_TypeCode
10118 (RTE
(RE_TC_Array
), New_List
(
10119 Build_To_Any_Call
(
10120 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10121 Make_Attribute_Reference
(Loc
,
10123 New_Occurrence_Of
(Typ
, Loc
),
10126 Expressions
=> New_List
(
10127 Make_Integer_Literal
(Loc
,
10130 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10133 -- Unconstrained case: add low bound for each
10136 Add_TypeCode_Parameter
10137 (Build_TypeCode_Call
(Loc
, Etype
(Indx
), Decls
),
10139 Get_Name_String
(New_External_Name
('L', J
));
10140 Add_String_Parameter
(
10141 String_From_Name_Buffer
,
10145 Inner_TypeCode
:= Make_Constructed_TypeCode
10146 (RTE
(RE_TC_Sequence
), New_List
(
10147 Build_To_Any_Call
(
10148 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10149 Make_Integer_Literal
(Loc
, 0)),
10151 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10155 if Constrained
then
10156 Return_Alias_TypeCode
(Inner_TypeCode
);
10158 Add_TypeCode_Parameter
(Inner_TypeCode
, Parameters
);
10160 Store_String_Char
('V');
10161 Add_String_Parameter
(End_String
, Parameters
);
10162 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10167 -- Default: type is represented as an opaque sequence of bytes
10169 Return_Alias_TypeCode
10170 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10174 Make_Subprogram_Body
(Loc
,
10175 Specification
=> Spec
,
10176 Declarations
=> Decls
,
10177 Handled_Statement_Sequence
=>
10178 Make_Handled_Sequence_Of_Statements
(Loc
,
10179 Statements
=> Stms
));
10180 end Build_TypeCode_Function
;
10182 ---------------------------------
10183 -- Find_Numeric_Representation --
10184 ---------------------------------
10186 function Find_Numeric_Representation
10187 (Typ
: Entity_Id
) return Entity_Id
10189 FST
: constant Entity_Id
:= First_Subtype
(Typ
);
10190 P_Size
: constant Uint
:= Esize
(FST
);
10193 if Is_Unsigned_Type
(Typ
) then
10194 if P_Size
<= Standard_Short_Short_Integer_Size
then
10195 return RTE
(RE_Short_Short_Unsigned
);
10197 elsif P_Size
<= Standard_Short_Integer_Size
then
10198 return RTE
(RE_Short_Unsigned
);
10200 elsif P_Size
<= Standard_Integer_Size
then
10201 return RTE
(RE_Unsigned
);
10203 elsif P_Size
<= Standard_Long_Integer_Size
then
10204 return RTE
(RE_Long_Unsigned
);
10207 return RTE
(RE_Long_Long_Unsigned
);
10210 elsif Is_Integer_Type
(Typ
) then
10211 if P_Size
<= Standard_Short_Short_Integer_Size
then
10212 return Standard_Short_Short_Integer
;
10214 elsif P_Size
<= Standard_Short_Integer_Size
then
10215 return Standard_Short_Integer
;
10217 elsif P_Size
<= Standard_Integer_Size
then
10218 return Standard_Integer
;
10220 elsif P_Size
<= Standard_Long_Integer_Size
then
10221 return Standard_Long_Integer
;
10224 return Standard_Long_Long_Integer
;
10227 elsif Is_Floating_Point_Type
(Typ
) then
10228 if P_Size
<= Standard_Short_Float_Size
then
10229 return Standard_Short_Float
;
10231 elsif P_Size
<= Standard_Float_Size
then
10232 return Standard_Float
;
10234 elsif P_Size
<= Standard_Long_Float_Size
then
10235 return Standard_Long_Float
;
10238 return Standard_Long_Long_Float
;
10242 raise Program_Error
;
10245 -- TBD: fixed point types???
10246 -- TBverified numeric types with a biased representation???
10248 end Find_Numeric_Representation
;
10250 ---------------------------
10251 -- Append_Array_Traversal --
10252 ---------------------------
10254 procedure Append_Array_Traversal
10257 Counter
: Entity_Id
:= Empty
;
10260 Loc
: constant Source_Ptr
:= Sloc
(Subprogram
);
10261 Typ
: constant Entity_Id
:= Etype
(Arry
);
10262 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10263 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10265 Inner_Any
, Inner_Counter
: Entity_Id
;
10267 Loop_Stm
: Node_Id
;
10268 Inner_Stmts
: constant List_Id
:= New_List
;
10271 if Depth
> Ndim
then
10273 -- Processing for one element of an array
10276 Element_Expr
: constant Node_Id
:=
10277 Make_Indexed_Component
(Loc
,
10278 New_Occurrence_Of
(Arry
, Loc
),
10282 Set_Etype
(Element_Expr
, Component_Type
(Typ
));
10283 Add_Process_Element
(Stmts
,
10285 Counter
=> Counter
,
10286 Datum
=> Element_Expr
);
10292 Append_To
(Indices
,
10293 Make_Identifier
(Loc
, New_External_Name
('L', Depth
)));
10295 if not Constrained
or else Depth
> 1 then
10296 Inner_Any
:= Make_Defining_Identifier
(Loc
,
10297 New_External_Name
('A', Depth
));
10298 Set_Etype
(Inner_Any
, RTE
(RE_Any
));
10300 Inner_Any
:= Empty
;
10303 if Present
(Counter
) then
10304 Inner_Counter
:= Make_Defining_Identifier
(Loc
,
10305 New_External_Name
('J', Depth
));
10307 Inner_Counter
:= Empty
;
10311 Loop_Any
: Node_Id
:= Inner_Any
;
10314 -- For the first dimension of a constrained array, we add
10315 -- elements directly in the corresponding Any; there is no
10316 -- intervening inner Any.
10318 if No
(Loop_Any
) then
10322 Append_Array_Traversal
(Inner_Stmts
,
10324 Counter
=> Inner_Counter
,
10325 Depth
=> Depth
+ 1);
10329 Make_Implicit_Loop_Statement
(Subprogram
,
10330 Iteration_Scheme
=>
10331 Make_Iteration_Scheme
(Loc
,
10332 Loop_Parameter_Specification
=>
10333 Make_Loop_Parameter_Specification
(Loc
,
10334 Defining_Identifier
=>
10335 Make_Defining_Identifier
(Loc
,
10336 Chars
=> New_External_Name
('L', Depth
)),
10338 Discrete_Subtype_Definition
=>
10339 Make_Attribute_Reference
(Loc
,
10340 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10341 Attribute_Name
=> Name_Range
,
10343 Expressions
=> New_List
(
10344 Make_Integer_Literal
(Loc
, Depth
))))),
10345 Statements
=> Inner_Stmts
);
10348 Decls
: constant List_Id
:= New_List
;
10349 Dimen_Stmts
: constant List_Id
:= New_List
;
10350 Length_Node
: Node_Id
;
10352 Inner_Any_TypeCode
: constant Entity_Id
:=
10353 Make_Defining_Identifier
(Loc
,
10354 New_External_Name
('T', Depth
));
10356 Inner_Any_TypeCode_Expr
: Node_Id
;
10360 if Constrained
then
10361 Inner_Any_TypeCode_Expr
:=
10362 Make_Function_Call
(Loc
,
10364 New_Occurrence_Of
(RTE
(RE_Get_TC
), Loc
),
10365 Parameter_Associations
=> New_List
(
10366 New_Occurrence_Of
(Any
, Loc
)));
10368 Inner_Any_TypeCode_Expr
:=
10369 Make_Function_Call
(Loc
,
10371 New_Occurrence_Of
(RTE
(RE_Any_Member_Type
), Loc
),
10372 Parameter_Associations
=> New_List
(
10373 New_Occurrence_Of
(Any
, Loc
),
10374 Make_Integer_Literal
(Loc
, Ndim
)));
10377 Inner_Any_TypeCode_Expr
:=
10378 Make_Function_Call
(Loc
,
10380 New_Occurrence_Of
(RTE
(RE_Content_Type
), Loc
),
10381 Parameter_Associations
=> New_List
(
10382 Make_Identifier
(Loc
,
10383 New_External_Name
('T', Depth
- 1))));
10387 Make_Object_Declaration
(Loc
,
10388 Defining_Identifier
=> Inner_Any_TypeCode
,
10389 Constant_Present
=> True,
10390 Object_Definition
=> New_Occurrence_Of
(
10391 RTE
(RE_TypeCode
), Loc
),
10392 Expression
=> Inner_Any_TypeCode_Expr
));
10394 if Present
(Inner_Any
) then
10396 Make_Object_Declaration
(Loc
,
10397 Defining_Identifier
=> Inner_Any
,
10398 Object_Definition
=>
10399 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
10401 Make_Function_Call
(Loc
,
10403 New_Occurrence_Of
(
10404 RTE
(RE_Create_Any
), Loc
),
10405 Parameter_Associations
=> New_List
(
10406 New_Occurrence_Of
(Inner_Any_TypeCode
, Loc
)))));
10409 if Present
(Inner_Counter
) then
10411 Make_Object_Declaration
(Loc
,
10412 Defining_Identifier
=> Inner_Counter
,
10413 Object_Definition
=>
10414 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
10416 Make_Integer_Literal
(Loc
, 0)));
10419 if not Constrained
then
10420 Length_Node
:= Make_Attribute_Reference
(Loc
,
10421 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10422 Attribute_Name
=> Name_Length
,
10424 New_List
(Make_Integer_Literal
(Loc
, Depth
)));
10425 Set_Etype
(Length_Node
, RTE
(RE_Long_Unsigned
));
10427 Add_Process_Element
(Dimen_Stmts
,
10428 Datum
=> Length_Node
,
10430 Counter
=> Inner_Counter
);
10433 -- Loop_Stm does approrpriate processing for each element
10436 Append_To
(Dimen_Stmts
, Loop_Stm
);
10438 -- Link outer and inner any
10440 if Present
(Inner_Any
) then
10441 Add_Process_Element
(Dimen_Stmts
,
10443 Counter
=> Counter
,
10444 Datum
=> New_Occurrence_Of
(Inner_Any
, Loc
));
10448 Make_Block_Statement
(Loc
,
10451 Handled_Statement_Sequence
=>
10452 Make_Handled_Sequence_Of_Statements
(Loc
,
10453 Statements
=> Dimen_Stmts
)));
10455 end Append_Array_Traversal
;
10457 -----------------------------------------
10458 -- Make_Stream_Procedure_Function_Name --
10459 -----------------------------------------
10461 function Make_Stream_Procedure_Function_Name
10464 Nam
: Name_Id
) return Entity_Id
10467 -- For tagged types, we use a canonical name so that it matches
10468 -- the primitive spec. For all other cases, we use a serialized
10469 -- name so that multiple generations of the same procedure do not
10472 if Is_Tagged_Type
(Typ
) then
10473 return Make_Defining_Identifier
(Loc
, Nam
);
10475 return Make_Defining_Identifier
(Loc
,
10477 New_External_Name
(Nam
, ' ', Increment_Serial_Number
));
10479 end Make_Stream_Procedure_Function_Name
;
10482 -----------------------------------
10483 -- Reserve_NamingContext_Methods --
10484 -----------------------------------
10486 procedure Reserve_NamingContext_Methods
is
10487 Str_Resolve
: constant String := "resolve";
10489 Name_Buffer
(1 .. Str_Resolve
'Length) := Str_Resolve
;
10490 Name_Len
:= Str_Resolve
'Length;
10491 Overload_Counter_Table
.Set
(Name_Find
, 1);
10492 end Reserve_NamingContext_Methods
;
10494 end PolyORB_Support
;
10496 -------------------------------
10497 -- RACW_Type_Is_Asynchronous --
10498 -------------------------------
10500 procedure RACW_Type_Is_Asynchronous
(RACW_Type
: Entity_Id
) is
10501 Asynchronous_Flag
: constant Entity_Id
:=
10502 Asynchronous_Flags_Table
.Get
(RACW_Type
);
10504 Replace
(Expression
(Parent
(Asynchronous_Flag
)),
10505 New_Occurrence_Of
(Standard_True
, Sloc
(Asynchronous_Flag
)));
10506 end RACW_Type_Is_Asynchronous
;
10508 -------------------------
10509 -- RCI_Package_Locator --
10510 -------------------------
10512 function RCI_Package_Locator
10514 Package_Spec
: Node_Id
) return Node_Id
10517 Pkg_Name
: String_Id
;
10520 Get_Library_Unit_Name_String
(Package_Spec
);
10521 Pkg_Name
:= String_From_Name_Buffer
;
10523 Make_Package_Instantiation
(Loc
,
10524 Defining_Unit_Name
=>
10525 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
10527 New_Occurrence_Of
(RTE
(RE_RCI_Locator
), Loc
),
10528 Generic_Associations
=> New_List
(
10529 Make_Generic_Association
(Loc
,
10531 Make_Identifier
(Loc
, Name_RCI_Name
),
10532 Explicit_Generic_Actual_Parameter
=>
10533 Make_String_Literal
(Loc
,
10534 Strval
=> Pkg_Name
))));
10536 RCI_Locator_Table
.Set
(Defining_Unit_Name
(Package_Spec
),
10537 Defining_Unit_Name
(Inst
));
10539 end RCI_Package_Locator
;
10541 -----------------------------------------------
10542 -- Remote_Types_Tagged_Full_View_Encountered --
10543 -----------------------------------------------
10545 procedure Remote_Types_Tagged_Full_View_Encountered
10546 (Full_View
: Entity_Id
)
10548 Stub_Elements
: constant Stub_Structure
:=
10549 Stubs_Table
.Get
(Full_View
);
10551 if Stub_Elements
/= Empty_Stub_Structure
then
10552 Add_RACW_Primitive_Declarations_And_Bodies
10554 Stub_Elements
.RPC_Receiver_Decl
,
10555 List_Containing
(Declaration_Node
(Full_View
)));
10557 end Remote_Types_Tagged_Full_View_Encountered
;
10559 -------------------
10560 -- Scope_Of_Spec --
10561 -------------------
10563 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
is
10564 Unit_Name
: Node_Id
;
10567 Unit_Name
:= Defining_Unit_Name
(Spec
);
10568 while Nkind
(Unit_Name
) /= N_Defining_Identifier
loop
10569 Unit_Name
:= Defining_Identifier
(Unit_Name
);
10575 ----------------------
10576 -- Set_Renaming_TSS --
10577 ----------------------
10579 procedure Set_Renaming_TSS
10582 TSS_Nam
: TSS_Name_Type
)
10584 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
10585 Spec
: constant Node_Id
:= Parent
(Nam
);
10587 TSS_Node
: constant Node_Id
:=
10588 Make_Subprogram_Renaming_Declaration
(Loc
,
10590 Copy_Specification
(Loc
,
10592 New_Name
=> Make_TSS_Name
(Typ
, TSS_Nam
)),
10593 Name
=> New_Occurrence_Of
(Nam
, Loc
));
10595 Snam
: constant Entity_Id
:=
10596 Defining_Unit_Name
(Specification
(TSS_Node
));
10599 if Nkind
(Spec
) = N_Function_Specification
then
10600 Set_Ekind
(Snam
, E_Function
);
10601 Set_Etype
(Snam
, Entity
(Result_Definition
(Spec
)));
10603 Set_Ekind
(Snam
, E_Procedure
);
10604 Set_Etype
(Snam
, Standard_Void_Type
);
10607 Set_TSS
(Typ
, Snam
);
10608 end Set_Renaming_TSS
;
10610 ----------------------------------------------
10611 -- Specific_Add_Obj_RPC_Receiver_Completion --
10612 ----------------------------------------------
10614 procedure Specific_Add_Obj_RPC_Receiver_Completion
10617 RPC_Receiver
: Entity_Id
;
10618 Stub_Elements
: Stub_Structure
) is
10620 case Get_PCS_Name
is
10621 when Name_PolyORB_DSA
=>
10622 PolyORB_Support
.Add_Obj_RPC_Receiver_Completion
(Loc
,
10623 Decls
, RPC_Receiver
, Stub_Elements
);
10625 GARLIC_Support
.Add_Obj_RPC_Receiver_Completion
(Loc
,
10626 Decls
, RPC_Receiver
, Stub_Elements
);
10628 end Specific_Add_Obj_RPC_Receiver_Completion
;
10630 --------------------------------
10631 -- Specific_Add_RACW_Features --
10632 --------------------------------
10634 procedure Specific_Add_RACW_Features
10635 (RACW_Type
: Entity_Id
;
10637 Stub_Type
: Entity_Id
;
10638 Stub_Type_Access
: Entity_Id
;
10639 RPC_Receiver_Decl
: Node_Id
;
10640 Declarations
: List_Id
) is
10642 case Get_PCS_Name
is
10643 when Name_PolyORB_DSA
=>
10644 PolyORB_Support
.Add_RACW_Features
(
10653 GARLIC_Support
.Add_RACW_Features
(
10660 end Specific_Add_RACW_Features
;
10662 --------------------------------
10663 -- Specific_Add_RAST_Features --
10664 --------------------------------
10666 procedure Specific_Add_RAST_Features
10667 (Vis_Decl
: Node_Id
;
10668 RAS_Type
: Entity_Id
) is
10670 case Get_PCS_Name
is
10671 when Name_PolyORB_DSA
=>
10672 PolyORB_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
10674 GARLIC_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
10676 end Specific_Add_RAST_Features
;
10678 --------------------------------------------------
10679 -- Specific_Add_Receiving_Stubs_To_Declarations --
10680 --------------------------------------------------
10682 procedure Specific_Add_Receiving_Stubs_To_Declarations
10683 (Pkg_Spec
: Node_Id
;
10687 case Get_PCS_Name
is
10688 when Name_PolyORB_DSA
=>
10689 PolyORB_Support
.Add_Receiving_Stubs_To_Declarations
(
10692 GARLIC_Support
.Add_Receiving_Stubs_To_Declarations
(
10695 end Specific_Add_Receiving_Stubs_To_Declarations
;
10697 ------------------------------------------
10698 -- Specific_Build_General_Calling_Stubs --
10699 ------------------------------------------
10701 procedure Specific_Build_General_Calling_Stubs
10703 Statements
: List_Id
;
10704 Target
: RPC_Target
;
10705 Subprogram_Id
: Node_Id
;
10706 Asynchronous
: Node_Id
:= Empty
;
10707 Is_Known_Asynchronous
: Boolean := False;
10708 Is_Known_Non_Asynchronous
: Boolean := False;
10709 Is_Function
: Boolean;
10711 Stub_Type
: Entity_Id
:= Empty
;
10712 RACW_Type
: Entity_Id
:= Empty
;
10716 case Get_PCS_Name
is
10717 when Name_PolyORB_DSA
=>
10718 PolyORB_Support
.Build_General_Calling_Stubs
(
10724 Is_Known_Asynchronous
,
10725 Is_Known_Non_Asynchronous
,
10732 GARLIC_Support
.Build_General_Calling_Stubs
(
10736 Target
.RPC_Receiver
,
10739 Is_Known_Asynchronous
,
10740 Is_Known_Non_Asynchronous
,
10747 end Specific_Build_General_Calling_Stubs
;
10749 --------------------------------------
10750 -- Specific_Build_RPC_Receiver_Body --
10751 --------------------------------------
10753 procedure Specific_Build_RPC_Receiver_Body
10754 (RPC_Receiver
: Entity_Id
;
10755 Request
: out Entity_Id
;
10756 Subp_Id
: out Entity_Id
;
10757 Subp_Index
: out Entity_Id
;
10758 Stmts
: out List_Id
;
10759 Decl
: out Node_Id
)
10762 case Get_PCS_Name
is
10763 when Name_PolyORB_DSA
=>
10764 PolyORB_Support
.Build_RPC_Receiver_Body
10772 GARLIC_Support
.Build_RPC_Receiver_Body
10780 end Specific_Build_RPC_Receiver_Body
;
10782 --------------------------------
10783 -- Specific_Build_Stub_Target --
10784 --------------------------------
10786 function Specific_Build_Stub_Target
10789 RCI_Locator
: Entity_Id
;
10790 Controlling_Parameter
: Entity_Id
) return RPC_Target
10793 case Get_PCS_Name
is
10794 when Name_PolyORB_DSA
=>
10795 return PolyORB_Support
.Build_Stub_Target
(Loc
,
10796 Decls
, RCI_Locator
, Controlling_Parameter
);
10798 return GARLIC_Support
.Build_Stub_Target
(Loc
,
10799 Decls
, RCI_Locator
, Controlling_Parameter
);
10801 end Specific_Build_Stub_Target
;
10803 ------------------------------
10804 -- Specific_Build_Stub_Type --
10805 ------------------------------
10807 procedure Specific_Build_Stub_Type
10808 (RACW_Type
: Entity_Id
;
10809 Stub_Type
: Entity_Id
;
10810 Stub_Type_Decl
: out Node_Id
;
10811 RPC_Receiver_Decl
: out Node_Id
)
10814 case Get_PCS_Name
is
10815 when Name_PolyORB_DSA
=>
10816 PolyORB_Support
.Build_Stub_Type
(
10817 RACW_Type
, Stub_Type
,
10818 Stub_Type_Decl
, RPC_Receiver_Decl
);
10820 GARLIC_Support
.Build_Stub_Type
(
10821 RACW_Type
, Stub_Type
,
10822 Stub_Type_Decl
, RPC_Receiver_Decl
);
10824 end Specific_Build_Stub_Type
;
10826 function Specific_Build_Subprogram_Receiving_Stubs
10827 (Vis_Decl
: Node_Id
;
10828 Asynchronous
: Boolean;
10829 Dynamically_Asynchronous
: Boolean := False;
10830 Stub_Type
: Entity_Id
:= Empty
;
10831 RACW_Type
: Entity_Id
:= Empty
;
10832 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
10835 case Get_PCS_Name
is
10836 when Name_PolyORB_DSA
=>
10837 return PolyORB_Support
.Build_Subprogram_Receiving_Stubs
(
10840 Dynamically_Asynchronous
,
10845 return GARLIC_Support
.Build_Subprogram_Receiving_Stubs
(
10848 Dynamically_Asynchronous
,
10853 end Specific_Build_Subprogram_Receiving_Stubs
;
10855 --------------------------
10856 -- Underlying_RACW_Type --
10857 --------------------------
10859 function Underlying_RACW_Type
(RAS_Typ
: Entity_Id
) return Entity_Id
is
10860 Record_Type
: Entity_Id
;
10863 if Ekind
(RAS_Typ
) = E_Record_Type
then
10864 Record_Type
:= RAS_Typ
;
10866 pragma Assert
(Present
(Equivalent_Type
(RAS_Typ
)));
10867 Record_Type
:= Equivalent_Type
(RAS_Typ
);
10871 Etype
(Subtype_Indication
(
10872 Component_Definition
(
10873 First
(Component_Items
(Component_List
(
10874 Type_Definition
(Declaration_Node
(Record_Type
))))))));
10875 end Underlying_RACW_Type
;