1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 function Get_PCS_Name
return PCS_Names
;
156 -- Return the name of a literal of type
157 -- System.Partition_Interface.DSA_Implementation_Type
158 -- indicating what PCS is currently in use.
160 procedure Add_RAS_Dereference_TSS
(N
: Node_Id
);
161 -- Add a subprogram body for RAS Dereference TSS
163 procedure Add_RAS_Proxy_And_Analyze
166 All_Calls_Remote_E
: Entity_Id
;
167 Proxy_Object_Addr
: out Entity_Id
);
168 -- Add the proxy type necessary to call the subprogram declared
169 -- by Vis_Decl through a remote access to subprogram type.
170 -- All_Calls_Remote_E must be Standard_True if a pragma All_Calls_Remote
171 -- applies, Standard_False otherwise. The new proxy type is appended
172 -- to Decls. Proxy_Object_Addr is a constant of type System.Address that
173 -- designates an instance of the proxy object.
175 function Build_Remote_Subprogram_Proxy_Type
177 ACR_Expression
: Node_Id
) return Node_Id
;
178 -- Build and return a tagged record type definition for an RCI
179 -- subprogram proxy type.
180 -- ACR_Expression is use as the initialization value for
181 -- the All_Calls_Remote component.
183 function Build_Get_Unique_RP_Call
186 Stub_Type
: Entity_Id
) return List_Id
;
187 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
188 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
189 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
191 function Build_Subprogram_Calling_Stubs
194 Asynchronous
: Boolean;
195 Dynamically_Asynchronous
: Boolean := False;
196 Stub_Type
: Entity_Id
:= Empty
;
197 RACW_Type
: Entity_Id
:= Empty
;
198 Locator
: Entity_Id
:= Empty
;
199 New_Name
: Name_Id
:= No_Name
) return Node_Id
;
200 -- Build the calling stub for a given subprogram with the subprogram ID
201 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
202 -- parameters of this type will be marshalled instead of the object
203 -- itself. It will then be converted into Stub_Type before performing
204 -- the real call. If Dynamically_Asynchronous is True, then it will be
205 -- computed at run time whether the call is asynchronous or not.
206 -- Otherwise, the value of the formal Asynchronous will be used.
207 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
208 -- New_Name is given, then it will be used instead of the original name.
210 function Build_RPC_Receiver_Specification
211 (RPC_Receiver
: Entity_Id
;
212 Request_Parameter
: Entity_Id
) return Node_Id
;
213 -- Make a subprogram specification for an RPC receiver, with the given
214 -- defining unit name and formal parameter.
216 function Build_Ordered_Parameters_List
(Spec
: Node_Id
) return List_Id
;
217 -- Return an ordered parameter list: unconstrained parameters are put
218 -- at the beginning of the list and constrained ones are put after. If
219 -- there are no parameters, an empty list is returned. Special case:
220 -- the controlling formal of the equivalent RACW operation for a RAS
221 -- type is always left in first position.
223 procedure Add_Calling_Stubs_To_Declarations
226 -- Add calling stubs to the declarative part
228 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean;
229 -- Return True if nothing prevents the program whose specification is
230 -- given to be asynchronous (i.e. no out parameter).
232 function Pack_Entity_Into_Stream_Access
236 Etyp
: Entity_Id
:= Empty
) return Node_Id
;
237 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
238 -- then Etype (Object) will be used if present. If the type is
239 -- constrained, then 'Write will be used to output the object,
240 -- If the type is unconstrained, 'Output will be used.
242 function Pack_Node_Into_Stream
246 Etyp
: Entity_Id
) return Node_Id
;
247 -- Similar to above, with an arbitrary node instead of an entity
249 function Pack_Node_Into_Stream_Access
253 Etyp
: Entity_Id
) return Node_Id
;
254 -- Similar to above, with Stream instead of Stream'Access
256 function Make_Selected_Component
259 Selector_Name
: Name_Id
) return Node_Id
;
260 -- Return a selected_component whose prefix denotes the given entity,
261 -- and with the given Selector_Name.
263 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
;
264 -- Return the scope represented by a given spec
266 procedure Set_Renaming_TSS
270 -- Create a renaming declaration of subprogram Nam,
271 -- and register it as a TSS for Typ with name TSS_Nam.
273 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean;
274 -- Return True if the current parameter needs an extra formal to reflect
275 -- its constrained status.
277 function Is_RACW_Controlling_Formal
278 (Parameter
: Node_Id
; Stub_Type
: Entity_Id
) return Boolean;
279 -- Return True if the current parameter is a controlling formal argument
280 -- of type Stub_Type or access to Stub_Type.
282 procedure Declare_Create_NVList
287 -- Append the declaration of NVList to Decls, and its
288 -- initialization to Stmts.
290 function Add_Parameter_To_NVList
293 Parameter
: Entity_Id
;
294 Constrained
: Boolean;
295 RACW_Ctrl
: Boolean := False;
296 Any
: Entity_Id
) return Node_Id
;
297 -- Return a call to Add_Item to add the Any corresponding
298 -- to the designated formal Parameter (with the indicated
299 -- Constrained status) to NVList. RACW_Ctrl must be set to
300 -- True for controlling formals of distributed object primitive
303 type Stub_Structure
is record
304 Stub_Type
: Entity_Id
;
305 Stub_Type_Access
: Entity_Id
;
306 RPC_Receiver_Decl
: Node_Id
;
307 RACW_Type
: Entity_Id
;
309 -- This structure is necessary because of the two phases analysis of
310 -- a RACW declaration occurring in the same Remote_Types package as the
311 -- designated type. RACW_Type is any of the RACW types pointing on this
312 -- designated type, it is used here to save an anonymous type creation
313 -- for each primitive operation.
315 -- For a RACW that implements a RAS, no object RPC receiver is generated.
316 -- Instead, RPC_Receiver_Decl is the declaration after which the
317 -- RPC receiver would have been inserted.
319 Empty_Stub_Structure
: constant Stub_Structure
:=
320 (Empty
, Empty
, Empty
, Empty
);
322 package Stubs_Table
is
323 new Simple_HTable
(Header_Num
=> Hash_Index
,
324 Element
=> Stub_Structure
,
325 No_Element
=> Empty_Stub_Structure
,
329 -- Mapping between a RACW designated type and its stub type
331 package Asynchronous_Flags_Table
is
332 new Simple_HTable
(Header_Num
=> Hash_Index
,
333 Element
=> Entity_Id
,
338 -- Mapping between a RACW type and a constant having the value True
339 -- if the RACW is asynchronous and False otherwise.
341 package RCI_Locator_Table
is
342 new Simple_HTable
(Header_Num
=> Hash_Index
,
343 Element
=> Entity_Id
,
348 -- Mapping between a RCI package on which All_Calls_Remote applies and
349 -- the generic instantiation of RCI_Locator for this package.
351 package RCI_Calling_Stubs_Table
is
352 new Simple_HTable
(Header_Num
=> Hash_Index
,
353 Element
=> Entity_Id
,
358 -- Mapping between a RCI subprogram and the corresponding calling stubs
360 procedure Add_Stub_Type
361 (Designated_Type
: Entity_Id
;
362 RACW_Type
: Entity_Id
;
364 Stub_Type
: out Entity_Id
;
365 Stub_Type_Access
: out Entity_Id
;
366 RPC_Receiver_Decl
: out Node_Id
;
367 Existing
: out Boolean);
368 -- Add the declaration of the stub type, the access to stub type and the
369 -- object RPC receiver at the end of Decls. If these already exist,
370 -- then nothing is added in the tree but the right values are returned
371 -- anyhow and Existing is set to True.
373 procedure Add_RACW_Asynchronous_Flag
374 (Declarations
: List_Id
;
375 RACW_Type
: Entity_Id
);
376 -- Declare a boolean constant associated with RACW_Type whose value
377 -- indicates at run time whether a pragma Asynchronous applies to it.
379 procedure Assign_Subprogram_Identifier
383 -- Determine the distribution subprogram identifier to
384 -- be used for remote subprogram Def, return it in Id and
385 -- store it in a hash table for later retrieval by
386 -- Get_Subprogram_Id. Spn is the subprogram number.
388 function RCI_Package_Locator
390 Package_Spec
: Node_Id
) return Node_Id
;
391 -- Instantiate the generic package RCI_Locator in order to locate the
392 -- RCI package whose spec is given as argument.
394 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
;
395 -- Surround a node N by a tag check, as in:
399 -- when E : Ada.Tags.Tag_Error =>
400 -- Raise_Exception (Program_Error'Identity,
401 -- Exception_Message (E));
404 function Input_With_Tag_Check
406 Var_Type
: Entity_Id
;
407 Stream
: Node_Id
) return Node_Id
;
408 -- Return a function with the following form:
409 -- function R return Var_Type is
411 -- return Var_Type'Input (S);
413 -- when E : Ada.Tags.Tag_Error =>
414 -- Raise_Exception (Program_Error'Identity,
415 -- Exception_Message (E));
418 --------------------------------------------
419 -- Hooks for PCS-specific code generation --
420 --------------------------------------------
422 -- Part of the code generation circuitry for distribution needs to be
423 -- tailored for each implementation of the PCS. For each routine that
424 -- needs to be specialized, a Specific_<routine> wrapper is created,
425 -- which calls the corresponding <routine> in package
426 -- <pcs_implementation>_Support.
428 procedure Specific_Add_RACW_Features
429 (RACW_Type
: Entity_Id
;
431 Stub_Type
: Entity_Id
;
432 Stub_Type_Access
: Entity_Id
;
433 RPC_Receiver_Decl
: Node_Id
;
434 Declarations
: List_Id
);
435 -- Add declaration for TSSs for a given RACW type. The declarations are
436 -- added just after the declaration of the RACW type itself, while the
437 -- bodies are inserted at the end of Decls. Runtime-specific ancillary
438 -- subprogram for Add_RACW_Features.
440 procedure Specific_Add_RAST_Features
442 RAS_Type
: Entity_Id
;
444 -- Add declaration for TSSs for a given RAS type. The declarations are
445 -- added just after the declaration of the RAS type itself, while the
446 -- bodies are inserted at the end of Decls. PCS-specific ancillary
447 -- subprogram for Add_RAST_Features.
449 -- An RPC_Target record is used during construction of calling stubs
450 -- to pass PCS-specific tree fragments corresponding to the information
451 -- necessary to locate the target of a remote subprogram call.
453 type RPC_Target
(PCS_Kind
: PCS_Names
) is record
455 when Name_PolyORB_DSA
=>
457 -- An expression whose value is a PolyORB reference to the target
460 Partition
: Entity_Id
;
461 -- A variable containing the Partition_ID of the target parition
463 RPC_Receiver
: Node_Id
;
464 -- An expression whose value is the address of the target RPC
469 procedure Specific_Build_General_Calling_Stubs
471 Statements
: List_Id
;
473 Subprogram_Id
: Node_Id
;
474 Asynchronous
: Node_Id
:= Empty
;
475 Is_Known_Asynchronous
: Boolean := False;
476 Is_Known_Non_Asynchronous
: Boolean := False;
477 Is_Function
: Boolean;
479 Stub_Type
: Entity_Id
:= Empty
;
480 RACW_Type
: Entity_Id
:= Empty
;
482 -- Build calling stubs for general purpose. The parameters are:
483 -- Decls : a place to put declarations
484 -- Statements : a place to put statements
485 -- Target : PCS-specific target information (see details
486 -- in RPC_Target declaration).
487 -- Subprogram_Id : a node containing the subprogram ID
488 -- Asynchronous : True if an APC must be made instead of an RPC.
489 -- The value needs not be supplied if one of the
490 -- Is_Known_... is True.
491 -- Is_Known_Async... : True if we know that this is asynchronous
492 -- Is_Known_Non_A... : True if we know that this is not asynchronous
493 -- Spec : a node with a Parameter_Specifications and
494 -- a Subtype_Mark if applicable
495 -- Stub_Type : in case of RACW stubs, parameters of type access
496 -- to Stub_Type will be marshalled using the
497 -- address of the object (the addr field) rather
498 -- than using the 'Write on the stub itself
499 -- Nod : used to provide sloc for generated code
501 function Specific_Build_Stub_Target
504 RCI_Locator
: Entity_Id
;
505 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
506 -- Build call target information nodes for use within calling stubs. In the
507 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
508 -- for an RACW, Controlling_Parameter is the entity for the controlling
509 -- formal parameter used to determine the location of the target of the
510 -- call. Decls provides a location where variable declarations can be
511 -- appended to construct the necessary values.
513 procedure Specific_Build_Stub_Type
514 (RACW_Type
: Entity_Id
;
515 Stub_Type
: Entity_Id
;
516 Stub_Type_Decl
: out Node_Id
;
517 RPC_Receiver_Decl
: out Node_Id
);
518 -- Build a type declaration for the stub type associated with an RACW
519 -- type, and the necessary RPC receiver, if applicable. PCS-specific
520 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
521 -- is generated, then RPC_Receiver_Decl is set to Empty.
523 procedure Specific_Build_RPC_Receiver_Body
524 (RPC_Receiver
: Entity_Id
;
525 Request
: out Entity_Id
;
526 Subp_Id
: out Entity_Id
;
527 Subp_Index
: out Entity_Id
;
530 -- Make a subprogram body for an RPC receiver, with the given
531 -- defining unit name. On return:
532 -- - Subp_Id is the subprogram identifier from the PCS.
533 -- - Subp_Index is the index in the list of subprograms
534 -- used for dispatching (a variable of type Subprogram_Id).
535 -- - Stmts is the place where the request dispatching
536 -- statements can occur,
537 -- - Decl is the subprogram body declaration.
539 function Specific_Build_Subprogram_Receiving_Stubs
541 Asynchronous
: Boolean;
542 Dynamically_Asynchronous
: Boolean := False;
543 Stub_Type
: Entity_Id
:= Empty
;
544 RACW_Type
: Entity_Id
:= Empty
;
545 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
546 -- Build the receiving stub for a given subprogram. The subprogram
547 -- declaration is also built by this procedure, and the value returned
548 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
549 -- found in the specification, then its address is read from the stream
550 -- instead of the object itself and converted into an access to
551 -- class-wide type before doing the real call using any of the RACW type
552 -- pointing on the designated type.
554 procedure Specific_Add_Receiving_Stubs_To_Declarations
557 -- Add receiving stubs to the declarative part
559 package GARLIC_Support
is
561 -- Support for generating DSA code that uses the GARLIC PCS
563 -- The subprograms below provide the GARLIC versions of
564 -- the corresponding Specific_<subprogram> routine declared
567 procedure Add_RACW_Features
568 (RACW_Type
: Entity_Id
;
569 Stub_Type
: Entity_Id
;
570 Stub_Type_Access
: Entity_Id
;
571 RPC_Receiver_Decl
: Node_Id
;
572 Declarations
: List_Id
);
574 procedure Add_RAST_Features
576 RAS_Type
: Entity_Id
;
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_Receiving_Stubs_To_Declarations
618 procedure Build_RPC_Receiver_Body
619 (RPC_Receiver
: Entity_Id
;
620 Request
: out Entity_Id
;
621 Subp_Id
: out Entity_Id
;
622 Subp_Index
: out Entity_Id
;
628 package PolyORB_Support
is
630 -- Support for generating DSA code that uses the PolyORB PCS
632 -- The subprograms below provide the PolyORB versions of
633 -- the corresponding Specific_<subprogram> routine declared
636 procedure Add_RACW_Features
637 (RACW_Type
: Entity_Id
;
639 Stub_Type
: Entity_Id
;
640 Stub_Type_Access
: Entity_Id
;
641 RPC_Receiver_Decl
: Node_Id
;
642 Declarations
: List_Id
);
644 procedure Add_RAST_Features
646 RAS_Type
: Entity_Id
;
649 procedure Build_General_Calling_Stubs
651 Statements
: List_Id
;
652 Target_Object
: Node_Id
; -- From RPC_Target
653 Subprogram_Id
: Node_Id
;
654 Asynchronous
: Node_Id
:= Empty
;
655 Is_Known_Asynchronous
: Boolean := False;
656 Is_Known_Non_Asynchronous
: Boolean := False;
657 Is_Function
: Boolean;
659 Stub_Type
: Entity_Id
:= Empty
;
660 RACW_Type
: Entity_Id
:= Empty
;
663 function Build_Stub_Target
666 RCI_Locator
: Entity_Id
;
667 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
669 procedure Build_Stub_Type
670 (RACW_Type
: Entity_Id
;
671 Stub_Type
: Entity_Id
;
672 Stub_Type_Decl
: out Node_Id
;
673 RPC_Receiver_Decl
: out Node_Id
);
675 function Build_Subprogram_Receiving_Stubs
677 Asynchronous
: Boolean;
678 Dynamically_Asynchronous
: Boolean := False;
679 Stub_Type
: Entity_Id
:= Empty
;
680 RACW_Type
: Entity_Id
:= Empty
;
681 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
683 procedure Add_Receiving_Stubs_To_Declarations
687 procedure Build_RPC_Receiver_Body
688 (RPC_Receiver
: Entity_Id
;
689 Request
: out Entity_Id
;
690 Subp_Id
: out Entity_Id
;
691 Subp_Index
: out Entity_Id
;
695 procedure Reserve_NamingContext_Methods
;
696 -- Mark the method names for interface NamingContext as already used in
697 -- the overload table, so no clashes occur with user code (with the
698 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
699 -- their methods to be accessed as objects, for the implementation of
700 -- remote access-to-subprogram types).
704 -- Routines to build distribtion helper subprograms for user-defined
705 -- types. For implementation of the Distributed systems annex (DSA)
706 -- over the PolyORB generic middleware components, it is necessary to
707 -- generate several supporting subprograms for each application data
708 -- type used in inter-partition communication. These subprograms are:
709 -- * a Typecode function returning a high-level description of the
711 -- * two conversion functions allowing conversion of values of the
712 -- type from and to the generic data containers used by PolyORB.
713 -- These generic containers are called 'Any' type values after
714 -- the CORBA terminology, and hence the conversion subprograms
715 -- are named To_Any and From_Any.
717 function Build_From_Any_Call
720 Decls
: List_Id
) return Node_Id
;
721 -- Build call to From_Any attribute function of type Typ with
722 -- expression N as actual parameter. Decls is the declarations list
723 -- for an appropriate enclosing scope of the point where the call
724 -- will be inserted; if the From_Any attribute for Typ needs to be
725 -- generated at this point, its declaration is appended to Decls.
727 procedure Build_From_Any_Function
731 Fnam
: out Entity_Id
);
732 -- Build From_Any attribute function for Typ. Loc is the reference
733 -- location for generated nodes, Typ is the type for which the
734 -- conversion function is generated. On return, Decl and Fnam contain
735 -- the declaration and entity for the newly-created function.
737 function Build_To_Any_Call
739 Decls
: List_Id
) return Node_Id
;
740 -- Build call to To_Any attribute function with expression as actual
741 -- parameter. Decls is the declarations list for an appropriate
742 -- enclosing scope of the point where the call will be inserted; if
743 -- the To_Any attribute for Typ needs to be generated at this point,
744 -- its declaration is appended to Decls.
746 procedure Build_To_Any_Function
750 Fnam
: out Entity_Id
);
751 -- Build To_Any attribute function for Typ. Loc is the reference
752 -- location for generated nodes, Typ is the type for which the
753 -- conversion function is generated. On return, Decl and Fnam contain
754 -- the declaration and entity for the newly-created function.
756 function Build_TypeCode_Call
759 Decls
: List_Id
) return Node_Id
;
760 -- Build call to TypeCode attribute function for Typ. Decls is the
761 -- declarations list for an appropriate enclosing scope of the point
762 -- where the call will be inserted; if the To_Any attribute for Typ
763 -- needs to be generated at this point, its declaration is appended
766 procedure Build_TypeCode_Function
770 Fnam
: out Entity_Id
);
771 -- Build TypeCode attribute function for Typ. Loc is the reference
772 -- location for generated nodes, Typ is the type for which the
773 -- conversion function is generated. On return, Decl and Fnam contain
774 -- the declaration and entity for the newly-created function.
776 procedure Build_Name_And_Repository_Id
778 Name_Str
: out String_Id
;
779 Repo_Id_Str
: out String_Id
);
780 -- In the PolyORB distribution model, each distributed object type
781 -- and each distributed operation has a globally unique identifier,
782 -- its Repository Id. This subprogram builds and returns two strings
783 -- for entity E (a distributed object type or operation): one
784 -- containing the name of E, the second containing its repository id.
790 ------------------------------------
791 -- Local variables and structures --
792 ------------------------------------
795 -- Needs comments ???
797 Output_From_Constrained
: constant array (Boolean) of Name_Id
:=
798 (False => Name_Output
,
800 -- The attribute to choose depending on the fact that the parameter
801 -- is constrained or not. There is no such thing as Input_From_Constrained
802 -- since this require separate mechanisms ('Input is a function while
803 -- 'Read is a procedure).
805 ---------------------------------------
806 -- Add_Calling_Stubs_To_Declarations --
807 ---------------------------------------
809 procedure Add_Calling_Stubs_To_Declarations
813 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
814 -- Subprogram id 0 is reserved for calls received from
815 -- remote access-to-subprogram dereferences.
817 Current_Declaration
: Node_Id
;
818 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
819 RCI_Instantiation
: Node_Id
;
820 Subp_Stubs
: Node_Id
;
821 Subp_Str
: String_Id
;
824 -- The first thing added is an instantiation of the generic package
825 -- System.Partition_Interface.RCI_Locator with the name of this
826 -- remote package. This will act as an interface with the name server
827 -- to determine the Partition_ID and the RPC_Receiver for the
828 -- receiver of this package.
830 RCI_Instantiation
:= RCI_Package_Locator
(Loc
, Pkg_Spec
);
831 RCI_Cache
:= Defining_Unit_Name
(RCI_Instantiation
);
833 Append_To
(Decls
, RCI_Instantiation
);
834 Analyze
(RCI_Instantiation
);
836 -- For each subprogram declaration visible in the spec, we do
837 -- build a body. We also increment a counter to assign a different
838 -- Subprogram_Id to each subprograms. The receiving stubs processing
839 -- do use the same mechanism and will thus assign the same Id and
840 -- do the correct dispatching.
842 Overload_Counter_Table
.Reset
;
843 PolyORB_Support
.Reserve_NamingContext_Methods
;
845 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
847 while Present
(Current_Declaration
) loop
848 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
849 and then Comes_From_Source
(Current_Declaration
)
851 Assign_Subprogram_Identifier
(
852 Defining_Unit_Name
(Specification
(Current_Declaration
)),
853 Current_Subprogram_Number
,
857 Build_Subprogram_Calling_Stubs
(
858 Vis_Decl
=> Current_Declaration
,
860 Build_Subprogram_Id
(Loc
,
861 Defining_Unit_Name
(Specification
(Current_Declaration
))),
863 Nkind
(Specification
(Current_Declaration
)) =
864 N_Procedure_Specification
866 Is_Asynchronous
(Defining_Unit_Name
(Specification
867 (Current_Declaration
))));
869 Append_To
(Decls
, Subp_Stubs
);
870 Analyze
(Subp_Stubs
);
872 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
875 Next
(Current_Declaration
);
877 end Add_Calling_Stubs_To_Declarations
;
879 -----------------------------
880 -- Add_Parameter_To_NVList --
881 -----------------------------
883 function Add_Parameter_To_NVList
886 Parameter
: Entity_Id
;
887 Constrained
: Boolean;
888 RACW_Ctrl
: Boolean := False;
889 Any
: Entity_Id
) return Node_Id
891 Parameter_Name_String
: String_Id
;
892 Parameter_Mode
: Node_Id
;
894 function Parameter_Passing_Mode
896 Parameter
: Entity_Id
;
897 Constrained
: Boolean) return Node_Id
;
898 -- Return an expression that denotes the parameter passing
899 -- mode to be used for Parameter in distribution stubs,
900 -- where Constrained is Parameter's constrained status.
902 ----------------------------
903 -- Parameter_Passing_Mode --
904 ----------------------------
906 function Parameter_Passing_Mode
908 Parameter
: Entity_Id
;
909 Constrained
: Boolean) return Node_Id
914 if Out_Present
(Parameter
) then
915 if In_Present
(Parameter
)
916 or else not Constrained
918 -- Unconstrained formals must be translated
919 -- to 'in' or 'inout', not 'out', because
920 -- they need to be constrained by the actual.
922 Lib_RE
:= RE_Mode_Inout
;
924 Lib_RE
:= RE_Mode_Out
;
928 Lib_RE
:= RE_Mode_In
;
931 return New_Occurrence_Of
(RTE
(Lib_RE
), Loc
);
932 end Parameter_Passing_Mode
;
934 -- Start of processing for Add_Parameter_To_NVList
937 if Nkind
(Parameter
) = N_Defining_Identifier
then
938 Get_Name_String
(Chars
(Parameter
));
940 Get_Name_String
(Chars
(Defining_Identifier
944 Parameter_Name_String
:= String_From_Name_Buffer
;
947 Parameter_Mode
:= New_Occurrence_Of
948 (RTE
(RE_Mode_In
), Loc
);
950 Parameter_Mode
:= Parameter_Passing_Mode
(Loc
,
951 Parameter
, Constrained
);
955 Make_Procedure_Call_Statement
(Loc
,
958 (RTE
(RE_NVList_Add_Item
), Loc
),
959 Parameter_Associations
=> New_List
(
960 New_Occurrence_Of
(NVList
, Loc
),
961 Make_Function_Call
(Loc
,
964 (RTE
(RE_To_PolyORB_String
), Loc
),
965 Parameter_Associations
=> New_List
(
966 Make_String_Literal
(Loc
,
967 Strval
=> Parameter_Name_String
))),
968 New_Occurrence_Of
(Any
, Loc
),
970 end Add_Parameter_To_NVList
;
972 --------------------------------
973 -- Add_RACW_Asynchronous_Flag --
974 --------------------------------
976 procedure Add_RACW_Asynchronous_Flag
977 (Declarations
: List_Id
;
978 RACW_Type
: Entity_Id
)
980 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
982 Asynchronous_Flag
: constant Entity_Id
:=
983 Make_Defining_Identifier
(Loc
,
984 New_External_Name
(Chars
(RACW_Type
), 'A'));
987 -- Declare the asynchronous flag. This flag will be changed to True
988 -- whenever it is known that the RACW type is asynchronous.
990 Append_To
(Declarations
,
991 Make_Object_Declaration
(Loc
,
992 Defining_Identifier
=> Asynchronous_Flag
,
993 Constant_Present
=> True,
994 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
995 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
997 Asynchronous_Flags_Table
.Set
(RACW_Type
, Asynchronous_Flag
);
998 end Add_RACW_Asynchronous_Flag
;
1000 -----------------------
1001 -- Add_RACW_Features --
1002 -----------------------
1004 procedure Add_RACW_Features
(RACW_Type
: Entity_Id
)
1006 Desig
: constant Entity_Id
:=
1007 Etype
(Designated_Type
(RACW_Type
));
1009 List_Containing
(Declaration_Node
(RACW_Type
));
1011 Same_Scope
: constant Boolean :=
1012 Scope
(Desig
) = Scope
(RACW_Type
);
1014 Stub_Type
: Entity_Id
;
1015 Stub_Type_Access
: Entity_Id
;
1016 RPC_Receiver_Decl
: Node_Id
;
1020 if not Expander_Active
then
1026 -- We are declaring a RACW in the same package than its designated
1027 -- type, so the list to use for late declarations must be the
1028 -- private part of the package. We do know that this private part
1029 -- exists since the designated type has to be a private one.
1031 Decls
:= Private_Declarations
1032 (Package_Specification_Of_Scope
(Current_Scope
));
1034 elsif Nkind
(Parent
(Decls
)) = N_Package_Specification
1035 and then Present
(Private_Declarations
(Parent
(Decls
)))
1037 Decls
:= Private_Declarations
(Parent
(Decls
));
1040 -- If we were unable to find the declarations, that means that the
1041 -- completion of the type was missing. We can safely return and let
1042 -- the error be caught by the semantic analysis.
1049 (Designated_Type
=> Desig
,
1050 RACW_Type
=> RACW_Type
,
1052 Stub_Type
=> Stub_Type
,
1053 Stub_Type_Access
=> Stub_Type_Access
,
1054 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1055 Existing
=> Existing
);
1057 Add_RACW_Asynchronous_Flag
1058 (Declarations
=> Decls
,
1059 RACW_Type
=> RACW_Type
);
1061 Specific_Add_RACW_Features
1062 (RACW_Type
=> RACW_Type
,
1064 Stub_Type
=> Stub_Type
,
1065 Stub_Type_Access
=> Stub_Type_Access
,
1066 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1067 Declarations
=> Decls
);
1069 if not Same_Scope
and then not Existing
then
1071 -- The RACW has been declared in another scope than the designated
1072 -- type and has not been handled by another RACW in the same package
1073 -- as the first one, so add primitive for the stub type here.
1075 Add_RACW_Primitive_Declarations_And_Bodies
1076 (Designated_Type
=> Desig
,
1077 Insertion_Node
=> RPC_Receiver_Decl
,
1081 Add_Access_Type_To_Process
(E
=> Desig
, A
=> RACW_Type
);
1083 end Add_RACW_Features
;
1085 ------------------------------------------------
1086 -- Add_RACW_Primitive_Declarations_And_Bodies --
1087 ------------------------------------------------
1089 procedure Add_RACW_Primitive_Declarations_And_Bodies
1090 (Designated_Type
: Entity_Id
;
1091 Insertion_Node
: Node_Id
;
1094 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1095 -- the declarations are recognized as belonging to the current package.
1097 Loc
: constant Source_Ptr
:= Sloc
(Insertion_Node
);
1099 Stub_Elements
: constant Stub_Structure
:=
1100 Stubs_Table
.Get
(Designated_Type
);
1102 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
1103 Is_RAS
: constant Boolean :=
1104 not Comes_From_Source
(Stub_Elements
.RACW_Type
);
1106 Current_Insertion_Node
: Node_Id
:= Insertion_Node
;
1108 RPC_Receiver
: Entity_Id
;
1109 RPC_Receiver_Statements
: List_Id
;
1110 RPC_Receiver_Case_Alternatives
: constant List_Id
:= New_List
;
1111 RPC_Receiver_Request
: Entity_Id
;
1112 RPC_Receiver_Subp_Id
: Entity_Id
;
1113 RPC_Receiver_Subp_Index
: Entity_Id
;
1115 Subp_Str
: String_Id
;
1117 Current_Primitive_Elmt
: Elmt_Id
;
1118 Current_Primitive
: Entity_Id
;
1119 Current_Primitive_Body
: Node_Id
;
1120 Current_Primitive_Spec
: Node_Id
;
1121 Current_Primitive_Decl
: Node_Id
;
1122 Current_Primitive_Number
: Int
:= 0;
1124 Current_Primitive_Alias
: Node_Id
;
1126 Current_Receiver
: Entity_Id
;
1127 Current_Receiver_Body
: Node_Id
;
1129 RPC_Receiver_Decl
: Node_Id
;
1131 Possibly_Asynchronous
: Boolean;
1134 if not Expander_Active
then
1139 RPC_Receiver
:= Make_Defining_Identifier
(Loc
,
1140 New_Internal_Name
('P'));
1141 Specific_Build_RPC_Receiver_Body
(
1142 RPC_Receiver
=> RPC_Receiver
,
1143 Request
=> RPC_Receiver_Request
,
1144 Subp_Id
=> RPC_Receiver_Subp_Id
,
1145 Subp_Index
=> RPC_Receiver_Subp_Index
,
1146 Stmts
=> RPC_Receiver_Statements
,
1147 Decl
=> RPC_Receiver_Decl
);
1150 -- Build callers, receivers for every primitive operations and a RPC
1151 -- receiver for this type.
1153 if Present
(Primitive_Operations
(Designated_Type
)) then
1154 Overload_Counter_Table
.Reset
;
1156 Current_Primitive_Elmt
:=
1157 First_Elmt
(Primitive_Operations
(Designated_Type
));
1158 while Current_Primitive_Elmt
/= No_Elmt
loop
1159 Current_Primitive
:= Node
(Current_Primitive_Elmt
);
1161 -- Copy the primitive of all the parents, except predefined
1162 -- ones that are not remotely dispatching.
1164 if Chars
(Current_Primitive
) /= Name_uSize
1165 and then Chars
(Current_Primitive
) /= Name_uAlignment
1166 and then not Is_TSS
(Current_Primitive
, TSS_Deep_Finalize
)
1168 -- The first thing to do is build an up-to-date copy of
1169 -- the spec with all the formals referencing Designated_Type
1170 -- transformed into formals referencing Stub_Type. Since this
1171 -- primitive may have been inherited, go back the alias chain
1172 -- until the real primitive has been found.
1174 Current_Primitive_Alias
:= Current_Primitive
;
1175 while Present
(Alias
(Current_Primitive_Alias
)) loop
1177 (Current_Primitive_Alias
1178 /= Alias
(Current_Primitive_Alias
));
1179 Current_Primitive_Alias
:= Alias
(Current_Primitive_Alias
);
1182 Current_Primitive_Spec
:=
1183 Copy_Specification
(Loc
,
1184 Spec
=> Parent
(Current_Primitive_Alias
),
1185 Object_Type
=> Designated_Type
,
1186 Stub_Type
=> Stub_Elements
.Stub_Type
);
1188 Current_Primitive_Decl
:=
1189 Make_Subprogram_Declaration
(Loc
,
1190 Specification
=> Current_Primitive_Spec
);
1192 Insert_After
(Current_Insertion_Node
, Current_Primitive_Decl
);
1193 Analyze
(Current_Primitive_Decl
);
1194 Current_Insertion_Node
:= Current_Primitive_Decl
;
1196 Possibly_Asynchronous
:=
1197 Nkind
(Current_Primitive_Spec
) = N_Procedure_Specification
1198 and then Could_Be_Asynchronous
(Current_Primitive_Spec
);
1200 Assign_Subprogram_Identifier
(
1201 Defining_Unit_Name
(Current_Primitive_Spec
),
1202 Current_Primitive_Number
,
1205 Current_Primitive_Body
:=
1206 Build_Subprogram_Calling_Stubs
1207 (Vis_Decl
=> Current_Primitive_Decl
,
1209 Build_Subprogram_Id
(Loc
,
1210 Defining_Unit_Name
(Current_Primitive_Spec
)),
1211 Asynchronous
=> Possibly_Asynchronous
,
1212 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1213 Stub_Type
=> Stub_Elements
.Stub_Type
,
1214 RACW_Type
=> Stub_Elements
.RACW_Type
);
1215 Append_To
(Decls
, Current_Primitive_Body
);
1217 -- Analyzing the body here would cause the Stub type to be
1218 -- frozen, thus preventing subsequent primitive declarations.
1219 -- For this reason, it will be analyzed later in the
1222 -- Build the receiver stubs
1225 Current_Receiver_Body
:=
1226 Specific_Build_Subprogram_Receiving_Stubs
1227 (Vis_Decl
=> Current_Primitive_Decl
,
1228 Asynchronous
=> Possibly_Asynchronous
,
1229 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1230 Stub_Type
=> Stub_Elements
.Stub_Type
,
1231 RACW_Type
=> Stub_Elements
.RACW_Type
,
1232 Parent_Primitive
=> Current_Primitive
);
1234 Current_Receiver
:= Defining_Unit_Name
(
1235 Specification
(Current_Receiver_Body
));
1237 Append_To
(Decls
, Current_Receiver_Body
);
1239 -- Add a case alternative to the receiver
1241 Append_To
(RPC_Receiver_Case_Alternatives
,
1242 Make_Case_Statement_Alternative
(Loc
,
1243 Discrete_Choices
=> New_List
(
1244 Make_Integer_Literal
(Loc
, Current_Primitive_Number
)),
1246 Statements
=> New_List
(
1247 Make_Procedure_Call_Statement
(Loc
,
1249 New_Occurrence_Of
(Current_Receiver
, Loc
),
1250 Parameter_Associations
=> New_List
(
1251 New_Occurrence_Of
(RPC_Receiver_Request
, Loc
))))));
1254 -- Increment the index of current primitive
1256 Current_Primitive_Number
:= Current_Primitive_Number
+ 1;
1259 Next_Elmt
(Current_Primitive_Elmt
);
1263 -- Build the case statement and the heart of the subprogram
1266 Append_To
(RPC_Receiver_Case_Alternatives
,
1267 Make_Case_Statement_Alternative
(Loc
,
1268 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1269 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
1271 Append_To
(RPC_Receiver_Statements
,
1272 Make_Case_Statement
(Loc
,
1274 New_Occurrence_Of
(RPC_Receiver_Subp_Index
, Loc
),
1275 Alternatives
=> RPC_Receiver_Case_Alternatives
));
1277 Append_To
(Decls
, RPC_Receiver_Decl
);
1279 -- The RPC receiver body should not be the completion of the
1280 -- declaration recorded in the stub structure, because then the
1281 -- occurrences of the formal parameters within the body should
1282 -- refer to the entities from the declaration, not from the
1283 -- completion, to which we do not have easy access. Instead, the
1284 -- RPC receiver body acts as its own declaration, and the RPC
1285 -- receiver declaration is completed by a renaming-as-body.
1288 Make_Subprogram_Renaming_Declaration
(Loc
,
1290 Copy_Specification
(Loc
,
1291 Specification
(Stub_Elements
.RPC_Receiver_Decl
)),
1292 Name
=> New_Occurrence_Of
(RPC_Receiver
, Loc
)));
1295 -- Do not analyze RPC receiver at this stage since it will otherwise
1296 -- reference subprograms that have not been analyzed yet. It will
1297 -- be analyzed in the regular flow.
1299 end Add_RACW_Primitive_Declarations_And_Bodies
;
1301 -----------------------------
1302 -- Add_RAS_Dereference_TSS --
1303 -----------------------------
1305 procedure Add_RAS_Dereference_TSS
(N
: Node_Id
) is
1306 Loc
: constant Source_Ptr
:= Sloc
(N
);
1308 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
1310 RAS_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
1311 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(RAS_Type
);
1312 RACW_Type
: constant Entity_Id
:= Underlying_RACW_Type
(RAS_Type
);
1313 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
1315 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
1316 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
1318 RACW_Primitive_Name
: Node_Id
;
1320 Proc
: constant Entity_Id
:=
1321 Make_Defining_Identifier
(Loc
,
1322 Chars
=> Make_TSS_Name
(RAS_Type
, TSS_RAS_Dereference
));
1324 Proc_Spec
: Node_Id
;
1325 Param_Specs
: List_Id
;
1326 Param_Assoc
: constant List_Id
:= New_List
;
1327 Stmts
: constant List_Id
:= New_List
;
1329 RAS_Parameter
: constant Entity_Id
:=
1330 Make_Defining_Identifier
(Loc
,
1331 Chars
=> New_Internal_Name
('P'));
1333 Is_Function
: constant Boolean :=
1334 Nkind
(Type_Def
) = N_Access_Function_Definition
;
1336 Is_Degenerate
: Boolean;
1337 -- Set to True if the subprogram_specification for this RAS has
1338 -- an anonymous access parameter (see Process_Remote_AST_Declaration).
1340 Spec
: constant Node_Id
:= Type_Def
;
1342 Current_Parameter
: Node_Id
;
1344 -- Start of processing for Add_RAS_Dereference_TSS
1347 -- The Dereference TSS for a remote access-to-subprogram type
1350 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1353 -- This is called whenever a value of a RAS type is dereferenced
1355 -- First construct a list of parameter specifications:
1357 -- The first formal is the RAS values
1359 Param_Specs
:= New_List
(
1360 Make_Parameter_Specification
(Loc
,
1361 Defining_Identifier
=> RAS_Parameter
,
1364 New_Occurrence_Of
(Fat_Type
, Loc
)));
1366 -- The following formals are copied from the type declaration
1368 Is_Degenerate
:= False;
1369 Current_Parameter
:= First
(Parameter_Specifications
(Type_Def
));
1370 Parameters
: while Present
(Current_Parameter
) loop
1371 if Nkind
(Parameter_Type
(Current_Parameter
))
1372 = N_Access_Definition
1374 Is_Degenerate
:= True;
1376 Append_To
(Param_Specs
,
1377 Make_Parameter_Specification
(Loc
,
1378 Defining_Identifier
=>
1379 Make_Defining_Identifier
(Loc
,
1380 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))),
1381 In_Present
=> In_Present
(Current_Parameter
),
1382 Out_Present
=> Out_Present
(Current_Parameter
),
1384 New_Copy_Tree
(Parameter_Type
(Current_Parameter
)),
1386 New_Copy_Tree
(Expression
(Current_Parameter
))));
1388 Append_To
(Param_Assoc
,
1389 Make_Identifier
(Loc
,
1390 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))));
1392 Next
(Current_Parameter
);
1393 end loop Parameters
;
1395 if Is_Degenerate
then
1396 Prepend_To
(Param_Assoc
, New_Occurrence_Of
(RAS_Parameter
, Loc
));
1398 -- Generate a dummy body. This code will never actually be executed,
1399 -- because null is the only legal value for a degenerate RAS type.
1400 -- For legality's sake (in order to avoid generating a function
1401 -- that does not contain a return statement), we include a dummy
1402 -- recursive call on the TSS itself.
1405 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Explicit_Raise
));
1406 RACW_Primitive_Name
:= New_Occurrence_Of
(Proc
, Loc
);
1409 -- For a normal RAS type, we cast the RAS formal to the corresponding
1410 -- tagged type, and perform a dispatching call to its Call
1411 -- primitive operation.
1413 Prepend_To
(Param_Assoc
,
1414 Unchecked_Convert_To
(RACW_Type
,
1415 New_Occurrence_Of
(RAS_Parameter
, Loc
)));
1417 RACW_Primitive_Name
:= Make_Selected_Component
(Loc
,
1418 Prefix
=> Scope
(RACW_Type
),
1419 Selector_Name
=> Name_Call
);
1424 Make_Return_Statement
(Loc
,
1426 Make_Function_Call
(Loc
,
1428 RACW_Primitive_Name
,
1429 Parameter_Associations
=> Param_Assoc
)));
1433 Make_Procedure_Call_Statement
(Loc
,
1435 RACW_Primitive_Name
,
1436 Parameter_Associations
=> Param_Assoc
));
1439 -- Build the complete subprogram
1443 Make_Function_Specification
(Loc
,
1444 Defining_Unit_Name
=> Proc
,
1445 Parameter_Specifications
=> Param_Specs
,
1448 Entity
(Subtype_Mark
(Spec
)), Loc
));
1450 Set_Ekind
(Proc
, E_Function
);
1452 New_Occurrence_Of
(Entity
(Subtype_Mark
(Spec
)), Loc
));
1456 Make_Procedure_Specification
(Loc
,
1457 Defining_Unit_Name
=> Proc
,
1458 Parameter_Specifications
=> Param_Specs
);
1460 Set_Ekind
(Proc
, E_Procedure
);
1461 Set_Etype
(Proc
, Standard_Void_Type
);
1465 Make_Subprogram_Body
(Loc
,
1466 Specification
=> Proc_Spec
,
1467 Declarations
=> New_List
,
1468 Handled_Statement_Sequence
=>
1469 Make_Handled_Sequence_Of_Statements
(Loc
,
1470 Statements
=> Stmts
)));
1472 Set_TSS
(Fat_Type
, Proc
);
1473 end Add_RAS_Dereference_TSS
;
1475 -------------------------------
1476 -- Add_RAS_Proxy_And_Analyze --
1477 -------------------------------
1479 procedure Add_RAS_Proxy_And_Analyze
1482 All_Calls_Remote_E
: Entity_Id
;
1483 Proxy_Object_Addr
: out Entity_Id
)
1485 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
1487 Subp_Name
: constant Entity_Id
:=
1488 Defining_Unit_Name
(Specification
(Vis_Decl
));
1490 Pkg_Name
: constant Entity_Id
:=
1491 Make_Defining_Identifier
(Loc
,
1493 New_External_Name
(Chars
(Subp_Name
), 'P', -1));
1495 Proxy_Type
: constant Entity_Id
:=
1496 Make_Defining_Identifier
(Loc
,
1499 Related_Id
=> Chars
(Subp_Name
),
1502 Proxy_Type_Full_View
: constant Entity_Id
:=
1503 Make_Defining_Identifier
(Loc
,
1504 Chars
(Proxy_Type
));
1506 Subp_Decl_Spec
: constant Node_Id
:=
1507 Build_RAS_Primitive_Specification
1508 (Subp_Spec
=> Specification
(Vis_Decl
),
1509 Remote_Object_Type
=> Proxy_Type
);
1511 Subp_Body_Spec
: constant Node_Id
:=
1512 Build_RAS_Primitive_Specification
1513 (Subp_Spec
=> Specification
(Vis_Decl
),
1514 Remote_Object_Type
=> Proxy_Type
);
1516 Vis_Decls
: constant List_Id
:= New_List
;
1517 Pvt_Decls
: constant List_Id
:= New_List
;
1518 Actuals
: constant List_Id
:= New_List
;
1520 Perform_Call
: Node_Id
;
1523 -- type subpP is tagged limited private;
1525 Append_To
(Vis_Decls
,
1526 Make_Private_Type_Declaration
(Loc
,
1527 Defining_Identifier
=> Proxy_Type
,
1528 Tagged_Present
=> True,
1529 Limited_Present
=> True));
1531 -- [subprogram] Call
1532 -- (Self : access subpP;
1533 -- ...other-formals...)
1536 Append_To
(Vis_Decls
,
1537 Make_Subprogram_Declaration
(Loc
,
1538 Specification
=> Subp_Decl_Spec
));
1540 -- A : constant System.Address;
1542 Proxy_Object_Addr
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1544 Append_To
(Vis_Decls
,
1545 Make_Object_Declaration
(Loc
,
1546 Defining_Identifier
=>
1550 Object_Definition
=>
1551 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
1555 -- type subpP is tagged limited record
1556 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1560 Append_To
(Pvt_Decls
,
1561 Make_Full_Type_Declaration
(Loc
,
1562 Defining_Identifier
=>
1563 Proxy_Type_Full_View
,
1565 Build_Remote_Subprogram_Proxy_Type
(Loc
,
1566 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
))));
1568 -- Trick semantic analysis into swapping the public and
1569 -- full view when freezing the public view.
1571 Set_Comes_From_Source
(Proxy_Type_Full_View
, True);
1574 -- (Self : access O;
1575 -- ...other-formals...) is
1577 -- P (...other-formals...);
1581 -- (Self : access O;
1582 -- ...other-formals...)
1585 -- return F (...other-formals...);
1588 if Nkind
(Subp_Decl_Spec
) = N_Procedure_Specification
then
1590 Make_Procedure_Call_Statement
(Loc
,
1592 New_Occurrence_Of
(Subp_Name
, Loc
),
1593 Parameter_Associations
=>
1597 Make_Return_Statement
(Loc
,
1599 Make_Function_Call
(Loc
,
1601 New_Occurrence_Of
(Subp_Name
, Loc
),
1602 Parameter_Associations
=>
1606 Formal
:= First
(Parameter_Specifications
(Subp_Decl_Spec
));
1607 pragma Assert
(Present
(Formal
));
1610 exit when No
(Formal
);
1612 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1615 -- O : aliased subpP;
1617 Append_To
(Pvt_Decls
,
1618 Make_Object_Declaration
(Loc
,
1619 Defining_Identifier
=>
1620 Make_Defining_Identifier
(Loc
,
1624 Object_Definition
=>
1625 New_Occurrence_Of
(Proxy_Type
, Loc
)));
1627 -- A : constant System.Address := O'Address;
1629 Append_To
(Pvt_Decls
,
1630 Make_Object_Declaration
(Loc
,
1631 Defining_Identifier
=>
1632 Make_Defining_Identifier
(Loc
,
1633 Chars
(Proxy_Object_Addr
)),
1636 Object_Definition
=>
1637 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
1639 Make_Attribute_Reference
(Loc
,
1640 Prefix
=> New_Occurrence_Of
(
1641 Defining_Identifier
(Last
(Pvt_Decls
)), Loc
),
1646 Make_Package_Declaration
(Loc
,
1647 Specification
=> Make_Package_Specification
(Loc
,
1648 Defining_Unit_Name
=> Pkg_Name
,
1649 Visible_Declarations
=> Vis_Decls
,
1650 Private_Declarations
=> Pvt_Decls
,
1651 End_Label
=> Empty
)));
1652 Analyze
(Last
(Decls
));
1655 Make_Package_Body
(Loc
,
1656 Defining_Unit_Name
=>
1657 Make_Defining_Identifier
(Loc
,
1659 Declarations
=> New_List
(
1660 Make_Subprogram_Body
(Loc
,
1663 Declarations
=> New_List
,
1664 Handled_Statement_Sequence
=>
1665 Make_Handled_Sequence_Of_Statements
(Loc
,
1666 Statements
=> New_List
(Perform_Call
))))));
1667 Analyze
(Last
(Decls
));
1668 end Add_RAS_Proxy_And_Analyze
;
1670 -----------------------
1671 -- Add_RAST_Features --
1672 -----------------------
1674 procedure Add_RAST_Features
(Vis_Decl
: Node_Id
) is
1675 RAS_Type
: constant Entity_Id
:=
1676 Equivalent_Type
(Defining_Identifier
(Vis_Decl
));
1678 Spec
: constant Node_Id
:=
1679 Specification
(Unit
(Enclosing_Lib_Unit_Node
(Vis_Decl
)));
1680 Decls
: List_Id
:= Private_Declarations
(Spec
);
1683 pragma Assert
(No
(TSS
(RAS_Type
, TSS_RAS_Access
)));
1686 Decls
:= Visible_Declarations
(Spec
);
1689 Add_RAS_Dereference_TSS
(Vis_Decl
);
1690 Specific_Add_RAST_Features
(Vis_Decl
, RAS_Type
, Decls
);
1691 end Add_RAST_Features
;
1697 procedure Add_Stub_Type
1698 (Designated_Type
: Entity_Id
;
1699 RACW_Type
: Entity_Id
;
1701 Stub_Type
: out Entity_Id
;
1702 Stub_Type_Access
: out Entity_Id
;
1703 RPC_Receiver_Decl
: out Node_Id
;
1704 Existing
: out Boolean)
1706 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1708 Stub_Elements
: constant Stub_Structure
:=
1709 Stubs_Table
.Get
(Designated_Type
);
1710 Stub_Type_Decl
: Node_Id
;
1711 Stub_Type_Access_Decl
: Node_Id
;
1714 if Stub_Elements
/= Empty_Stub_Structure
then
1715 Stub_Type
:= Stub_Elements
.Stub_Type
;
1716 Stub_Type_Access
:= Stub_Elements
.Stub_Type_Access
;
1717 RPC_Receiver_Decl
:= Stub_Elements
.RPC_Receiver_Decl
;
1724 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
1726 Make_Defining_Identifier
(Loc
,
1728 Related_Id
=> Chars
(Stub_Type
),
1731 Specific_Build_Stub_Type
(
1732 RACW_Type
, Stub_Type
,
1733 Stub_Type_Decl
, RPC_Receiver_Decl
);
1735 Stub_Type_Access_Decl
:=
1736 Make_Full_Type_Declaration
(Loc
,
1737 Defining_Identifier
=> Stub_Type_Access
,
1739 Make_Access_To_Object_Definition
(Loc
,
1740 All_Present
=> True,
1741 Subtype_Indication
=> New_Occurrence_Of
(Stub_Type
, Loc
)));
1743 Append_To
(Decls
, Stub_Type_Decl
);
1744 Analyze
(Last
(Decls
));
1745 Append_To
(Decls
, Stub_Type_Access_Decl
);
1746 Analyze
(Last
(Decls
));
1748 -- This is in no way a type derivation, but we fake it to make
1749 -- sure that the dispatching table gets built with the corresponding
1750 -- primitive operations at the right place.
1752 Derive_Subprograms
(Parent_Type
=> Designated_Type
,
1753 Derived_Type
=> Stub_Type
);
1755 if Present
(RPC_Receiver_Decl
) then
1756 Append_To
(Decls
, RPC_Receiver_Decl
);
1758 RPC_Receiver_Decl
:= Last
(Decls
);
1761 Stubs_Table
.Set
(Designated_Type
,
1762 (Stub_Type
=> Stub_Type
,
1763 Stub_Type_Access
=> Stub_Type_Access
,
1764 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1765 RACW_Type
=> RACW_Type
));
1768 ----------------------------------
1769 -- Assign_Subprogram_Identifier --
1770 ----------------------------------
1772 procedure Assign_Subprogram_Identifier
1777 N
: constant Name_Id
:= Chars
(Def
);
1779 Overload_Order
: constant Int
:=
1780 Overload_Counter_Table
.Get
(N
) + 1;
1783 Overload_Counter_Table
.Set
(N
, Overload_Order
);
1785 Get_Name_String
(N
);
1787 -- Homonym handling: as in Exp_Dbug, but much simpler,
1788 -- because the only entities for which we have to generate
1789 -- names here need only to be disambiguated within their
1792 if Overload_Order
> 1 then
1793 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 2) := "__";
1794 Name_Len
:= Name_Len
+ 2;
1795 Add_Nat_To_Name_Buffer
(Overload_Order
);
1798 Id
:= String_From_Name_Buffer
;
1799 Subprogram_Identifier_Table
.Set
(Def
,
1800 Subprogram_Identifiers
'(Str_Identifier => Id, Int_Identifier => Spn));
1801 end Assign_Subprogram_Identifier;
1803 ------------------------------
1804 -- Build_Get_Unique_RP_Call --
1805 ------------------------------
1807 function Build_Get_Unique_RP_Call
1809 Pointer : Entity_Id;
1810 Stub_Type : Entity_Id) return List_Id
1814 Make_Procedure_Call_Statement (Loc,
1816 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
1817 Parameter_Associations => New_List (
1818 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
1819 New_Occurrence_Of (Pointer, Loc)))),
1821 Make_Assignment_Statement (Loc,
1823 Make_Selected_Component (Loc,
1825 New_Occurrence_Of (Pointer, Loc),
1827 New_Occurrence_Of (Tag_Component
1828 (Designated_Type (Etype (Pointer))), Loc)),
1830 Make_Attribute_Reference (Loc,
1832 New_Occurrence_Of (Stub_Type, Loc),
1836 -- Note: The assignment to Pointer._Tag is safe here because
1837 -- we carefully ensured that Stub_Type has exactly the same layout
1838 -- as System.Partition_Interface.RACW_Stub_Type.
1840 end Build_Get_Unique_RP_Call;
1842 -----------------------------------
1843 -- Build_Ordered_Parameters_List --
1844 -----------------------------------
1846 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
1847 Constrained_List : List_Id;
1848 Unconstrained_List : List_Id;
1849 Current_Parameter : Node_Id;
1851 First_Parameter : Node_Id;
1852 For_RAS : Boolean := False;
1855 if not Present (Parameter_Specifications (Spec)) then
1859 Constrained_List := New_List;
1860 Unconstrained_List := New_List;
1861 First_Parameter := First (Parameter_Specifications (Spec));
1863 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
1864 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
1869 -- Loop through the parameters and add them to the right list
1871 Current_Parameter := First_Parameter;
1872 while Present (Current_Parameter) loop
1873 if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
1875 Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
1877 Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
1878 and then not (For_RAS and then Current_Parameter = First_Parameter)
1880 Append_To (Constrained_List, New_Copy (Current_Parameter));
1882 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
1885 Next (Current_Parameter);
1888 -- Unconstrained parameters are returned first
1890 Append_List_To (Unconstrained_List, Constrained_List);
1892 return Unconstrained_List;
1893 end Build_Ordered_Parameters_List;
1895 ----------------------------------
1896 -- Build_Passive_Partition_Stub --
1897 ----------------------------------
1899 procedure Build_Passive_Partition_Stub (U : Node_Id) is
1901 Pkg_Name : String_Id;
1904 Loc : constant Source_Ptr := Sloc (U);
1907 -- Verify that the implementation supports distribution, by accessing
1908 -- a type defined in the proper version of system.rpc
1911 Dist_OK : Entity_Id;
1912 pragma Warnings (Off, Dist_OK);
1914 Dist_OK := RTE (RE_Params_Stream_Type);
1917 -- Use body if present, spec otherwise
1919 if Nkind (U) = N_Package_Declaration then
1920 Pkg_Spec := Specification (U);
1921 L := Visible_Declarations (Pkg_Spec);
1923 Pkg_Spec := Parent (Corresponding_Spec (U));
1924 L := Declarations (U);
1927 Get_Library_Unit_Name_String (Pkg_Spec);
1928 Pkg_Name := String_From_Name_Buffer;
1930 Make_Procedure_Call_Statement (Loc,
1932 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
1933 Parameter_Associations => New_List (
1934 Make_String_Literal (Loc, Pkg_Name),
1935 Make_Attribute_Reference (Loc,
1937 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
1942 end Build_Passive_Partition_Stub;
1944 --------------------------------------
1945 -- Build_RPC_Receiver_Specification --
1946 --------------------------------------
1948 function Build_RPC_Receiver_Specification
1949 (RPC_Receiver : Entity_Id;
1950 Request_Parameter : Entity_Id) return Node_Id
1952 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
1955 Make_Procedure_Specification (Loc,
1956 Defining_Unit_Name => RPC_Receiver,
1957 Parameter_Specifications => New_List (
1958 Make_Parameter_Specification (Loc,
1959 Defining_Identifier => Request_Parameter,
1961 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
1962 end Build_RPC_Receiver_Specification;
1964 ----------------------------------------
1965 -- Build_Remote_Subprogram_Proxy_Type --
1966 ----------------------------------------
1968 function Build_Remote_Subprogram_Proxy_Type
1970 ACR_Expression : Node_Id) return Node_Id
1974 Make_Record_Definition (Loc,
1975 Tagged_Present => True,
1976 Limited_Present => True,
1978 Make_Component_List (Loc,
1980 Component_Items => New_List (
1981 Make_Component_Declaration (Loc,
1982 Defining_Identifier =>
1983 Make_Defining_Identifier (Loc,
1984 Name_All_Calls_Remote),
1985 Component_Definition =>
1986 Make_Component_Definition (Loc,
1987 Subtype_Indication =>
1988 New_Occurrence_Of (Standard_Boolean, Loc)),
1992 Make_Component_Declaration (Loc,
1993 Defining_Identifier =>
1994 Make_Defining_Identifier (Loc,
1996 Component_Definition =>
1997 Make_Component_Definition (Loc,
1998 Subtype_Indication =>
1999 New_Occurrence_Of (RTE (RE_Address), Loc)),
2001 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2003 Make_Component_Declaration (Loc,
2004 Defining_Identifier =>
2005 Make_Defining_Identifier (Loc,
2007 Component_Definition =>
2008 Make_Component_Definition (Loc,
2009 Subtype_Indication =>
2010 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2011 end Build_Remote_Subprogram_Proxy_Type;
2013 ------------------------------------
2014 -- Build_Subprogram_Calling_Stubs --
2015 ------------------------------------
2017 function Build_Subprogram_Calling_Stubs
2018 (Vis_Decl : Node_Id;
2020 Asynchronous : Boolean;
2021 Dynamically_Asynchronous : Boolean := False;
2022 Stub_Type : Entity_Id := Empty;
2023 RACW_Type : Entity_Id := Empty;
2024 Locator : Entity_Id := Empty;
2025 New_Name : Name_Id := No_Name) return Node_Id
2027 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2029 Decls : constant List_Id := New_List;
2030 Statements : constant List_Id := New_List;
2032 Subp_Spec : Node_Id;
2033 -- The specification of the body
2035 Controlling_Parameter : Entity_Id := Empty;
2037 Asynchronous_Expr : Node_Id := Empty;
2039 RCI_Locator : Entity_Id;
2041 Spec_To_Use : Node_Id;
2043 procedure Insert_Partition_Check (Parameter : Node_Id);
2044 -- Check that the parameter has been elaborated on the same partition
2045 -- than the controlling parameter (E.4(19)).
2047 ----------------------------
2048 -- Insert_Partition_Check --
2049 ----------------------------
2051 procedure Insert_Partition_Check (Parameter : Node_Id) is
2052 Parameter_Entity : constant Entity_Id :=
2053 Defining_Identifier (Parameter);
2055 -- The expression that will be built is of the form:
2057 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2058 -- raise Constraint_Error;
2061 -- We do not check that Parameter is in Stub_Type since such a check
2062 -- has been inserted at the point of call already (a tag check since
2063 -- we have multiple controlling operands).
2066 Make_Raise_Constraint_Error (Loc,
2070 Make_Function_Call (Loc,
2072 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2073 Parameter_Associations =>
2075 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2076 New_Occurrence_Of (Parameter_Entity, Loc)),
2077 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2078 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2079 Reason => CE_Partition_Check_Failed));
2080 end Insert_Partition_Check;
2082 -- Start of processing for Build_Subprogram_Calling_Stubs
2085 Subp_Spec := Copy_Specification (Loc,
2086 Spec => Specification (Vis_Decl),
2087 New_Name => New_Name);
2089 if Locator = Empty then
2090 RCI_Locator := RCI_Cache;
2091 Spec_To_Use := Specification (Vis_Decl);
2093 RCI_Locator := Locator;
2094 Spec_To_Use := Subp_Spec;
2097 -- Find a controlling argument if we have a stub type. Also check
2098 -- if this subprogram can be made asynchronous.
2100 if Present (Stub_Type)
2101 and then Present (Parameter_Specifications (Spec_To_Use))
2104 Current_Parameter : Node_Id :=
2105 First (Parameter_Specifications
2108 while Present (Current_Parameter) loop
2110 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2112 if Controlling_Parameter = Empty then
2113 Controlling_Parameter :=
2114 Defining_Identifier (Current_Parameter);
2116 Insert_Partition_Check (Current_Parameter);
2120 Next (Current_Parameter);
2125 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2127 if Dynamically_Asynchronous then
2128 Asynchronous_Expr := Make_Selected_Component (Loc,
2129 Prefix => Controlling_Parameter,
2130 Selector_Name => Name_Asynchronous);
2133 Specific_Build_General_Calling_Stubs
2135 Statements => Statements,
2136 Target => Specific_Build_Stub_Target (Loc,
2137 Decls, RCI_Locator, Controlling_Parameter),
2138 Subprogram_Id => Subp_Id,
2139 Asynchronous => Asynchronous_Expr,
2140 Is_Known_Asynchronous => Asynchronous
2141 and then not Dynamically_Asynchronous,
2142 Is_Known_Non_Asynchronous
2144 and then not Dynamically_Asynchronous,
2145 Is_Function => Nkind (Spec_To_Use) =
2146 N_Function_Specification,
2147 Spec => Spec_To_Use,
2148 Stub_Type => Stub_Type,
2149 RACW_Type => RACW_Type,
2152 RCI_Calling_Stubs_Table.Set
2153 (Defining_Unit_Name (Specification (Vis_Decl)),
2154 Defining_Unit_Name (Spec_To_Use));
2157 Make_Subprogram_Body (Loc,
2158 Specification => Subp_Spec,
2159 Declarations => Decls,
2160 Handled_Statement_Sequence =>
2161 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2162 end Build_Subprogram_Calling_Stubs;
2164 -------------------------
2165 -- Build_Subprogram_Id --
2166 -------------------------
2168 function Build_Subprogram_Id
2170 E : Entity_Id) return Node_Id
2173 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2174 end Build_Subprogram_Id;
2176 ------------------------
2177 -- Copy_Specification --
2178 ------------------------
2180 function Copy_Specification
2183 Object_Type : Entity_Id := Empty;
2184 Stub_Type : Entity_Id := Empty;
2185 New_Name : Name_Id := No_Name) return Node_Id
2187 Parameters : List_Id := No_List;
2189 Current_Parameter : Node_Id;
2190 Current_Identifier : Entity_Id;
2191 Current_Type : Node_Id;
2192 Current_Etype : Entity_Id;
2194 Name_For_New_Spec : Name_Id;
2196 New_Identifier : Entity_Id;
2198 -- Comments needed in body below ???
2201 if New_Name = No_Name then
2202 pragma Assert (Nkind (Spec) = N_Function_Specification
2203 or else Nkind (Spec) = N_Procedure_Specification);
2205 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2207 Name_For_New_Spec := New_Name;
2210 if Present (Parameter_Specifications (Spec)) then
2211 Parameters := New_List;
2212 Current_Parameter := First (Parameter_Specifications (Spec));
2213 while Present (Current_Parameter) loop
2214 Current_Identifier := Defining_Identifier (Current_Parameter);
2215 Current_Type := Parameter_Type (Current_Parameter);
2217 if Nkind (Current_Type) = N_Access_Definition then
2218 Current_Etype := Entity (Subtype_Mark (Current_Type));
2220 if Present (Object_Type) then
2222 Root_Type (Current_Etype) = Root_Type (Object_Type));
2224 Make_Access_Definition (Loc,
2225 Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
2228 Make_Access_Definition (Loc,
2230 New_Occurrence_Of (Current_Etype, Loc));
2234 Current_Etype := Entity (Current_Type);
2236 if Present (Object_Type)
2237 and then Current_Etype = Object_Type
2239 Current_Type := New_Occurrence_Of (Stub_Type, Loc);
2241 Current_Type := New_Occurrence_Of (Current_Etype, Loc);
2245 New_Identifier := Make_Defining_Identifier (Loc,
2246 Chars (Current_Identifier));
2248 Append_To (Parameters,
2249 Make_Parameter_Specification (Loc,
2250 Defining_Identifier => New_Identifier,
2251 Parameter_Type => Current_Type,
2252 In_Present => In_Present (Current_Parameter),
2253 Out_Present => Out_Present (Current_Parameter),
2255 New_Copy_Tree (Expression (Current_Parameter))));
2257 -- For a regular formal parameter (that needs to be marshalled
2258 -- in the context of remote calls), set the Etype now, because
2259 -- marshalling processing might need it.
2261 if Is_Entity_Name (Current_Type) then
2262 Set_Etype (New_Identifier, Entity (Current_Type));
2264 -- Current_Type is an access definition, special processing
2265 -- (not requiring etype) will occur for marshalling.
2271 Next (Current_Parameter);
2275 case Nkind (Spec) is
2277 when N_Function_Specification | N_Access_Function_Definition =>
2279 Make_Function_Specification (Loc,
2280 Defining_Unit_Name =>
2281 Make_Defining_Identifier (Loc,
2282 Chars => Name_For_New_Spec),
2283 Parameter_Specifications => Parameters,
2285 New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
2287 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2289 Make_Procedure_Specification (Loc,
2290 Defining_Unit_Name =>
2291 Make_Defining_Identifier (Loc,
2292 Chars => Name_For_New_Spec),
2293 Parameter_Specifications => Parameters);
2296 raise Program_Error;
2298 end Copy_Specification;
2300 ---------------------------
2301 -- Could_Be_Asynchronous --
2302 ---------------------------
2304 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2305 Current_Parameter : Node_Id;
2308 if Present (Parameter_Specifications (Spec)) then
2309 Current_Parameter := First (Parameter_Specifications (Spec));
2310 while Present (Current_Parameter) loop
2311 if Out_Present (Current_Parameter) then
2315 Next (Current_Parameter);
2320 end Could_Be_Asynchronous;
2322 ---------------------------
2323 -- Declare_Create_NVList --
2324 ---------------------------
2326 procedure Declare_Create_NVList
2334 Make_Object_Declaration (Loc,
2335 Defining_Identifier => NVList,
2336 Aliased_Present => False,
2337 Object_Definition =>
2338 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2341 Make_Procedure_Call_Statement (Loc,
2343 New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2344 Parameter_Associations => New_List (
2345 New_Occurrence_Of (NVList, Loc))));
2346 end Declare_Create_NVList;
2348 ---------------------------------------------
2349 -- Expand_All_Calls_Remote_Subprogram_Call --
2350 ---------------------------------------------
2352 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2353 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2354 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2355 Loc : constant Source_Ptr := Sloc (N);
2356 RCI_Locator : Node_Id;
2357 RCI_Cache : Entity_Id;
2358 Calling_Stubs : Node_Id;
2359 E_Calling_Stubs : Entity_Id;
2362 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2364 if E_Calling_Stubs = Empty then
2365 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
2367 if RCI_Cache = Empty then
2370 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2371 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
2373 -- The RCI_Locator package is inserted at the top level in the
2374 -- current unit, and must appear in the proper scope, so that it
2375 -- is not prematurely removed by the GCC back-end.
2378 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2381 if Ekind (Scop) = E_Package_Body then
2382 New_Scope (Spec_Entity (Scop));
2384 elsif Ekind (Scop) = E_Subprogram_Body then
2386 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2392 Analyze (RCI_Locator);
2396 RCI_Cache := Defining_Unit_Name (RCI_Locator);
2399 RCI_Locator := Parent (RCI_Cache);
2402 Calling_Stubs := Build_Subprogram_Calling_Stubs
2403 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2405 Build_Subprogram_Id (Loc, Called_Subprogram),
2406 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2408 Is_Asynchronous (Called_Subprogram),
2409 Locator => RCI_Cache,
2410 New_Name => New_Internal_Name ('S
'));
2411 Insert_After (RCI_Locator, Calling_Stubs);
2412 Analyze (Calling_Stubs);
2413 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2416 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2417 end Expand_All_Calls_Remote_Subprogram_Call;
2419 ---------------------------------
2420 -- Expand_Calling_Stubs_Bodies --
2421 ---------------------------------
2423 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2424 Spec : constant Node_Id := Specification (Unit_Node);
2425 Decls : constant List_Id := Visible_Declarations (Spec);
2427 New_Scope (Scope_Of_Spec (Spec));
2428 Add_Calling_Stubs_To_Declarations
2429 (Specification (Unit_Node), Decls);
2431 end Expand_Calling_Stubs_Bodies;
2433 -----------------------------------
2434 -- Expand_Receiving_Stubs_Bodies --
2435 -----------------------------------
2437 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2443 if Nkind (Unit_Node) = N_Package_Declaration then
2444 Spec := Specification (Unit_Node);
2445 Decls := Visible_Declarations (Spec);
2446 New_Scope (Scope_Of_Spec (Spec));
2447 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls);
2451 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2452 Decls := Declarations (Unit_Node);
2453 New_Scope (Scope_Of_Spec (Unit_Node));
2455 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Temp);
2456 Insert_List_Before (First (Decls), Temp);
2460 end Expand_Receiving_Stubs_Bodies;
2462 --------------------
2463 -- GARLIC_Support --
2464 --------------------
2466 package body GARLIC_Support is
2468 -- Local subprograms
2470 procedure Add_RACW_Read_Attribute
2471 (RACW_Type : Entity_Id;
2472 Stub_Type : Entity_Id;
2473 Stub_Type_Access : Entity_Id;
2474 Declarations : List_Id);
2475 -- Add Read attribute in Decls for the RACW type. The Read attribute
2476 -- is added right after the RACW_Type declaration while the body is
2477 -- inserted after Declarations.
2479 procedure Add_RACW_Write_Attribute
2480 (RACW_Type : Entity_Id;
2481 Stub_Type : Entity_Id;
2482 Stub_Type_Access : Entity_Id;
2483 RPC_Receiver : Node_Id;
2484 Declarations : List_Id);
2485 -- Same thing for the Write attribute
2487 function Stream_Parameter return Node_Id;
2488 function Result return Node_Id;
2489 function Object return Node_Id renames Result;
2490 -- Functions to create occurrences of the formal parameter names of
2491 -- the 'Read
and 'Write attributes.
2494 -- Shared source location used by Add_{Read,Write}_Read_Attribute
2495 -- and their ancillary subroutines (set on entry by Add_RACW_Features).
2497 procedure Add_RAS_Access_TSS (N : Node_Id);
2498 -- Add a subprogram body for RAS Access TSS
2500 -----------------------
2501 -- Add_RACW_Features --
2502 -----------------------
2504 procedure Add_RACW_Features
2505 (RACW_Type : Entity_Id;
2506 Stub_Type : Entity_Id;
2507 Stub_Type_Access : Entity_Id;
2508 RPC_Receiver_Decl : Node_Id;
2509 Declarations : List_Id)
2511 RPC_Receiver : Node_Id;
2512 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2515 Loc := Sloc (RACW_Type);
2519 -- For a RAS, the RPC receiver is that of the RCI unit,
2520 -- not that of the corresponding distributed object type.
2521 -- We retrieve its address from the local proxy object.
2523 RPC_Receiver := Make_Selected_Component (Loc,
2525 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2526 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2529 RPC_Receiver := Make_Attribute_Reference (Loc,
2530 Prefix => New_Occurrence_Of (
2531 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2532 Attribute_Name => Name_Address);
2535 Add_RACW_Write_Attribute (
2542 Add_RACW_Read_Attribute (
2547 end Add_RACW_Features;
2549 -----------------------------
2550 -- Add_RACW_Read_Attribute --
2551 -----------------------------
2553 procedure Add_RACW_Read_Attribute
2554 (RACW_Type : Entity_Id;
2555 Stub_Type : Entity_Id;
2556 Stub_Type_Access : Entity_Id;
2557 Declarations : List_Id)
2559 Proc_Decl : Node_Id;
2560 Attr_Decl : Node_Id;
2562 Body_Node : Node_Id;
2565 Statements : List_Id;
2566 Local_Statements : List_Id;
2567 Remote_Statements : List_Id;
2568 -- Various parts of the procedure
2570 Procedure_Name : constant Name_Id :=
2571 New_Internal_Name ('R
');
2572 Source_Partition : constant Entity_Id :=
2573 Make_Defining_Identifier
2574 (Loc, New_Internal_Name ('P
'));
2575 Source_Receiver : constant Entity_Id :=
2576 Make_Defining_Identifier
2577 (Loc, New_Internal_Name ('S
'));
2578 Source_Address : constant Entity_Id :=
2579 Make_Defining_Identifier
2580 (Loc, New_Internal_Name ('P
'));
2581 Local_Stub : constant Entity_Id :=
2582 Make_Defining_Identifier
2583 (Loc, New_Internal_Name ('L
'));
2584 Stubbed_Result : constant Entity_Id :=
2585 Make_Defining_Identifier
2586 (Loc, New_Internal_Name ('S
'));
2587 Asynchronous_Flag : constant Entity_Id :=
2588 Asynchronous_Flags_Table.Get (RACW_Type);
2589 pragma Assert (Present (Asynchronous_Flag));
2591 -- Start of processing for Add_RACW_Read_Attribute
2594 -- Generate object declarations
2597 Make_Object_Declaration (Loc,
2598 Defining_Identifier => Source_Partition,
2599 Object_Definition =>
2600 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
2602 Make_Object_Declaration (Loc,
2603 Defining_Identifier => Source_Receiver,
2604 Object_Definition =>
2605 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2607 Make_Object_Declaration (Loc,
2608 Defining_Identifier => Source_Address,
2609 Object_Definition =>
2610 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2612 Make_Object_Declaration (Loc,
2613 Defining_Identifier => Local_Stub,
2614 Aliased_Present => True,
2615 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
2617 Make_Object_Declaration (Loc,
2618 Defining_Identifier => Stubbed_Result,
2619 Object_Definition =>
2620 New_Occurrence_Of (Stub_Type_Access, Loc),
2622 Make_Attribute_Reference (Loc,
2624 New_Occurrence_Of (Local_Stub, Loc),
2626 Name_Unchecked_Access)));
2628 -- Read the source Partition_ID and RPC_Receiver from incoming stream
2630 Statements := New_List (
2631 Make_Attribute_Reference (Loc,
2633 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
2634 Attribute_Name => Name_Read,
2635 Expressions => New_List (
2637 New_Occurrence_Of (Source_Partition, Loc))),
2639 Make_Attribute_Reference (Loc,
2641 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2644 Expressions => New_List (
2646 New_Occurrence_Of (Source_Receiver, Loc))),
2648 Make_Attribute_Reference (Loc,
2650 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2653 Expressions => New_List (
2655 New_Occurrence_Of (Source_Address, Loc))));
2657 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
2659 Set_Etype (Stubbed_Result, Stub_Type_Access);
2661 -- If the Address is Null_Address, then return a null object
2663 Append_To (Statements,
2664 Make_Implicit_If_Statement (RACW_Type,
2667 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
2668 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
2669 Then_Statements => New_List (
2670 Make_Assignment_Statement (Loc,
2672 Expression => Make_Null (Loc)),
2673 Make_Return_Statement (Loc))));
2675 -- If the RACW denotes an object created on the current partition,
2676 -- Local_Statements will be executed. The real object will be used.
2678 Local_Statements := New_List (
2679 Make_Assignment_Statement (Loc,
2682 Unchecked_Convert_To (RACW_Type,
2683 OK_Convert_To (RTE (RE_Address),
2684 New_Occurrence_Of (Source_Address, Loc)))));
2686 -- If the object is located on another partition, then a stub object
2687 -- will be created with all the information needed to rebuild the
2688 -- real object at the other end.
2690 Remote_Statements := New_List (
2692 Make_Assignment_Statement (Loc,
2693 Name => Make_Selected_Component (Loc,
2694 Prefix => Stubbed_Result,
2695 Selector_Name => Name_Origin),
2697 New_Occurrence_Of (Source_Partition, Loc)),
2699 Make_Assignment_Statement (Loc,
2700 Name => Make_Selected_Component (Loc,
2701 Prefix => Stubbed_Result,
2702 Selector_Name => Name_Receiver),
2704 New_Occurrence_Of (Source_Receiver, Loc)),
2706 Make_Assignment_Statement (Loc,
2707 Name => Make_Selected_Component (Loc,
2708 Prefix => Stubbed_Result,
2709 Selector_Name => Name_Addr),
2711 New_Occurrence_Of (Source_Address, Loc)));
2713 Append_To (Remote_Statements,
2714 Make_Assignment_Statement (Loc,
2715 Name => Make_Selected_Component (Loc,
2716 Prefix => Stubbed_Result,
2717 Selector_Name => Name_Asynchronous),
2719 New_Occurrence_Of (Asynchronous_Flag, Loc)));
2721 Append_List_To (Remote_Statements,
2722 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
2723 -- ??? Issue with asynchronous calls here: the Asynchronous
2724 -- flag is set on the stub type if, and only if, the RACW type
2725 -- has a pragma Asynchronous. This is incorrect for RACWs that
2726 -- implement RAS types, because in that case the /designated
2727 -- subprogram/ (not the type) might be asynchronous, and
2728 -- that causes the stub to need to be asynchronous too.
2729 -- A solution is to transport a RAS as a struct containing
2730 -- a RACW and an asynchronous flag, and to properly alter
2731 -- the Asynchronous component in the stub type in the RAS's
2734 Append_To (Remote_Statements,
2735 Make_Assignment_Statement (Loc,
2737 Expression => Unchecked_Convert_To (RACW_Type,
2738 New_Occurrence_Of (Stubbed_Result, Loc))));
2740 -- Distinguish between the local and remote cases, and execute the
2741 -- appropriate piece of code.
2743 Append_To (Statements,
2744 Make_Implicit_If_Statement (RACW_Type,
2748 Make_Function_Call (Loc,
2749 Name => New_Occurrence_Of (
2750 RTE (RE_Get_Local_Partition_Id), Loc)),
2751 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
2752 Then_Statements => Local_Statements,
2753 Else_Statements => Remote_Statements));
2755 Build_Stream_Procedure
2756 (Loc, RACW_Type, Body_Node,
2757 Make_Defining_Identifier (Loc, Procedure_Name),
2758 Statements, Outp => True);
2759 Set_Declarations (Body_Node, Decls);
2761 Proc_Decl := Make_Subprogram_Declaration (Loc,
2762 Copy_Specification (Loc, Specification (Body_Node)));
2765 Make_Attribute_Definition_Clause (Loc,
2766 Name => New_Occurrence_Of (RACW_Type, Loc),
2770 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
2772 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
2773 Insert_After (Proc_Decl, Attr_Decl);
2774 Append_To (Declarations, Body_Node);
2775 end Add_RACW_Read_Attribute;
2777 ------------------------------
2778 -- Add_RACW_Write_Attribute --
2779 ------------------------------
2781 procedure Add_RACW_Write_Attribute
2782 (RACW_Type : Entity_Id;
2783 Stub_Type : Entity_Id;
2784 Stub_Type_Access : Entity_Id;
2785 RPC_Receiver : Node_Id;
2786 Declarations : List_Id)
2788 Body_Node : Node_Id;
2789 Proc_Decl : Node_Id;
2790 Attr_Decl : Node_Id;
2792 Statements : List_Id;
2793 Local_Statements : List_Id;
2794 Remote_Statements : List_Id;
2795 Null_Statements : List_Id;
2797 Procedure_Name : constant Name_Id := New_Internal_Name ('R
');
2800 -- Build the code fragment corresponding to the marshalling of a
2803 Local_Statements := New_List (
2805 Pack_Entity_Into_Stream_Access (Loc,
2806 Stream => Stream_Parameter,
2807 Object => RTE (RE_Get_Local_Partition_Id)),
2809 Pack_Node_Into_Stream_Access (Loc,
2810 Stream => Stream_Parameter,
2811 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
2812 Etyp => RTE (RE_Unsigned_64)),
2814 Pack_Node_Into_Stream_Access (Loc,
2815 Stream => Stream_Parameter,
2816 Object => OK_Convert_To (RTE (RE_Unsigned_64),
2817 Make_Attribute_Reference (Loc,
2819 Make_Explicit_Dereference (Loc,
2821 Attribute_Name => Name_Address)),
2822 Etyp => RTE (RE_Unsigned_64)));
2824 -- Build the code fragment corresponding to the marshalling of
2827 Remote_Statements := New_List (
2829 Pack_Node_Into_Stream_Access (Loc,
2830 Stream => Stream_Parameter,
2832 Make_Selected_Component (Loc,
2833 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2836 Make_Identifier (Loc, Name_Origin)),
2837 Etyp => RTE (RE_Partition_ID)),
2839 Pack_Node_Into_Stream_Access (Loc,
2840 Stream => Stream_Parameter,
2842 Make_Selected_Component (Loc,
2843 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2846 Make_Identifier (Loc, Name_Receiver)),
2847 Etyp => RTE (RE_Unsigned_64)),
2849 Pack_Node_Into_Stream_Access (Loc,
2850 Stream => Stream_Parameter,
2852 Make_Selected_Component (Loc,
2853 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2856 Make_Identifier (Loc, Name_Addr)),
2857 Etyp => RTE (RE_Unsigned_64)));
2859 -- Build code fragment corresponding to marshalling of a null object
2861 Null_Statements := New_List (
2863 Pack_Entity_Into_Stream_Access (Loc,
2864 Stream => Stream_Parameter,
2865 Object => RTE (RE_Get_Local_Partition_Id)),
2867 Pack_Node_Into_Stream_Access (Loc,
2868 Stream => Stream_Parameter,
2869 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
2870 Etyp => RTE (RE_Unsigned_64)),
2872 Pack_Node_Into_Stream_Access (Loc,
2873 Stream => Stream_Parameter,
2874 Object => Make_Integer_Literal (Loc, Uint_0),
2875 Etyp => RTE (RE_Unsigned_64)));
2877 Statements := New_List (
2878 Make_Implicit_If_Statement (RACW_Type,
2881 Left_Opnd => Object,
2882 Right_Opnd => Make_Null (Loc)),
2883 Then_Statements => Null_Statements,
2884 Elsif_Parts => New_List (
2885 Make_Elsif_Part (Loc,
2889 Make_Attribute_Reference (Loc,
2891 Attribute_Name => Name_Tag),
2893 Make_Attribute_Reference (Loc,
2894 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2895 Attribute_Name => Name_Tag)),
2896 Then_Statements => Remote_Statements)),
2897 Else_Statements => Local_Statements));
2899 Build_Stream_Procedure
2900 (Loc, RACW_Type, Body_Node,
2901 Make_Defining_Identifier (Loc, Procedure_Name),
2902 Statements, Outp => False);
2904 Proc_Decl := Make_Subprogram_Declaration (Loc,
2905 Copy_Specification (Loc, Specification (Body_Node)));
2908 Make_Attribute_Definition_Clause (Loc,
2909 Name => New_Occurrence_Of (RACW_Type, Loc),
2910 Chars => Name_Write,
2913 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
2915 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
2916 Insert_After (Proc_Decl, Attr_Decl);
2917 Append_To (Declarations, Body_Node);
2918 end Add_RACW_Write_Attribute;
2920 ------------------------
2921 -- Add_RAS_Access_TSS --
2922 ------------------------
2924 procedure Add_RAS_Access_TSS (N : Node_Id) is
2925 Loc : constant Source_Ptr := Sloc (N);
2927 Ras_Type : constant Entity_Id := Defining_Identifier (N);
2928 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
2929 -- Ras_Type is the access to subprogram type while Fat_Type is the
2930 -- corresponding record type.
2932 RACW_Type : constant Entity_Id :=
2933 Underlying_RACW_Type (Ras_Type);
2934 Desig : constant Entity_Id :=
2935 Etype (Designated_Type (RACW_Type));
2937 Stub_Elements : constant Stub_Structure :=
2938 Stubs_Table.Get (Desig);
2939 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
2941 Proc : constant Entity_Id :=
2942 Make_Defining_Identifier (Loc,
2943 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
2945 Proc_Spec : Node_Id;
2947 -- Formal parameters
2949 Package_Name : constant Entity_Id :=
2950 Make_Defining_Identifier (Loc,
2954 Subp_Id : constant Entity_Id :=
2955 Make_Defining_Identifier (Loc,
2957 -- Target subprogram
2959 Asynch_P : constant Entity_Id :=
2960 Make_Defining_Identifier (Loc,
2961 Chars => Name_Asynchronous);
2962 -- Is the procedure to which the 'Access applies asynchronous?
2964 All_Calls_Remote
: constant Entity_Id
:=
2965 Make_Defining_Identifier
(Loc
,
2966 Chars
=> Name_All_Calls_Remote
);
2967 -- True if an All_Calls_Remote pragma applies to the RCI unit
2968 -- that contains the subprogram.
2970 -- Common local variables
2972 Proc_Decls
: List_Id
;
2973 Proc_Statements
: List_Id
;
2975 Origin
: constant Entity_Id
:=
2976 Make_Defining_Identifier
(Loc
,
2977 Chars
=> New_Internal_Name
('P'));
2979 -- Additional local variables for the local case
2981 Proxy_Addr
: constant Entity_Id
:=
2982 Make_Defining_Identifier
(Loc
,
2983 Chars
=> New_Internal_Name
('P'));
2985 -- Additional local variables for the remote case
2987 Local_Stub
: constant Entity_Id
:=
2988 Make_Defining_Identifier
(Loc
,
2989 Chars
=> New_Internal_Name
('L'));
2991 Stub_Ptr
: constant Entity_Id
:=
2992 Make_Defining_Identifier
(Loc
,
2993 Chars
=> New_Internal_Name
('S'));
2996 (Field_Name
: Name_Id
;
2997 Value
: Node_Id
) return Node_Id
;
2998 -- Construct an assignment that sets the named component in the
3006 (Field_Name
: Name_Id
;
3007 Value
: Node_Id
) return Node_Id
3011 Make_Assignment_Statement
(Loc
,
3013 Make_Selected_Component
(Loc
,
3015 Selector_Name
=> Field_Name
),
3016 Expression
=> Value
);
3019 -- Start of processing for Add_RAS_Access_TSS
3022 Proc_Decls
:= New_List
(
3024 -- Common declarations
3026 Make_Object_Declaration
(Loc
,
3027 Defining_Identifier
=> Origin
,
3028 Constant_Present
=> True,
3029 Object_Definition
=>
3030 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3032 Make_Function_Call
(Loc
,
3034 New_Occurrence_Of
(RTE
(RE_Get_Active_Partition_Id
), Loc
),
3035 Parameter_Associations
=> New_List
(
3036 New_Occurrence_Of
(Package_Name
, Loc
)))),
3038 -- Declaration use only in the local case: proxy address
3040 Make_Object_Declaration
(Loc
,
3041 Defining_Identifier
=> Proxy_Addr
,
3042 Object_Definition
=>
3043 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3045 -- Declarations used only in the remote case: stub object and
3048 Make_Object_Declaration
(Loc
,
3049 Defining_Identifier
=> Local_Stub
,
3050 Aliased_Present
=> True,
3051 Object_Definition
=>
3052 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
3054 Make_Object_Declaration
(Loc
,
3055 Defining_Identifier
=>
3057 Object_Definition
=>
3058 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
3060 Make_Attribute_Reference
(Loc
,
3061 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
3062 Attribute_Name
=> Name_Unchecked_Access
)));
3064 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
3065 -- Build_Get_Unique_RP_Call needs this information
3067 -- Note: Here we assume that the Fat_Type is a record
3068 -- containing just a pointer to a proxy or stub object.
3070 Proc_Statements
:= New_List
(
3074 -- Get_RAS_Info (Pkg, Subp, PA);
3075 -- if Origin = Local_Partition_Id
3076 -- and then not All_Calls_Remote
3078 -- return Fat_Type!(PA);
3081 Make_Procedure_Call_Statement
(Loc
,
3083 New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
3084 Parameter_Associations
=> New_List
(
3085 New_Occurrence_Of
(Package_Name
, Loc
),
3086 New_Occurrence_Of
(Subp_Id
, Loc
),
3087 New_Occurrence_Of
(Proxy_Addr
, Loc
))),
3089 Make_Implicit_If_Statement
(N
,
3095 New_Occurrence_Of
(Origin
, Loc
),
3097 Make_Function_Call
(Loc
,
3099 RTE
(RE_Get_Local_Partition_Id
), Loc
))),
3102 New_Occurrence_Of
(All_Calls_Remote
, Loc
))),
3103 Then_Statements
=> New_List
(
3104 Make_Return_Statement
(Loc
,
3105 Unchecked_Convert_To
(Fat_Type
,
3106 OK_Convert_To
(RTE
(RE_Address
),
3107 New_Occurrence_Of
(Proxy_Addr
, Loc
)))))),
3109 Set_Field
(Name_Origin
,
3110 New_Occurrence_Of
(Origin
, Loc
)),
3112 Set_Field
(Name_Receiver
,
3113 Make_Function_Call
(Loc
,
3115 New_Occurrence_Of
(RTE
(RE_Get_RCI_Package_Receiver
), Loc
),
3116 Parameter_Associations
=> New_List
(
3117 New_Occurrence_Of
(Package_Name
, Loc
)))),
3119 Set_Field
(Name_Addr
, New_Occurrence_Of
(Proxy_Addr
, Loc
)),
3121 -- E.4.1(9) A remote call is asynchronous if it is a call to
3122 -- a procedure, or a call through a value of an access-to-procedure
3123 -- type, to which a pragma Asynchronous applies.
3125 -- Parameter Asynch_P is true when the procedure is asynchronous;
3126 -- Expression Asynch_T is true when the type is asynchronous.
3128 Set_Field
(Name_Asynchronous
,
3130 New_Occurrence_Of
(Asynch_P
, Loc
),
3131 New_Occurrence_Of
(Boolean_Literals
(
3132 Is_Asynchronous
(Ras_Type
)), Loc
))));
3134 Append_List_To
(Proc_Statements
,
3135 Build_Get_Unique_RP_Call
3136 (Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
3138 -- Return the newly created value
3140 Append_To
(Proc_Statements
,
3141 Make_Return_Statement
(Loc
,
3143 Unchecked_Convert_To
(Fat_Type
,
3144 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
3147 Make_Function_Specification
(Loc
,
3148 Defining_Unit_Name
=> Proc
,
3149 Parameter_Specifications
=> New_List
(
3150 Make_Parameter_Specification
(Loc
,
3151 Defining_Identifier
=> Package_Name
,
3153 New_Occurrence_Of
(Standard_String
, Loc
)),
3155 Make_Parameter_Specification
(Loc
,
3156 Defining_Identifier
=> Subp_Id
,
3158 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
)),
3160 Make_Parameter_Specification
(Loc
,
3161 Defining_Identifier
=> Asynch_P
,
3163 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3165 Make_Parameter_Specification
(Loc
,
3166 Defining_Identifier
=> All_Calls_Remote
,
3168 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
3171 New_Occurrence_Of
(Fat_Type
, Loc
));
3173 -- Set the kind and return type of the function to prevent
3174 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3176 Set_Ekind
(Proc
, E_Function
);
3177 Set_Etype
(Proc
, Fat_Type
);
3180 Make_Subprogram_Body
(Loc
,
3181 Specification
=> Proc_Spec
,
3182 Declarations
=> Proc_Decls
,
3183 Handled_Statement_Sequence
=>
3184 Make_Handled_Sequence_Of_Statements
(Loc
,
3185 Statements
=> Proc_Statements
)));
3187 Set_TSS
(Fat_Type
, Proc
);
3188 end Add_RAS_Access_TSS
;
3190 -----------------------
3191 -- Add_RAST_Features --
3192 -----------------------
3194 procedure Add_RAST_Features
3195 (Vis_Decl
: Node_Id
;
3196 RAS_Type
: Entity_Id
;
3199 pragma Warnings
(Off
);
3200 pragma Unreferenced
(RAS_Type
, Decls
);
3201 pragma Warnings
(On
);
3203 Add_RAS_Access_TSS
(Vis_Decl
);
3204 end Add_RAST_Features
;
3206 -----------------------------------------
3207 -- Add_Receiving_Stubs_To_Declarations --
3208 -----------------------------------------
3210 procedure Add_Receiving_Stubs_To_Declarations
3211 (Pkg_Spec
: Node_Id
;
3214 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
3216 Request_Parameter
: Node_Id
;
3218 Pkg_RPC_Receiver
: constant Entity_Id
:=
3219 Make_Defining_Identifier
(Loc
,
3220 New_Internal_Name
('H'));
3221 Pkg_RPC_Receiver_Statements
: List_Id
;
3222 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
3223 Pkg_RPC_Receiver_Body
: Node_Id
;
3224 -- A Pkg_RPC_Receiver is built to decode the request
3226 Lookup_RAS_Info
: constant Entity_Id
:=
3227 Make_Defining_Identifier
(Loc
,
3228 Chars
=> New_Internal_Name
('R'));
3229 -- A remote subprogram is created to allow peers to look up
3230 -- RAS information using subprogram ids.
3232 Subp_Id
: Entity_Id
;
3233 Subp_Index
: Entity_Id
;
3234 -- Subprogram_Id as read from the incoming stream
3236 Current_Declaration
: Node_Id
;
3237 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
3238 Current_Stubs
: Node_Id
;
3240 Subp_Info_Array
: constant Entity_Id
:=
3241 Make_Defining_Identifier
(Loc
,
3242 Chars
=> New_Internal_Name
('I'));
3244 Subp_Info_List
: constant List_Id
:= New_List
;
3246 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
3248 All_Calls_Remote_E
: Entity_Id
;
3249 Proxy_Object_Addr
: Entity_Id
;
3251 procedure Append_Stubs_To
3252 (RPC_Receiver_Cases
: List_Id
;
3254 Subprogram_Number
: Int
);
3255 -- Add one case to the specified RPC receiver case list
3256 -- associating Subprogram_Number with the subprogram declared
3257 -- by Declaration, for which we have receiving stubs in Stubs.
3259 ---------------------
3260 -- Append_Stubs_To --
3261 ---------------------
3263 procedure Append_Stubs_To
3264 (RPC_Receiver_Cases
: List_Id
;
3266 Subprogram_Number
: Int
)
3269 Append_To
(RPC_Receiver_Cases
,
3270 Make_Case_Statement_Alternative
(Loc
,
3272 New_List
(Make_Integer_Literal
(Loc
, Subprogram_Number
)),
3275 Make_Procedure_Call_Statement
(Loc
,
3278 Defining_Entity
(Stubs
), Loc
),
3279 Parameter_Associations
=> New_List
(
3280 New_Occurrence_Of
(Request_Parameter
, Loc
))))));
3281 end Append_Stubs_To
;
3283 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3286 -- Building receiving stubs consist in several operations:
3288 -- - a package RPC receiver must be built. This subprogram
3289 -- will get a Subprogram_Id from the incoming stream
3290 -- and will dispatch the call to the right subprogram
3292 -- - a receiving stub for any subprogram visible in the package
3293 -- spec. This stub will read all the parameters from the stream,
3294 -- and put the result as well as the exception occurrence in the
3297 -- - a dummy package with an empty spec and a body made of an
3298 -- elaboration part, whose job is to register the receiving
3299 -- part of this RCI package on the name server. This is done
3300 -- by calling System.Partition_Interface.Register_Receiving_Stub
3302 Build_RPC_Receiver_Body
(
3303 RPC_Receiver
=> Pkg_RPC_Receiver
,
3304 Request
=> Request_Parameter
,
3306 Subp_Index
=> Subp_Index
,
3307 Stmts
=> Pkg_RPC_Receiver_Statements
,
3308 Decl
=> Pkg_RPC_Receiver_Body
);
3309 pragma Assert
(Subp_Id
= Subp_Index
);
3311 -- A null subp_id denotes a call through a RAS, in which case the
3312 -- next Uint_64 element in the stream is the address of the local
3313 -- proxy object, from which we can retrieve the actual subprogram id.
3315 Append_To
(Pkg_RPC_Receiver_Statements
,
3316 Make_Implicit_If_Statement
(Pkg_Spec
,
3319 New_Occurrence_Of
(Subp_Id
, Loc
),
3320 Make_Integer_Literal
(Loc
, 0)),
3321 Then_Statements
=> New_List
(
3322 Make_Assignment_Statement
(Loc
,
3324 New_Occurrence_Of
(Subp_Id
, Loc
),
3326 Make_Selected_Component
(Loc
,
3328 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
3329 OK_Convert_To
(RTE
(RE_Address
),
3330 Make_Attribute_Reference
(Loc
,
3332 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3335 Expressions
=> New_List
(
3336 Make_Selected_Component
(Loc
,
3337 Prefix
=> Request_Parameter
,
3338 Selector_Name
=> Name_Params
))))),
3340 Make_Identifier
(Loc
, Name_Subp_Id
))))));
3342 -- Build a subprogram for RAS information lookups
3344 Current_Declaration
:=
3345 Make_Subprogram_Declaration
(Loc
,
3347 Make_Function_Specification
(Loc
,
3348 Defining_Unit_Name
=>
3350 Parameter_Specifications
=> New_List
(
3351 Make_Parameter_Specification
(Loc
,
3352 Defining_Identifier
=>
3353 Make_Defining_Identifier
(Loc
, Name_Subp_Id
),
3357 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))),
3359 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)));
3360 Append_To
(Decls
, Current_Declaration
);
3361 Analyze
(Current_Declaration
);
3363 Current_Stubs
:= Build_Subprogram_Receiving_Stubs
3364 (Vis_Decl
=> Current_Declaration
,
3365 Asynchronous
=> False);
3366 Append_To
(Decls
, Current_Stubs
);
3367 Analyze
(Current_Stubs
);
3369 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3372 Subprogram_Number
=> 1);
3374 -- For each subprogram, the receiving stub will be built and a
3375 -- case statement will be made on the Subprogram_Id to dispatch
3376 -- to the right subprogram.
3378 All_Calls_Remote_E
:= Boolean_Literals
(
3379 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
3381 Overload_Counter_Table
.Reset
;
3383 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
3384 while Present
(Current_Declaration
) loop
3385 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
3386 and then Comes_From_Source
(Current_Declaration
)
3389 Loc
: constant Source_Ptr
:=
3390 Sloc
(Current_Declaration
);
3391 -- While specifically processing Current_Declaration, use
3392 -- its Sloc as the location of all generated nodes.
3394 Subp_Def
: constant Entity_Id
:=
3396 (Specification
(Current_Declaration
));
3398 Subp_Val
: String_Id
;
3401 pragma Assert
(Current_Subprogram_Number
=
3402 Get_Subprogram_Id
(Subp_Def
));
3404 -- Build receiving stub
3407 Build_Subprogram_Receiving_Stubs
3408 (Vis_Decl
=> Current_Declaration
,
3410 Nkind
(Specification
(Current_Declaration
)) =
3411 N_Procedure_Specification
3412 and then Is_Asynchronous
(Subp_Def
));
3414 Append_To
(Decls
, Current_Stubs
);
3415 Analyze
(Current_Stubs
);
3419 Add_RAS_Proxy_And_Analyze
(Decls
,
3421 Current_Declaration
,
3422 All_Calls_Remote_E
=>
3424 Proxy_Object_Addr
=>
3427 -- Compute distribution identifier
3429 Assign_Subprogram_Identifier
(
3431 Current_Subprogram_Number
,
3434 -- Add subprogram descriptor (RCI_Subp_Info) to the
3435 -- subprograms table for this receiver. The aggregate
3436 -- below must be kept consistent with the declaration
3437 -- of type RCI_Subp_Info in System.Partition_Interface.
3439 Append_To
(Subp_Info_List
,
3440 Make_Component_Association
(Loc
,
3441 Choices
=> New_List
(
3442 Make_Integer_Literal
(Loc
,
3443 Current_Subprogram_Number
)),
3445 Make_Aggregate
(Loc
,
3446 Component_Associations
=> New_List
(
3447 Make_Component_Association
(Loc
,
3448 Choices
=> New_List
(
3449 Make_Identifier
(Loc
, Name_Addr
)),
3452 Proxy_Object_Addr
, Loc
))))));
3454 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3457 Subprogram_Number
=>
3458 Current_Subprogram_Number
);
3461 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
3464 Next
(Current_Declaration
);
3467 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3468 -- rather than raising an exception since we do not want someone
3469 -- to crash a remote partition by sending invalid subprogram ids.
3470 -- This is consistent with the other parts of the case statement
3471 -- since even in presence of incorrect parameters in the stream,
3472 -- every exception will be caught and (if the subprogram is not an
3473 -- APC) put into the result stream and sent away.
3475 Append_To
(Pkg_RPC_Receiver_Cases
,
3476 Make_Case_Statement_Alternative
(Loc
,
3478 New_List
(Make_Others_Choice
(Loc
)),
3480 New_List
(Make_Null_Statement
(Loc
))));
3482 Append_To
(Pkg_RPC_Receiver_Statements
,
3483 Make_Case_Statement
(Loc
,
3485 New_Occurrence_Of
(Subp_Id
, Loc
),
3486 Alternatives
=> Pkg_RPC_Receiver_Cases
));
3489 Make_Object_Declaration
(Loc
,
3490 Defining_Identifier
=> Subp_Info_Array
,
3491 Constant_Present
=> True,
3492 Aliased_Present
=> True,
3493 Object_Definition
=>
3494 Make_Subtype_Indication
(Loc
,
3496 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
3498 Make_Index_Or_Discriminant_Constraint
(Loc
,
3501 Low_Bound
=> Make_Integer_Literal
(Loc
,
3502 First_RCI_Subprogram_Id
),
3504 Make_Integer_Literal
(Loc
,
3505 First_RCI_Subprogram_Id
3506 + List_Length
(Subp_Info_List
) - 1))))),
3508 Make_Aggregate
(Loc
,
3509 Component_Associations
=> Subp_Info_List
)));
3510 Analyze
(Last
(Decls
));
3513 Make_Subprogram_Body
(Loc
,
3515 Copy_Specification
(Loc
, Parent
(Lookup_RAS_Info
)),
3518 Handled_Statement_Sequence
=>
3519 Make_Handled_Sequence_Of_Statements
(Loc
,
3520 Statements
=> New_List
(
3521 Make_Return_Statement
(Loc
,
3522 Expression
=> OK_Convert_To
(RTE
(RE_Unsigned_64
),
3523 Make_Selected_Component
(Loc
,
3525 Make_Indexed_Component
(Loc
,
3527 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3528 Expressions
=> New_List
(
3529 Convert_To
(Standard_Integer
,
3530 Make_Identifier
(Loc
, Name_Subp_Id
)))),
3532 Make_Identifier
(Loc
, Name_Addr
))))))));
3533 Analyze
(Last
(Decls
));
3535 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
3536 Analyze
(Last
(Decls
));
3538 Get_Library_Unit_Name_String
(Pkg_Spec
);
3539 Append_To
(Register_Pkg_Actuals
,
3541 Make_String_Literal
(Loc
,
3542 Strval
=> String_From_Name_Buffer
));
3544 Append_To
(Register_Pkg_Actuals
,
3546 Make_Attribute_Reference
(Loc
,
3548 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
3550 Name_Unrestricted_Access
));
3552 Append_To
(Register_Pkg_Actuals
,
3554 Make_Attribute_Reference
(Loc
,
3556 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
3560 Append_To
(Register_Pkg_Actuals
,
3562 Make_Attribute_Reference
(Loc
,
3564 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3568 Append_To
(Register_Pkg_Actuals
,
3570 Make_Attribute_Reference
(Loc
,
3572 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3577 Make_Procedure_Call_Statement
(Loc
,
3579 New_Occurrence_Of
(RTE
(RE_Register_Receiving_Stub
), Loc
),
3580 Parameter_Associations
=> Register_Pkg_Actuals
));
3581 Analyze
(Last
(Decls
));
3582 end Add_Receiving_Stubs_To_Declarations
;
3584 ---------------------------------
3585 -- Build_General_Calling_Stubs --
3586 ---------------------------------
3588 procedure Build_General_Calling_Stubs
3590 Statements
: List_Id
;
3591 Target_Partition
: Entity_Id
;
3592 Target_RPC_Receiver
: Node_Id
;
3593 Subprogram_Id
: Node_Id
;
3594 Asynchronous
: Node_Id
:= Empty
;
3595 Is_Known_Asynchronous
: Boolean := False;
3596 Is_Known_Non_Asynchronous
: Boolean := False;
3597 Is_Function
: Boolean;
3599 Stub_Type
: Entity_Id
:= Empty
;
3600 RACW_Type
: Entity_Id
:= Empty
;
3603 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
3605 Stream_Parameter
: Node_Id
;
3606 -- Name of the stream used to transmit parameters to the
3609 Result_Parameter
: Node_Id
;
3610 -- Name of the result parameter (in non-APC cases) which get the
3611 -- result of the remote subprogram.
3613 Exception_Return_Parameter
: Node_Id
;
3614 -- Name of the parameter which will hold the exception sent by the
3615 -- remote subprogram.
3617 Current_Parameter
: Node_Id
;
3618 -- Current parameter being handled
3620 Ordered_Parameters_List
: constant List_Id
:=
3621 Build_Ordered_Parameters_List
(Spec
);
3623 Asynchronous_Statements
: List_Id
:= No_List
;
3624 Non_Asynchronous_Statements
: List_Id
:= No_List
;
3625 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
3627 Extra_Formal_Statements
: constant List_Id
:= New_List
;
3628 -- List of statements for extra formal parameters. It will appear
3629 -- after the regular statements for writing out parameters.
3631 pragma Warnings
(Off
);
3632 pragma Unreferenced
(RACW_Type
);
3633 -- Used only for the PolyORB case
3634 pragma Warnings
(On
);
3637 -- The general form of a calling stub for a given subprogram is:
3639 -- procedure X (...) is P : constant Partition_ID :=
3640 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
3641 -- System.RPC.Params_Stream_Type (0); begin
3642 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
3643 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
3644 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
3645 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
3647 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
3649 -- There are some variations: Do_APC is called for an asynchronous
3650 -- procedure and the part after the call is completely ommitted as
3651 -- well as the declaration of Result. For a function call, 'Input is
3652 -- always used to read the result even if it is constrained.
3655 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
3658 Make_Object_Declaration
(Loc
,
3659 Defining_Identifier
=> Stream_Parameter
,
3660 Aliased_Present
=> True,
3661 Object_Definition
=>
3662 Make_Subtype_Indication
(Loc
,
3664 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
3666 Make_Index_Or_Discriminant_Constraint
(Loc
,
3668 New_List
(Make_Integer_Literal
(Loc
, 0))))));
3670 if not Is_Known_Asynchronous
then
3672 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
3675 Make_Object_Declaration
(Loc
,
3676 Defining_Identifier
=> Result_Parameter
,
3677 Aliased_Present
=> True,
3678 Object_Definition
=>
3679 Make_Subtype_Indication
(Loc
,
3681 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
3683 Make_Index_Or_Discriminant_Constraint
(Loc
,
3685 New_List
(Make_Integer_Literal
(Loc
, 0))))));
3687 Exception_Return_Parameter
:=
3688 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
3691 Make_Object_Declaration
(Loc
,
3692 Defining_Identifier
=> Exception_Return_Parameter
,
3693 Object_Definition
=>
3694 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
3697 Result_Parameter
:= Empty
;
3698 Exception_Return_Parameter
:= Empty
;
3701 -- Put first the RPC receiver corresponding to the remote package
3703 Append_To
(Statements
,
3704 Make_Attribute_Reference
(Loc
,
3706 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3707 Attribute_Name
=> Name_Write
,
3708 Expressions
=> New_List
(
3709 Make_Attribute_Reference
(Loc
,
3711 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3714 Target_RPC_Receiver
)));
3716 -- Then put the Subprogram_Id of the subprogram we want to call in
3719 Append_To
(Statements
,
3720 Make_Attribute_Reference
(Loc
,
3722 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
3725 Expressions
=> New_List
(
3726 Make_Attribute_Reference
(Loc
,
3728 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3729 Attribute_Name
=> Name_Access
),
3732 Current_Parameter
:= First
(Ordered_Parameters_List
);
3733 while Present
(Current_Parameter
) loop
3735 Typ
: constant Node_Id
:=
3736 Parameter_Type
(Current_Parameter
);
3738 Constrained
: Boolean;
3740 Extra_Parameter
: Entity_Id
;
3743 if Is_RACW_Controlling_Formal
3744 (Current_Parameter
, Stub_Type
)
3746 -- In the case of a controlling formal argument, we marshall
3747 -- its addr field rather than the local stub.
3749 Append_To
(Statements
,
3750 Pack_Node_Into_Stream
(Loc
,
3751 Stream
=> Stream_Parameter
,
3753 Make_Selected_Component
(Loc
,
3755 Defining_Identifier
(Current_Parameter
),
3756 Selector_Name
=> Name_Addr
),
3757 Etyp
=> RTE
(RE_Unsigned_64
)));
3760 Value
:= New_Occurrence_Of
3761 (Defining_Identifier
(Current_Parameter
), Loc
);
3763 -- Access type parameters are transmitted as in out
3764 -- parameters. However, a dereference is needed so that
3765 -- we marshall the designated object.
3767 if Nkind
(Typ
) = N_Access_Definition
then
3768 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
3769 Etyp
:= Etype
(Subtype_Mark
(Typ
));
3771 Etyp
:= Etype
(Typ
);
3775 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
3777 -- Any parameter but unconstrained out parameters are
3778 -- transmitted to the peer.
3780 if In_Present
(Current_Parameter
)
3781 or else not Out_Present
(Current_Parameter
)
3782 or else not Constrained
3784 Append_To
(Statements
,
3785 Make_Attribute_Reference
(Loc
,
3787 New_Occurrence_Of
(Etyp
, Loc
),
3789 Output_From_Constrained
(Constrained
),
3790 Expressions
=> New_List
(
3791 Make_Attribute_Reference
(Loc
,
3793 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3794 Attribute_Name
=> Name_Access
),
3799 -- If the current parameter has a dynamic constrained status,
3800 -- then this status is transmitted as well.
3801 -- This should be done for accessibility as well ???
3803 if Nkind
(Typ
) /= N_Access_Definition
3804 and then Need_Extra_Constrained
(Current_Parameter
)
3806 -- In this block, we do not use the extra formal that has
3807 -- been created because it does not exist at the time of
3808 -- expansion when building calling stubs for remote access
3809 -- to subprogram types. We create an extra variable of this
3810 -- type and push it in the stream after the regular
3813 Extra_Parameter
:= Make_Defining_Identifier
3814 (Loc
, New_Internal_Name
('P'));
3817 Make_Object_Declaration
(Loc
,
3818 Defining_Identifier
=> Extra_Parameter
,
3819 Constant_Present
=> True,
3820 Object_Definition
=>
3821 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3823 Make_Attribute_Reference
(Loc
,
3826 Defining_Identifier
(Current_Parameter
), Loc
),
3827 Attribute_Name
=> Name_Constrained
)));
3829 Append_To
(Extra_Formal_Statements
,
3830 Make_Attribute_Reference
(Loc
,
3832 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3835 Expressions
=> New_List
(
3836 Make_Attribute_Reference
(Loc
,
3838 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3841 New_Occurrence_Of
(Extra_Parameter
, Loc
))));
3844 Next
(Current_Parameter
);
3848 -- Append the formal statements list to the statements
3850 Append_List_To
(Statements
, Extra_Formal_Statements
);
3852 if not Is_Known_Non_Asynchronous
then
3854 -- Build the call to System.RPC.Do_APC
3856 Asynchronous_Statements
:= New_List
(
3857 Make_Procedure_Call_Statement
(Loc
,
3859 New_Occurrence_Of
(RTE
(RE_Do_Apc
), Loc
),
3860 Parameter_Associations
=> New_List
(
3861 New_Occurrence_Of
(Target_Partition
, Loc
),
3862 Make_Attribute_Reference
(Loc
,
3864 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3868 Asynchronous_Statements
:= No_List
;
3871 if not Is_Known_Asynchronous
then
3873 -- Build the call to System.RPC.Do_RPC
3875 Non_Asynchronous_Statements
:= New_List
(
3876 Make_Procedure_Call_Statement
(Loc
,
3878 New_Occurrence_Of
(RTE
(RE_Do_Rpc
), Loc
),
3879 Parameter_Associations
=> New_List
(
3880 New_Occurrence_Of
(Target_Partition
, Loc
),
3882 Make_Attribute_Reference
(Loc
,
3884 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3888 Make_Attribute_Reference
(Loc
,
3890 New_Occurrence_Of
(Result_Parameter
, Loc
),
3894 -- Read the exception occurrence from the result stream and
3895 -- reraise it. It does no harm if this is a Null_Occurrence since
3896 -- this does nothing.
3898 Append_To
(Non_Asynchronous_Statements
,
3899 Make_Attribute_Reference
(Loc
,
3901 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
3906 Expressions
=> New_List
(
3907 Make_Attribute_Reference
(Loc
,
3909 New_Occurrence_Of
(Result_Parameter
, Loc
),
3912 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
3914 Append_To
(Non_Asynchronous_Statements
,
3915 Make_Procedure_Call_Statement
(Loc
,
3917 New_Occurrence_Of
(RTE
(RE_Reraise_Occurrence
), Loc
),
3918 Parameter_Associations
=> New_List
(
3919 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
3923 -- If this is a function call, then read the value and return
3924 -- it. The return value is written/read using 'Output/'Input.
3926 Append_To
(Non_Asynchronous_Statements
,
3927 Make_Tag_Check
(Loc
,
3928 Make_Return_Statement
(Loc
,
3930 Make_Attribute_Reference
(Loc
,
3933 Etype
(Subtype_Mark
(Spec
)), Loc
),
3935 Attribute_Name
=> Name_Input
,
3937 Expressions
=> New_List
(
3938 Make_Attribute_Reference
(Loc
,
3940 New_Occurrence_Of
(Result_Parameter
, Loc
),
3941 Attribute_Name
=> Name_Access
))))));
3944 -- Loop around parameters and assign out (or in out)
3945 -- parameters. In the case of RACW, controlling arguments
3946 -- cannot possibly have changed since they are remote, so we do
3947 -- not read them from the stream.
3949 Current_Parameter
:= First
(Ordered_Parameters_List
);
3950 while Present
(Current_Parameter
) loop
3952 Typ
: constant Node_Id
:=
3953 Parameter_Type
(Current_Parameter
);
3960 (Defining_Identifier
(Current_Parameter
), Loc
);
3962 if Nkind
(Typ
) = N_Access_Definition
then
3963 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
3964 Etyp
:= Etype
(Subtype_Mark
(Typ
));
3966 Etyp
:= Etype
(Typ
);
3969 if (Out_Present
(Current_Parameter
)
3970 or else Nkind
(Typ
) = N_Access_Definition
)
3971 and then Etyp
/= Stub_Type
3973 Append_To
(Non_Asynchronous_Statements
,
3974 Make_Attribute_Reference
(Loc
,
3976 New_Occurrence_Of
(Etyp
, Loc
),
3978 Attribute_Name
=> Name_Read
,
3980 Expressions
=> New_List
(
3981 Make_Attribute_Reference
(Loc
,
3983 New_Occurrence_Of
(Result_Parameter
, Loc
),
3990 Next
(Current_Parameter
);
3995 if Is_Known_Asynchronous
then
3996 Append_List_To
(Statements
, Asynchronous_Statements
);
3998 elsif Is_Known_Non_Asynchronous
then
3999 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
4002 pragma Assert
(Present
(Asynchronous
));
4003 Prepend_To
(Asynchronous_Statements
,
4004 Make_Attribute_Reference
(Loc
,
4005 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4006 Attribute_Name
=> Name_Write
,
4007 Expressions
=> New_List
(
4008 Make_Attribute_Reference
(Loc
,
4010 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4011 Attribute_Name
=> Name_Access
),
4012 New_Occurrence_Of
(Standard_True
, Loc
))));
4014 Prepend_To
(Non_Asynchronous_Statements
,
4015 Make_Attribute_Reference
(Loc
,
4016 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4017 Attribute_Name
=> Name_Write
,
4018 Expressions
=> New_List
(
4019 Make_Attribute_Reference
(Loc
,
4021 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4022 Attribute_Name
=> Name_Access
),
4023 New_Occurrence_Of
(Standard_False
, Loc
))));
4025 Append_To
(Statements
,
4026 Make_Implicit_If_Statement
(Nod
,
4027 Condition
=> Asynchronous
,
4028 Then_Statements
=> Asynchronous_Statements
,
4029 Else_Statements
=> Non_Asynchronous_Statements
));
4031 end Build_General_Calling_Stubs
;
4033 -----------------------------
4034 -- Build_RPC_Receiver_Body --
4035 -----------------------------
4037 procedure Build_RPC_Receiver_Body
4038 (RPC_Receiver
: Entity_Id
;
4039 Request
: out Entity_Id
;
4040 Subp_Id
: out Entity_Id
;
4041 Subp_Index
: out Entity_Id
;
4042 Stmts
: out List_Id
;
4045 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
4047 RPC_Receiver_Spec
: Node_Id
;
4048 RPC_Receiver_Decls
: List_Id
;
4051 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
4053 RPC_Receiver_Spec
:=
4054 Build_RPC_Receiver_Specification
4055 (RPC_Receiver
=> RPC_Receiver
,
4056 Request_Parameter
=> Request
);
4058 Subp_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4059 Subp_Index
:= Subp_Id
;
4061 -- Subp_Id may not be a constant, because in the case of the RPC
4062 -- receiver for an RCI package, when a call is received from a RAS
4063 -- dereference, it will be assigned during subsequent processing.
4065 RPC_Receiver_Decls
:= New_List
(
4066 Make_Object_Declaration
(Loc
,
4067 Defining_Identifier
=> Subp_Id
,
4068 Object_Definition
=>
4069 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4071 Make_Attribute_Reference
(Loc
,
4073 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4074 Attribute_Name
=> Name_Input
,
4075 Expressions
=> New_List
(
4076 Make_Selected_Component
(Loc
,
4078 Selector_Name
=> Name_Params
)))));
4083 Make_Subprogram_Body
(Loc
,
4084 Specification
=> RPC_Receiver_Spec
,
4085 Declarations
=> RPC_Receiver_Decls
,
4086 Handled_Statement_Sequence
=>
4087 Make_Handled_Sequence_Of_Statements
(Loc
,
4088 Statements
=> Stmts
));
4089 end Build_RPC_Receiver_Body
;
4091 -----------------------
4092 -- Build_Stub_Target --
4093 -----------------------
4095 function Build_Stub_Target
4098 RCI_Locator
: Entity_Id
;
4099 Controlling_Parameter
: Entity_Id
) return RPC_Target
4101 Target_Info
: RPC_Target
(PCS_Kind
=> Name_GARLIC_DSA
);
4103 Target_Info
.Partition
:=
4104 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
4105 if Present
(Controlling_Parameter
) then
4107 Make_Object_Declaration
(Loc
,
4108 Defining_Identifier
=> Target_Info
.Partition
,
4109 Constant_Present
=> True,
4110 Object_Definition
=>
4111 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4114 Make_Selected_Component
(Loc
,
4115 Prefix
=> Controlling_Parameter
,
4116 Selector_Name
=> Name_Origin
)));
4118 Target_Info
.RPC_Receiver
:=
4119 Make_Selected_Component
(Loc
,
4120 Prefix
=> Controlling_Parameter
,
4121 Selector_Name
=> Name_Receiver
);
4125 Make_Object_Declaration
(Loc
,
4126 Defining_Identifier
=> Target_Info
.Partition
,
4127 Constant_Present
=> True,
4128 Object_Definition
=>
4129 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4132 Make_Function_Call
(Loc
,
4133 Name
=> Make_Selected_Component
(Loc
,
4135 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4137 Make_Identifier
(Loc
,
4138 Name_Get_Active_Partition_ID
)))));
4140 Target_Info
.RPC_Receiver
:=
4141 Make_Selected_Component
(Loc
,
4143 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4145 Make_Identifier
(Loc
, Name_Get_RCI_Package_Receiver
));
4148 end Build_Stub_Target
;
4150 ---------------------
4151 -- Build_Stub_Type --
4152 ---------------------
4154 procedure Build_Stub_Type
4155 (RACW_Type
: Entity_Id
;
4156 Stub_Type
: Entity_Id
;
4157 Stub_Type_Decl
: out Node_Id
;
4158 RPC_Receiver_Decl
: out Node_Id
)
4160 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
4161 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
4165 Make_Full_Type_Declaration
(Loc
,
4166 Defining_Identifier
=> Stub_Type
,
4168 Make_Record_Definition
(Loc
,
4169 Tagged_Present
=> True,
4170 Limited_Present
=> True,
4172 Make_Component_List
(Loc
,
4173 Component_Items
=> New_List
(
4175 Make_Component_Declaration
(Loc
,
4176 Defining_Identifier
=>
4177 Make_Defining_Identifier
(Loc
, Name_Origin
),
4178 Component_Definition
=>
4179 Make_Component_Definition
(Loc
,
4180 Aliased_Present
=> False,
4181 Subtype_Indication
=>
4183 RTE
(RE_Partition_ID
), Loc
))),
4185 Make_Component_Declaration
(Loc
,
4186 Defining_Identifier
=>
4187 Make_Defining_Identifier
(Loc
, Name_Receiver
),
4188 Component_Definition
=>
4189 Make_Component_Definition
(Loc
,
4190 Aliased_Present
=> False,
4191 Subtype_Indication
=>
4192 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4194 Make_Component_Declaration
(Loc
,
4195 Defining_Identifier
=>
4196 Make_Defining_Identifier
(Loc
, Name_Addr
),
4197 Component_Definition
=>
4198 Make_Component_Definition
(Loc
,
4199 Aliased_Present
=> False,
4200 Subtype_Indication
=>
4201 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4203 Make_Component_Declaration
(Loc
,
4204 Defining_Identifier
=>
4205 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
4206 Component_Definition
=>
4207 Make_Component_Definition
(Loc
,
4208 Aliased_Present
=> False,
4209 Subtype_Indication
=>
4211 Standard_Boolean
, Loc
)))))));
4214 RPC_Receiver_Decl
:= Empty
;
4217 RPC_Receiver_Request
: constant Entity_Id
:=
4218 Make_Defining_Identifier
(Loc
, Name_R
);
4220 RPC_Receiver_Decl
:=
4221 Make_Subprogram_Declaration
(Loc
,
4222 Build_RPC_Receiver_Specification
(
4223 RPC_Receiver
=> Make_Defining_Identifier
(Loc
,
4224 New_Internal_Name
('R')),
4225 Request_Parameter
=> RPC_Receiver_Request
));
4228 end Build_Stub_Type
;
4230 --------------------------------------
4231 -- Build_Subprogram_Receiving_Stubs --
4232 --------------------------------------
4234 function Build_Subprogram_Receiving_Stubs
4235 (Vis_Decl
: Node_Id
;
4236 Asynchronous
: Boolean;
4237 Dynamically_Asynchronous
: Boolean := False;
4238 Stub_Type
: Entity_Id
:= Empty
;
4239 RACW_Type
: Entity_Id
:= Empty
;
4240 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
4242 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
4244 Request_Parameter
: Node_Id
;
4247 Decls
: constant List_Id
:= New_List
;
4248 -- All the parameters will get declared before calling the real
4249 -- subprograms. Also the out parameters will be declared.
4251 Statements
: constant List_Id
:= New_List
;
4253 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4254 -- Statements concerning extra formal parameters
4256 After_Statements
: constant List_Id
:= New_List
;
4257 -- Statements to be executed after the subprogram call
4259 Inner_Decls
: List_Id
:= No_List
;
4260 -- In case of a function, the inner declarations are needed since
4261 -- the result may be unconstrained.
4263 Excep_Handlers
: List_Id
:= No_List
;
4264 Excep_Choice
: Entity_Id
;
4265 Excep_Code
: List_Id
;
4267 Parameter_List
: constant List_Id
:= New_List
;
4268 -- List of parameters to be passed to the subprogram
4270 Current_Parameter
: Node_Id
;
4272 Ordered_Parameters_List
: constant List_Id
:=
4273 Build_Ordered_Parameters_List
4274 (Specification
(Vis_Decl
));
4276 Subp_Spec
: Node_Id
;
4277 -- Subprogram specification
4279 Called_Subprogram
: Node_Id
;
4280 -- The subprogram to call
4282 Null_Raise_Statement
: Node_Id
;
4284 Dynamic_Async
: Entity_Id
;
4287 if Present
(RACW_Type
) then
4288 Called_Subprogram
:=
4289 New_Occurrence_Of
(Parent_Primitive
, Loc
);
4291 Called_Subprogram
:=
4293 Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
4296 Request_Parameter
:=
4297 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4299 if Dynamically_Asynchronous
then
4301 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
4303 Dynamic_Async
:= Empty
;
4306 if not Asynchronous
or Dynamically_Asynchronous
then
4308 -- The first statement after the subprogram call is a statement to
4309 -- writes a Null_Occurrence into the result stream.
4311 Null_Raise_Statement
:=
4312 Make_Attribute_Reference
(Loc
,
4314 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4315 Attribute_Name
=> Name_Write
,
4316 Expressions
=> New_List
(
4317 Make_Selected_Component
(Loc
,
4318 Prefix
=> Request_Parameter
,
4319 Selector_Name
=> Name_Result
),
4320 New_Occurrence_Of
(RTE
(RE_Null_Occurrence
), Loc
)));
4322 if Dynamically_Asynchronous
then
4323 Null_Raise_Statement
:=
4324 Make_Implicit_If_Statement
(Vis_Decl
,
4326 Make_Op_Not
(Loc
, New_Occurrence_Of
(Dynamic_Async
, Loc
)),
4327 Then_Statements
=> New_List
(Null_Raise_Statement
));
4330 Append_To
(After_Statements
, Null_Raise_Statement
);
4333 -- Loop through every parameter and get its value from the stream. If
4334 -- the parameter is unconstrained, then the parameter is read using
4335 -- 'Input at the point of declaration.
4337 Current_Parameter
:= First
(Ordered_Parameters_List
);
4338 while Present
(Current_Parameter
) loop
4341 Constrained
: Boolean;
4343 Object
: constant Entity_Id
:=
4344 Make_Defining_Identifier
(Loc
,
4345 New_Internal_Name
('P'));
4347 Expr
: Node_Id
:= Empty
;
4349 Is_Controlling_Formal
: constant Boolean :=
4350 Is_RACW_Controlling_Formal
4351 (Current_Parameter
, Stub_Type
);
4354 Set_Ekind
(Object
, E_Variable
);
4356 if Is_Controlling_Formal
then
4358 -- We have a controlling formal parameter. Read its address
4359 -- rather than a real object. The address is in Unsigned_64
4362 Etyp
:= RTE
(RE_Unsigned_64
);
4364 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
4368 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
4370 if In_Present
(Current_Parameter
)
4371 or else not Out_Present
(Current_Parameter
)
4372 or else not Constrained
4373 or else Is_Controlling_Formal
4375 -- If an input parameter is contrained, then its reading is
4376 -- deferred until the beginning of the subprogram body. If
4377 -- it is unconstrained, then an expression is built for
4378 -- the object declaration and the variable is set using
4379 -- 'Input instead of 'Read.
4381 if Constrained
and then not Is_Controlling_Formal
then
4382 Append_To
(Statements
,
4383 Make_Attribute_Reference
(Loc
,
4384 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4385 Attribute_Name
=> Name_Read
,
4386 Expressions
=> New_List
(
4387 Make_Selected_Component
(Loc
,
4388 Prefix
=> Request_Parameter
,
4389 Selector_Name
=> Name_Params
),
4390 New_Occurrence_Of
(Object
, Loc
))));
4393 Expr
:= Input_With_Tag_Check
(Loc
,
4395 Stream
=> Make_Selected_Component
(Loc
,
4396 Prefix
=> Request_Parameter
,
4397 Selector_Name
=> Name_Params
));
4398 Append_To
(Decls
, Expr
);
4399 Expr
:= Make_Function_Call
(Loc
,
4400 New_Occurrence_Of
(Defining_Unit_Name
4401 (Specification
(Expr
)), Loc
));
4405 -- If we do not have to output the current parameter, then it
4406 -- can well be flagged as constant. This may allow further
4407 -- optimizations done by the back end.
4410 Make_Object_Declaration
(Loc
,
4411 Defining_Identifier
=> Object
,
4412 Constant_Present
=> not Constrained
4413 and then not Out_Present
(Current_Parameter
),
4414 Object_Definition
=>
4415 New_Occurrence_Of
(Etyp
, Loc
),
4416 Expression
=> Expr
));
4418 -- An out parameter may be written back using a 'Write
4419 -- attribute instead of a 'Output because it has been
4420 -- constrained by the parameter given to the caller. Note that
4421 -- out controlling arguments in the case of a RACW are not put
4422 -- back in the stream because the pointer on them has not
4425 if Out_Present
(Current_Parameter
)
4427 Etype
(Parameter_Type
(Current_Parameter
)) /= Stub_Type
4429 Append_To
(After_Statements
,
4430 Make_Attribute_Reference
(Loc
,
4431 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4432 Attribute_Name
=> Name_Write
,
4433 Expressions
=> New_List
(
4434 Make_Selected_Component
(Loc
,
4435 Prefix
=> Request_Parameter
,
4436 Selector_Name
=> Name_Result
),
4437 New_Occurrence_Of
(Object
, Loc
))));
4440 -- For RACW controlling formals, the Etyp of Object is always
4441 -- an RACW, even if the parameter is not of an anonymous access
4442 -- type. In such case, we need to dereference it at call time.
4444 if Is_Controlling_Formal
then
4445 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
4448 Append_To
(Parameter_List
,
4449 Make_Parameter_Association
(Loc
,
4452 Defining_Identifier
(Current_Parameter
), Loc
),
4453 Explicit_Actual_Parameter
=>
4454 Make_Explicit_Dereference
(Loc
,
4455 Unchecked_Convert_To
(RACW_Type
,
4456 OK_Convert_To
(RTE
(RE_Address
),
4457 New_Occurrence_Of
(Object
, Loc
))))));
4460 Append_To
(Parameter_List
,
4461 Make_Parameter_Association
(Loc
,
4464 Defining_Identifier
(Current_Parameter
), Loc
),
4465 Explicit_Actual_Parameter
=>
4466 Unchecked_Convert_To
(RACW_Type
,
4467 OK_Convert_To
(RTE
(RE_Address
),
4468 New_Occurrence_Of
(Object
, Loc
)))));
4472 Append_To
(Parameter_List
,
4473 Make_Parameter_Association
(Loc
,
4476 Defining_Identifier
(Current_Parameter
), Loc
),
4477 Explicit_Actual_Parameter
=>
4478 New_Occurrence_Of
(Object
, Loc
)));
4481 -- If the current parameter needs an extra formal, then read it
4482 -- from the stream and set the corresponding semantic field in
4483 -- the variable. If the kind of the parameter identifier is
4484 -- E_Void, then this is a compiler generated parameter that
4485 -- doesn't need an extra constrained status.
4487 -- The case of Extra_Accessibility should also be handled ???
4489 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
4492 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
4494 Present
(Extra_Constrained
4495 (Defining_Identifier
(Current_Parameter
)))
4498 Extra_Parameter
: constant Entity_Id
:=
4500 (Defining_Identifier
4501 (Current_Parameter
));
4503 Formal_Entity
: constant Entity_Id
:=
4504 Make_Defining_Identifier
4505 (Loc
, Chars
(Extra_Parameter
));
4507 Formal_Type
: constant Entity_Id
:=
4508 Etype
(Extra_Parameter
);
4512 Make_Object_Declaration
(Loc
,
4513 Defining_Identifier
=> Formal_Entity
,
4514 Object_Definition
=>
4515 New_Occurrence_Of
(Formal_Type
, Loc
)));
4517 Append_To
(Extra_Formal_Statements
,
4518 Make_Attribute_Reference
(Loc
,
4519 Prefix
=> New_Occurrence_Of
(
4521 Attribute_Name
=> Name_Read
,
4522 Expressions
=> New_List
(
4523 Make_Selected_Component
(Loc
,
4524 Prefix
=> Request_Parameter
,
4525 Selector_Name
=> Name_Params
),
4526 New_Occurrence_Of
(Formal_Entity
, Loc
))));
4527 Set_Extra_Constrained
(Object
, Formal_Entity
);
4532 Next
(Current_Parameter
);
4535 -- Append the formal statements list at the end of regular statements
4537 Append_List_To
(Statements
, Extra_Formal_Statements
);
4539 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
4541 -- The remote subprogram is a function. We build an inner block to
4542 -- be able to hold a potentially unconstrained result in a
4546 Etyp
: constant Entity_Id
:=
4547 Etype
(Subtype_Mark
(Specification
(Vis_Decl
)));
4548 Result
: constant Node_Id
:=
4549 Make_Defining_Identifier
(Loc
,
4550 New_Internal_Name
('R'));
4552 Inner_Decls
:= New_List
(
4553 Make_Object_Declaration
(Loc
,
4554 Defining_Identifier
=> Result
,
4555 Constant_Present
=> True,
4556 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
4558 Make_Function_Call
(Loc
,
4559 Name
=> Called_Subprogram
,
4560 Parameter_Associations
=> Parameter_List
)));
4562 Append_To
(After_Statements
,
4563 Make_Attribute_Reference
(Loc
,
4564 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4565 Attribute_Name
=> Name_Output
,
4566 Expressions
=> New_List
(
4567 Make_Selected_Component
(Loc
,
4568 Prefix
=> Request_Parameter
,
4569 Selector_Name
=> Name_Result
),
4570 New_Occurrence_Of
(Result
, Loc
))));
4573 Append_To
(Statements
,
4574 Make_Block_Statement
(Loc
,
4575 Declarations
=> Inner_Decls
,
4576 Handled_Statement_Sequence
=>
4577 Make_Handled_Sequence_Of_Statements
(Loc
,
4578 Statements
=> After_Statements
)));
4581 -- The remote subprogram is a procedure. We do not need any inner
4582 -- block in this case.
4584 if Dynamically_Asynchronous
then
4586 Make_Object_Declaration
(Loc
,
4587 Defining_Identifier
=> Dynamic_Async
,
4588 Object_Definition
=>
4589 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
4591 Append_To
(Statements
,
4592 Make_Attribute_Reference
(Loc
,
4593 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4594 Attribute_Name
=> Name_Read
,
4595 Expressions
=> New_List
(
4596 Make_Selected_Component
(Loc
,
4597 Prefix
=> Request_Parameter
,
4598 Selector_Name
=> Name_Params
),
4599 New_Occurrence_Of
(Dynamic_Async
, Loc
))));
4602 Append_To
(Statements
,
4603 Make_Procedure_Call_Statement
(Loc
,
4604 Name
=> Called_Subprogram
,
4605 Parameter_Associations
=> Parameter_List
));
4607 Append_List_To
(Statements
, After_Statements
);
4610 if Asynchronous
and then not Dynamically_Asynchronous
then
4612 -- For an asynchronous procedure, add a null exception handler
4614 Excep_Handlers
:= New_List
(
4615 Make_Exception_Handler
(Loc
,
4616 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
4617 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
4620 -- In the other cases, if an exception is raised, then the
4621 -- exception occurrence is copied into the output stream and
4622 -- no other output parameter is written.
4625 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
4627 Excep_Code
:= New_List
(
4628 Make_Attribute_Reference
(Loc
,
4630 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4631 Attribute_Name
=> Name_Write
,
4632 Expressions
=> New_List
(
4633 Make_Selected_Component
(Loc
,
4634 Prefix
=> Request_Parameter
,
4635 Selector_Name
=> Name_Result
),
4636 New_Occurrence_Of
(Excep_Choice
, Loc
))));
4638 if Dynamically_Asynchronous
then
4639 Excep_Code
:= New_List
(
4640 Make_Implicit_If_Statement
(Vis_Decl
,
4641 Condition
=> Make_Op_Not
(Loc
,
4642 New_Occurrence_Of
(Dynamic_Async
, Loc
)),
4643 Then_Statements
=> Excep_Code
));
4646 Excep_Handlers
:= New_List
(
4647 Make_Exception_Handler
(Loc
,
4648 Choice_Parameter
=> Excep_Choice
,
4649 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
4650 Statements
=> Excep_Code
));
4655 Make_Procedure_Specification
(Loc
,
4656 Defining_Unit_Name
=>
4657 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
4659 Parameter_Specifications
=> New_List
(
4660 Make_Parameter_Specification
(Loc
,
4661 Defining_Identifier
=> Request_Parameter
,
4663 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
4666 Make_Subprogram_Body
(Loc
,
4667 Specification
=> Subp_Spec
,
4668 Declarations
=> Decls
,
4669 Handled_Statement_Sequence
=>
4670 Make_Handled_Sequence_Of_Statements
(Loc
,
4671 Statements
=> Statements
,
4672 Exception_Handlers
=> Excep_Handlers
));
4673 end Build_Subprogram_Receiving_Stubs
;
4679 function Result
return Node_Id
is
4681 return Make_Identifier
(Loc
, Name_V
);
4684 ----------------------
4685 -- Stream_Parameter --
4686 ----------------------
4688 function Stream_Parameter
return Node_Id
is
4690 return Make_Identifier
(Loc
, Name_S
);
4691 end Stream_Parameter
;
4695 -----------------------------
4696 -- Make_Selected_Component --
4697 -----------------------------
4699 function Make_Selected_Component
4702 Selector_Name
: Name_Id
) return Node_Id
4705 return Make_Selected_Component
(Loc
,
4706 Prefix
=> New_Occurrence_Of
(Prefix
, Loc
),
4707 Selector_Name
=> Make_Identifier
(Loc
, Selector_Name
));
4708 end Make_Selected_Component
;
4714 function Get_PCS_Name
return PCS_Names
is
4715 PCS_Name
: constant PCS_Names
:=
4716 Chars
(Entity
(Expression
4717 (Parent
(RTE
(RE_DSA_Implementation
)))));
4722 -----------------------
4723 -- Get_Subprogram_Id --
4724 -----------------------
4726 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
is
4728 return Get_Subprogram_Ids
(Def
).Str_Identifier
;
4729 end Get_Subprogram_Id
;
4731 -----------------------
4732 -- Get_Subprogram_Id --
4733 -----------------------
4735 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
is
4737 return Get_Subprogram_Ids
(Def
).Int_Identifier
;
4738 end Get_Subprogram_Id
;
4740 ------------------------
4741 -- Get_Subprogram_Ids --
4742 ------------------------
4744 function Get_Subprogram_Ids
4745 (Def
: Entity_Id
) return Subprogram_Identifiers
4747 Result
: Subprogram_Identifiers
:=
4748 Subprogram_Identifier_Table
.Get
(Def
);
4750 Current_Declaration
: Node_Id
;
4751 Current_Subp
: Entity_Id
;
4752 Current_Subp_Str
: String_Id
;
4753 Current_Subp_Number
: Int
:= First_RCI_Subprogram_Id
;
4756 if Result
.Str_Identifier
= No_String
then
4758 -- We are looking up this subprogram's identifier outside of the
4759 -- context of generating calling or receiving stubs. Hence we are
4760 -- processing an 'Access attribute_reference for an RCI subprogram,
4761 -- for the purpose of obtaining a RAS value.
4764 (Is_Remote_Call_Interface
(Scope
(Def
))
4766 (Nkind
(Parent
(Def
)) = N_Procedure_Specification
4768 Nkind
(Parent
(Def
)) = N_Function_Specification
));
4770 Current_Declaration
:=
4771 First
(Visible_Declarations
4772 (Package_Specification_Of_Scope
(Scope
(Def
))));
4773 while Present
(Current_Declaration
) loop
4774 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
4775 and then Comes_From_Source
(Current_Declaration
)
4777 Current_Subp
:= Defining_Unit_Name
(Specification
(
4778 Current_Declaration
));
4779 Assign_Subprogram_Identifier
4780 (Current_Subp
, Current_Subp_Number
, Current_Subp_Str
);
4782 if Current_Subp
= Def
then
4783 Result
:= (Current_Subp_Str
, Current_Subp_Number
);
4786 Current_Subp_Number
:= Current_Subp_Number
+ 1;
4789 Next
(Current_Declaration
);
4793 pragma Assert
(Result
.Str_Identifier
/= No_String
);
4795 end Get_Subprogram_Ids
;
4801 function Hash
(F
: Entity_Id
) return Hash_Index
is
4803 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
4806 function Hash
(F
: Name_Id
) return Hash_Index
is
4808 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
4811 --------------------------
4812 -- Input_With_Tag_Check --
4813 --------------------------
4815 function Input_With_Tag_Check
4817 Var_Type
: Entity_Id
;
4818 Stream
: Node_Id
) return Node_Id
4822 Make_Subprogram_Body
(Loc
,
4823 Specification
=> Make_Function_Specification
(Loc
,
4824 Defining_Unit_Name
=>
4825 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S')),
4826 Subtype_Mark
=> New_Occurrence_Of
(Var_Type
, Loc
)),
4827 Declarations
=> No_List
,
4828 Handled_Statement_Sequence
=>
4829 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
4830 Make_Tag_Check
(Loc
,
4831 Make_Return_Statement
(Loc
,
4832 Make_Attribute_Reference
(Loc
,
4833 Prefix
=> New_Occurrence_Of
(Var_Type
, Loc
),
4834 Attribute_Name
=> Name_Input
,
4836 New_List
(Stream
)))))));
4837 end Input_With_Tag_Check
;
4839 --------------------------------
4840 -- Is_RACW_Controlling_Formal --
4841 --------------------------------
4843 function Is_RACW_Controlling_Formal
4844 (Parameter
: Node_Id
;
4845 Stub_Type
: Entity_Id
) return Boolean
4850 -- If the kind of the parameter is E_Void, then it is not a
4851 -- controlling formal (this can happen in the context of RAS).
4853 if Ekind
(Defining_Identifier
(Parameter
)) = E_Void
then
4857 -- If the parameter is not a controlling formal, then it cannot
4858 -- be possibly a RACW_Controlling_Formal.
4860 if not Is_Controlling_Formal
(Defining_Identifier
(Parameter
)) then
4864 Typ
:= Parameter_Type
(Parameter
);
4865 return (Nkind
(Typ
) = N_Access_Definition
4866 and then Etype
(Subtype_Mark
(Typ
)) = Stub_Type
)
4867 or else Etype
(Typ
) = Stub_Type
;
4868 end Is_RACW_Controlling_Formal
;
4870 --------------------
4871 -- Make_Tag_Check --
4872 --------------------
4874 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
is
4875 Occ
: constant Entity_Id
:=
4876 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
4879 return Make_Block_Statement
(Loc
,
4880 Handled_Statement_Sequence
=>
4881 Make_Handled_Sequence_Of_Statements
(Loc
,
4882 Statements
=> New_List
(N
),
4884 Exception_Handlers
=> New_List
(
4885 Make_Exception_Handler
(Loc
,
4886 Choice_Parameter
=> Occ
,
4888 Exception_Choices
=>
4889 New_List
(New_Occurrence_Of
(RTE
(RE_Tag_Error
), Loc
)),
4892 New_List
(Make_Procedure_Call_Statement
(Loc
,
4894 (RTE
(RE_Raise_Program_Error_Unknown_Tag
), Loc
),
4895 New_List
(New_Occurrence_Of
(Occ
, Loc
))))))));
4898 ----------------------------
4899 -- Need_Extra_Constrained --
4900 ----------------------------
4902 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean is
4903 Etyp
: constant Entity_Id
:= Etype
(Parameter_Type
(Parameter
));
4905 return Out_Present
(Parameter
)
4906 and then Has_Discriminants
(Etyp
)
4907 and then not Is_Constrained
(Etyp
)
4908 and then not Is_Indefinite_Subtype
(Etyp
);
4909 end Need_Extra_Constrained
;
4911 ------------------------------------
4912 -- Pack_Entity_Into_Stream_Access --
4913 ------------------------------------
4915 function Pack_Entity_Into_Stream_Access
4919 Etyp
: Entity_Id
:= Empty
) return Node_Id
4924 if Present
(Etyp
) then
4927 Typ
:= Etype
(Object
);
4931 Pack_Node_Into_Stream_Access
(Loc
,
4933 Object
=> New_Occurrence_Of
(Object
, Loc
),
4935 end Pack_Entity_Into_Stream_Access
;
4937 ---------------------------
4938 -- Pack_Node_Into_Stream --
4939 ---------------------------
4941 function Pack_Node_Into_Stream
4945 Etyp
: Entity_Id
) return Node_Id
4947 Write_Attribute
: Name_Id
:= Name_Write
;
4950 if not Is_Constrained
(Etyp
) then
4951 Write_Attribute
:= Name_Output
;
4955 Make_Attribute_Reference
(Loc
,
4956 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4957 Attribute_Name
=> Write_Attribute
,
4958 Expressions
=> New_List
(
4959 Make_Attribute_Reference
(Loc
,
4960 Prefix
=> New_Occurrence_Of
(Stream
, Loc
),
4961 Attribute_Name
=> Name_Access
),
4963 end Pack_Node_Into_Stream
;
4965 ----------------------------------
4966 -- Pack_Node_Into_Stream_Access --
4967 ----------------------------------
4969 function Pack_Node_Into_Stream_Access
4973 Etyp
: Entity_Id
) return Node_Id
4975 Write_Attribute
: Name_Id
:= Name_Write
;
4978 if not Is_Constrained
(Etyp
) then
4979 Write_Attribute
:= Name_Output
;
4983 Make_Attribute_Reference
(Loc
,
4984 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4985 Attribute_Name
=> Write_Attribute
,
4986 Expressions
=> New_List
(
4989 end Pack_Node_Into_Stream_Access
;
4991 ---------------------
4992 -- PolyORB_Support --
4993 ---------------------
4995 package body PolyORB_Support
is
4997 -- Local subprograms
4999 procedure Add_RACW_Read_Attribute
5000 (RACW_Type
: Entity_Id
;
5001 Stub_Type
: Entity_Id
;
5002 Stub_Type_Access
: Entity_Id
;
5003 Declarations
: List_Id
);
5004 -- Add Read attribute in Decls for the RACW type. The Read attribute
5005 -- is added right after the RACW_Type declaration while the body is
5006 -- inserted after Declarations.
5008 procedure Add_RACW_Write_Attribute
5009 (RACW_Type
: Entity_Id
;
5010 Stub_Type
: Entity_Id
;
5011 Stub_Type_Access
: Entity_Id
;
5012 Declarations
: List_Id
);
5013 -- Same thing for the Write attribute
5015 procedure Add_RACW_From_Any
5016 (RACW_Type
: Entity_Id
;
5017 Stub_Type
: Entity_Id
;
5018 Stub_Type_Access
: Entity_Id
;
5019 Declarations
: List_Id
);
5020 -- Add the From_Any TSS for this RACW type
5022 procedure Add_RACW_To_Any
5023 (Designated_Type
: Entity_Id
;
5024 RACW_Type
: Entity_Id
;
5025 Stub_Type
: Entity_Id
;
5026 Stub_Type_Access
: Entity_Id
;
5027 Declarations
: List_Id
);
5028 -- Add the To_Any TSS for this RACW type
5030 procedure Add_RACW_TypeCode
5031 (Designated_Type
: Entity_Id
;
5032 RACW_Type
: Entity_Id
;
5033 Declarations
: List_Id
);
5034 -- Add the TypeCode TSS for this RACW type
5036 procedure Add_RAS_From_Any
5037 (RAS_Type
: Entity_Id
;
5038 Declarations
: List_Id
);
5039 -- Add the From_Any TSS for this RAS type
5041 procedure Add_RAS_To_Any
5042 (RAS_Type
: Entity_Id
;
5043 Declarations
: List_Id
);
5044 -- Add the To_Any TSS for this RAS type
5046 procedure Add_RAS_TypeCode
5047 (RAS_Type
: Entity_Id
;
5048 Declarations
: List_Id
);
5049 -- Add the TypeCode TSS for this RAS type
5051 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
5052 -- Add a subprogram body for RAS Access TSS
5054 -----------------------
5055 -- Add_RACW_Features --
5056 -----------------------
5058 procedure Add_RACW_Features
5059 (RACW_Type
: Entity_Id
;
5061 Stub_Type
: Entity_Id
;
5062 Stub_Type_Access
: Entity_Id
;
5063 RPC_Receiver_Decl
: Node_Id
;
5064 Declarations
: List_Id
)
5066 pragma Warnings
(Off
);
5067 pragma Unreferenced
(RPC_Receiver_Decl
);
5068 pragma Warnings
(On
);
5072 (RACW_Type
=> RACW_Type
,
5073 Stub_Type
=> Stub_Type
,
5074 Stub_Type_Access
=> Stub_Type_Access
,
5075 Declarations
=> Declarations
);
5078 (Designated_Type
=> Desig
,
5079 RACW_Type
=> RACW_Type
,
5080 Stub_Type
=> Stub_Type
,
5081 Stub_Type_Access
=> Stub_Type_Access
,
5082 Declarations
=> Declarations
);
5084 -- In the PolyORB case, the RACW 'Read and 'Write attributes
5085 -- are implemented in terms of the From_Any and To_Any TSSs,
5086 -- so these TSSs must be expanded before 'Read and 'Write.
5088 Add_RACW_Write_Attribute
5089 (RACW_Type
=> RACW_Type
,
5090 Stub_Type
=> Stub_Type
,
5091 Stub_Type_Access
=> Stub_Type_Access
,
5092 Declarations
=> Declarations
);
5094 Add_RACW_Read_Attribute
5095 (RACW_Type
=> RACW_Type
,
5096 Stub_Type
=> Stub_Type
,
5097 Stub_Type_Access
=> Stub_Type_Access
,
5098 Declarations
=> Declarations
);
5101 (Designated_Type
=> Desig
,
5102 RACW_Type
=> RACW_Type
,
5103 Declarations
=> Declarations
);
5104 end Add_RACW_Features
;
5106 -----------------------
5107 -- Add_RACW_From_Any --
5108 -----------------------
5110 procedure Add_RACW_From_Any
5111 (RACW_Type
: Entity_Id
;
5112 Stub_Type
: Entity_Id
;
5113 Stub_Type_Access
: Entity_Id
;
5114 Declarations
: List_Id
)
5116 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5117 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5119 Fnam
: constant Entity_Id
:=
5120 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F'));
5122 Func_Spec
: Node_Id
;
5123 Func_Decl
: Node_Id
;
5124 Func_Body
: Node_Id
;
5127 Statements
: List_Id
;
5128 Stub_Statements
: List_Id
;
5129 Local_Statements
: List_Id
;
5130 -- Various parts of the subprogram
5132 Any_Parameter
: constant Entity_Id
:=
5133 Make_Defining_Identifier
(Loc
, Name_A
);
5134 Reference
: constant Entity_Id
:=
5135 Make_Defining_Identifier
5136 (Loc
, New_Internal_Name
('R'));
5137 Is_Local
: constant Entity_Id
:=
5138 Make_Defining_Identifier
5139 (Loc
, New_Internal_Name
('L'));
5140 Addr
: constant Entity_Id
:=
5141 Make_Defining_Identifier
5142 (Loc
, New_Internal_Name
('A'));
5143 Local_Stub
: constant Entity_Id
:=
5144 Make_Defining_Identifier
5145 (Loc
, New_Internal_Name
('L'));
5146 Stubbed_Result
: constant Entity_Id
:=
5147 Make_Defining_Identifier
5148 (Loc
, New_Internal_Name
('S'));
5150 Stub_Condition
: Node_Id
;
5151 -- An expression that determines whether we create a stub for the
5152 -- newly-unpacked RACW. Normally we create a stub only for remote
5153 -- objects, but in the case of an RACW used to implement a RAS,
5154 -- we also create a stub for local subprograms if a pragma
5155 -- All_Calls_Remote applies.
5157 Asynchronous_Flag
: constant Entity_Id
:=
5158 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5159 -- The flag object declared in Add_RACW_Asynchronous_Flag
5162 -- Object declarations
5165 Make_Object_Declaration
(Loc
,
5166 Defining_Identifier
=>
5168 Object_Definition
=>
5169 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5171 Make_Function_Call
(Loc
,
5173 New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
5174 Parameter_Associations
=> New_List
(
5175 New_Occurrence_Of
(Any_Parameter
, Loc
)))),
5177 Make_Object_Declaration
(Loc
,
5178 Defining_Identifier
=> Local_Stub
,
5179 Aliased_Present
=> True,
5180 Object_Definition
=> New_Occurrence_Of
(Stub_Type
, Loc
)),
5182 Make_Object_Declaration
(Loc
,
5183 Defining_Identifier
=> Stubbed_Result
,
5184 Object_Definition
=>
5185 New_Occurrence_Of
(Stub_Type_Access
, Loc
),
5187 Make_Attribute_Reference
(Loc
,
5189 New_Occurrence_Of
(Local_Stub
, Loc
),
5191 Name_Unchecked_Access
)),
5193 Make_Object_Declaration
(Loc
,
5194 Defining_Identifier
=> Is_Local
,
5195 Object_Definition
=>
5196 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
5198 Make_Object_Declaration
(Loc
,
5199 Defining_Identifier
=> Addr
,
5200 Object_Definition
=>
5201 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
5203 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
5205 Set_Etype
(Stubbed_Result
, Stub_Type_Access
);
5207 -- If the ref Is_Nil, return a null pointer
5209 Statements
:= New_List
(
5210 Make_Implicit_If_Statement
(RACW_Type
,
5212 Make_Function_Call
(Loc
,
5214 New_Occurrence_Of
(RTE
(RE_Is_Nil
), Loc
),
5215 Parameter_Associations
=> New_List
(
5216 New_Occurrence_Of
(Reference
, Loc
))),
5217 Then_Statements
=> New_List
(
5218 Make_Return_Statement
(Loc
,
5220 Make_Null
(Loc
)))));
5222 Append_To
(Statements
,
5223 Make_Procedure_Call_Statement
(Loc
,
5225 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
5226 Parameter_Associations
=> New_List
(
5227 New_Occurrence_Of
(Reference
, Loc
),
5228 New_Occurrence_Of
(Is_Local
, Loc
),
5229 New_Occurrence_Of
(Addr
, Loc
))));
5231 -- If the object is located on another partition, then a stub object
5232 -- will be created with all the information needed to rebuild the
5233 -- real object at the other end. This stanza is always used in the
5234 -- case of RAS types, for which a stub is required even for local
5237 Stub_Statements
:= New_List
(
5238 Make_Assignment_Statement
(Loc
,
5239 Name
=> Make_Selected_Component
(Loc
,
5240 Prefix
=> Stubbed_Result
,
5241 Selector_Name
=> Name_Target
),
5243 Make_Function_Call
(Loc
,
5245 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
5246 Parameter_Associations
=> New_List
(
5247 New_Occurrence_Of
(Reference
, Loc
)))),
5249 Make_Procedure_Call_Statement
(Loc
,
5251 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
5252 Parameter_Associations
=> New_List
(
5253 Make_Selected_Component
(Loc
,
5254 Prefix
=> Stubbed_Result
,
5255 Selector_Name
=> Name_Target
))),
5257 Make_Assignment_Statement
(Loc
,
5258 Name
=> Make_Selected_Component
(Loc
,
5259 Prefix
=> Stubbed_Result
,
5260 Selector_Name
=> Name_Asynchronous
),
5262 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)));
5264 -- ??? Issue with asynchronous calls here: the Asynchronous
5265 -- flag is set on the stub type if, and only if, the RACW type
5266 -- has a pragma Asynchronous. This is incorrect for RACWs that
5267 -- implement RAS types, because in that case the /designated
5268 -- subprogram/ (not the type) might be asynchronous, and
5269 -- that causes the stub to need to be asynchronous too.
5270 -- A solution is to transport a RAS as a struct containing
5271 -- a RACW and an asynchronous flag, and to properly alter
5272 -- the Asynchronous component in the stub type in the RAS's
5275 Append_List_To
(Stub_Statements
,
5276 Build_Get_Unique_RP_Call
(Loc
, Stubbed_Result
, Stub_Type
));
5278 -- Distinguish between the local and remote cases, and execute the
5279 -- appropriate piece of code.
5281 Stub_Condition
:= New_Occurrence_Of
(Is_Local
, Loc
);
5284 Stub_Condition
:= Make_And_Then
(Loc
,
5288 Make_Selected_Component
(Loc
,
5290 Unchecked_Convert_To
(
5291 RTE
(RE_RAS_Proxy_Type_Access
),
5292 New_Occurrence_Of
(Addr
, Loc
)),
5294 Make_Identifier
(Loc
,
5295 Name_All_Calls_Remote
)));
5298 Local_Statements
:= New_List
(
5299 Make_Return_Statement
(Loc
,
5301 Unchecked_Convert_To
(RACW_Type
,
5302 New_Occurrence_Of
(Addr
, Loc
))));
5304 Append_To
(Statements
,
5305 Make_Implicit_If_Statement
(RACW_Type
,
5308 Then_Statements
=> Local_Statements
,
5309 Else_Statements
=> Stub_Statements
));
5311 Append_To
(Statements
,
5312 Make_Return_Statement
(Loc
,
5313 Expression
=> Unchecked_Convert_To
(RACW_Type
,
5314 New_Occurrence_Of
(Stubbed_Result
, Loc
))));
5317 Make_Function_Specification
(Loc
,
5318 Defining_Unit_Name
=>
5320 Parameter_Specifications
=> New_List
(
5321 Make_Parameter_Specification
(Loc
,
5322 Defining_Identifier
=>
5325 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
5326 Subtype_Mark
=> New_Occurrence_Of
(RACW_Type
, Loc
));
5328 -- NOTE: The usage occurrences of RACW_Parameter must
5329 -- refer to the entity in the declaration spec, not those
5330 -- of the body spec.
5332 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5335 Make_Subprogram_Body
(Loc
,
5337 Copy_Specification
(Loc
, Func_Spec
),
5338 Declarations
=> Decls
,
5339 Handled_Statement_Sequence
=>
5340 Make_Handled_Sequence_Of_Statements
(Loc
,
5341 Statements
=> Statements
));
5343 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5344 Append_To
(Declarations
, Func_Body
);
5346 Set_Renaming_TSS
(RACW_Type
, Fnam
, Name_uFrom_Any
);
5347 end Add_RACW_From_Any
;
5349 -----------------------------
5350 -- Add_RACW_Read_Attribute --
5351 -----------------------------
5353 procedure Add_RACW_Read_Attribute
5354 (RACW_Type
: Entity_Id
;
5355 Stub_Type
: Entity_Id
;
5356 Stub_Type_Access
: Entity_Id
;
5357 Declarations
: List_Id
)
5359 pragma Warnings
(Off
);
5360 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
5361 pragma Warnings
(On
);
5362 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5364 Proc_Decl
: Node_Id
;
5365 Attr_Decl
: Node_Id
;
5367 Body_Node
: Node_Id
;
5370 Statements
: List_Id
;
5371 -- Various parts of the procedure
5373 Procedure_Name
: constant Name_Id
:=
5374 New_Internal_Name
('R');
5375 Source_Ref
: constant Entity_Id
:=
5376 Make_Defining_Identifier
5377 (Loc
, New_Internal_Name
('R'));
5378 Asynchronous_Flag
: constant Entity_Id
:=
5379 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5380 pragma Assert
(Present
(Asynchronous_Flag
));
5382 function Stream_Parameter
return Node_Id
;
5383 function Result
return Node_Id
;
5384 -- Functions to create occurrences of the formal parameter names
5390 function Result
return Node_Id
is
5392 return Make_Identifier
(Loc
, Name_V
);
5395 ----------------------
5396 -- Stream_Parameter --
5397 ----------------------
5399 function Stream_Parameter
return Node_Id
is
5401 return Make_Identifier
(Loc
, Name_S
);
5402 end Stream_Parameter
;
5404 -- Start of processing for Add_RACW_Read_Attribute
5407 -- Generate object declarations
5410 Make_Object_Declaration
(Loc
,
5411 Defining_Identifier
=> Source_Ref
,
5412 Object_Definition
=>
5413 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)));
5415 Statements
:= New_List
(
5416 Make_Attribute_Reference
(Loc
,
5418 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5419 Attribute_Name
=> Name_Read
,
5420 Expressions
=> New_List
(
5422 New_Occurrence_Of
(Source_Ref
, Loc
))),
5423 Make_Assignment_Statement
(Loc
,
5427 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
5429 Make_Function_Call
(Loc
,
5431 New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
5432 Parameter_Associations
=> New_List
(
5433 New_Occurrence_Of
(Source_Ref
, Loc
))),
5436 Build_Stream_Procedure
5437 (Loc
, RACW_Type
, Body_Node
,
5438 Make_Defining_Identifier
(Loc
, Procedure_Name
),
5439 Statements
, Outp
=> True);
5440 Set_Declarations
(Body_Node
, Decls
);
5442 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
5443 Copy_Specification
(Loc
, Specification
(Body_Node
)));
5446 Make_Attribute_Definition_Clause
(Loc
,
5447 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
5451 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
5453 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
5454 Insert_After
(Proc_Decl
, Attr_Decl
);
5455 Append_To
(Declarations
, Body_Node
);
5456 end Add_RACW_Read_Attribute
;
5458 ---------------------
5459 -- Add_RACW_To_Any --
5460 ---------------------
5462 procedure Add_RACW_To_Any
5463 (Designated_Type
: Entity_Id
;
5464 RACW_Type
: Entity_Id
;
5465 Stub_Type
: Entity_Id
;
5466 Stub_Type_Access
: Entity_Id
;
5467 Declarations
: List_Id
)
5469 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5471 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5475 Stub_Elements
: constant Stub_Structure
:=
5476 Stubs_Table
.Get
(Designated_Type
);
5477 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5479 Func_Spec
: Node_Id
;
5480 Func_Decl
: Node_Id
;
5481 Func_Body
: Node_Id
;
5484 Statements
: List_Id
;
5485 Null_Statements
: List_Id
;
5486 Local_Statements
: List_Id
:= No_List
;
5487 Stub_Statements
: List_Id
;
5489 -- Various parts of the subprogram
5491 RACW_Parameter
: constant Entity_Id
5492 := Make_Defining_Identifier
(Loc
, Name_R
);
5494 Reference
: constant Entity_Id
:=
5495 Make_Defining_Identifier
5496 (Loc
, New_Internal_Name
('R'));
5497 Any
: constant Entity_Id
:=
5498 Make_Defining_Identifier
5499 (Loc
, New_Internal_Name
('A'));
5502 -- Object declarations
5505 Make_Object_Declaration
(Loc
,
5506 Defining_Identifier
=>
5508 Object_Definition
=>
5509 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
5510 Make_Object_Declaration
(Loc
,
5511 Defining_Identifier
=>
5513 Object_Definition
=>
5514 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
5516 -- If the object is null, nothing to do (Reference is already
5519 Null_Statements
:= New_List
(Make_Null_Statement
(Loc
));
5523 -- If the object is a RAS designating a local subprogram,
5524 -- we already have a target reference.
5526 Local_Statements
:= New_List
(
5527 Make_Procedure_Call_Statement
(Loc
,
5529 New_Occurrence_Of
(RTE
(RE_Set_Ref
), Loc
),
5530 Parameter_Associations
=> New_List
(
5531 New_Occurrence_Of
(Reference
, Loc
),
5532 Make_Selected_Component
(Loc
,
5534 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
5535 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5536 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)))));
5539 -- If the object is a local RACW object, use Get_Reference now
5540 -- to obtain a reference.
5542 Local_Statements
:= New_List
(
5543 Make_Procedure_Call_Statement
(Loc
,
5545 New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
5546 Parameter_Associations
=> New_List
(
5547 Unchecked_Convert_To
(
5549 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5550 Make_String_Literal
(Loc
,
5551 Full_Qualified_Name
(Designated_Type
)),
5552 Make_Attribute_Reference
(Loc
,
5555 Defining_Identifier
(
5556 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5559 New_Occurrence_Of
(Reference
, Loc
))));
5562 -- If the object is located on another partition, use the target
5565 Stub_Statements
:= New_List
(
5566 Make_Procedure_Call_Statement
(Loc
,
5568 New_Occurrence_Of
(RTE
(RE_Set_Ref
), Loc
),
5569 Parameter_Associations
=> New_List
(
5570 New_Occurrence_Of
(Reference
, Loc
),
5571 Make_Selected_Component
(Loc
,
5572 Prefix
=> Unchecked_Convert_To
(Stub_Type_Access
,
5573 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5575 Make_Identifier
(Loc
, Name_Target
)))));
5577 -- Distinguish between the null, local and remote cases,
5578 -- and execute the appropriate piece of code.
5581 Make_Implicit_If_Statement
(RACW_Type
,
5584 Left_Opnd
=> New_Occurrence_Of
(RACW_Parameter
, Loc
),
5585 Right_Opnd
=> Make_Null
(Loc
)),
5586 Then_Statements
=> Null_Statements
,
5587 Elsif_Parts
=> New_List
(
5588 Make_Elsif_Part
(Loc
,
5592 Make_Attribute_Reference
(Loc
,
5594 New_Occurrence_Of
(RACW_Parameter
, Loc
),
5595 Attribute_Name
=> Name_Tag
),
5597 Make_Attribute_Reference
(Loc
,
5598 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
5599 Attribute_Name
=> Name_Tag
)),
5600 Then_Statements
=> Local_Statements
)),
5601 Else_Statements
=> Stub_Statements
);
5603 Statements
:= New_List
(
5605 Make_Assignment_Statement
(Loc
,
5607 New_Occurrence_Of
(Any
, Loc
),
5609 Make_Function_Call
(Loc
,
5610 Name
=> New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
5611 Parameter_Associations
=> New_List
(
5612 New_Occurrence_Of
(Reference
, Loc
)))),
5613 Make_Procedure_Call_Statement
(Loc
,
5615 New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
5616 Parameter_Associations
=> New_List
(
5617 New_Occurrence_Of
(Any
, Loc
),
5618 Make_Selected_Component
(Loc
,
5620 Defining_Identifier
(
5621 Stub_Elements
.RPC_Receiver_Decl
),
5622 Selector_Name
=> Name_Obj_TypeCode
))),
5623 Make_Return_Statement
(Loc
,
5625 New_Occurrence_Of
(Any
, Loc
)));
5627 Fnam
:= Make_Defining_Identifier
(
5628 Loc
, New_Internal_Name
('T'));
5631 Make_Function_Specification
(Loc
,
5632 Defining_Unit_Name
=>
5634 Parameter_Specifications
=> New_List
(
5635 Make_Parameter_Specification
(Loc
,
5636 Defining_Identifier
=>
5639 New_Occurrence_Of
(RACW_Type
, Loc
))),
5640 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
5642 -- NOTE: The usage occurrences of RACW_Parameter must
5643 -- refer to the entity in the declaration spec, not in
5646 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5649 Make_Subprogram_Body
(Loc
,
5651 Copy_Specification
(Loc
, Func_Spec
),
5652 Declarations
=> Decls
,
5653 Handled_Statement_Sequence
=>
5654 Make_Handled_Sequence_Of_Statements
(Loc
,
5655 Statements
=> Statements
));
5657 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5658 Append_To
(Declarations
, Func_Body
);
5660 Set_Renaming_TSS
(RACW_Type
, Fnam
, Name_uTo_Any
);
5661 end Add_RACW_To_Any
;
5663 -----------------------
5664 -- Add_RACW_TypeCode --
5665 -----------------------
5667 procedure Add_RACW_TypeCode
5668 (Designated_Type
: Entity_Id
;
5669 RACW_Type
: Entity_Id
;
5670 Declarations
: List_Id
)
5672 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5676 Stub_Elements
: constant Stub_Structure
:=
5677 Stubs_Table
.Get
(Designated_Type
);
5678 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5680 Func_Spec
: Node_Id
;
5681 Func_Decl
: Node_Id
;
5682 Func_Body
: Node_Id
;
5684 RACW_Parameter
: constant Entity_Id
:=
5685 Make_Defining_Identifier
(Loc
, Name_R
);
5689 Make_Defining_Identifier
(Loc
,
5690 Chars
=> New_Internal_Name
('T'));
5692 -- The spec for this subprogram has a dummy 'access RACW'
5693 -- argument, which serves only for overloading purposes.
5696 Make_Function_Specification
(Loc
,
5697 Defining_Unit_Name
=>
5699 Parameter_Specifications
=> New_List
(
5700 Make_Parameter_Specification
(Loc
,
5701 Defining_Identifier
=>
5704 Make_Access_Definition
(Loc
,
5706 New_Occurrence_Of
(RACW_Type
, Loc
)))),
5707 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
5709 -- NOTE: The usage occurrences of RACW_Parameter must
5710 -- refer to the entity in the declaration spec, not those
5711 -- of the body spec.
5713 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5716 Make_Subprogram_Body
(Loc
,
5718 Copy_Specification
(Loc
, Func_Spec
),
5719 Declarations
=> Empty_List
,
5720 Handled_Statement_Sequence
=>
5721 Make_Handled_Sequence_Of_Statements
(Loc
,
5722 Statements
=> New_List
(
5723 Make_Return_Statement
(Loc
,
5725 Make_Selected_Component
(Loc
,
5727 Defining_Identifier
(
5728 Stub_Elements
.RPC_Receiver_Decl
),
5729 Selector_Name
=> Name_Obj_TypeCode
)))));
5731 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5732 Append_To
(Declarations
, Func_Body
);
5734 Set_Renaming_TSS
(RACW_Type
, Fnam
, Name_uTypeCode
);
5735 end Add_RACW_TypeCode
;
5737 ------------------------------
5738 -- Add_RACW_Write_Attribute --
5739 ------------------------------
5741 procedure Add_RACW_Write_Attribute
5742 (RACW_Type
: Entity_Id
;
5743 Stub_Type
: Entity_Id
;
5744 Stub_Type_Access
: Entity_Id
;
5745 Declarations
: List_Id
)
5747 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5748 pragma Warnings
(Off
);
5749 pragma Unreferenced
(
5753 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5754 pragma Unreferenced
(Is_RAS
);
5755 pragma Warnings
(On
);
5757 Body_Node
: Node_Id
;
5758 Proc_Decl
: Node_Id
;
5759 Attr_Decl
: Node_Id
;
5761 Statements
: List_Id
;
5762 Procedure_Name
: constant Name_Id
:= New_Internal_Name
('R');
5764 function Stream_Parameter
return Node_Id
;
5765 function Object
return Node_Id
;
5766 -- Functions to create occurrences of the formal parameter names
5772 function Object
return Node_Id
is
5773 Object_Ref
: constant Node_Id
:=
5774 Make_Identifier
(Loc
, Name_V
);
5777 -- Etype must be set for Build_To_Any_Call
5779 Set_Etype
(Object_Ref
, RACW_Type
);
5784 ----------------------
5785 -- Stream_Parameter --
5786 ----------------------
5788 function Stream_Parameter
return Node_Id
is
5790 return Make_Identifier
(Loc
, Name_S
);
5791 end Stream_Parameter
;
5793 -- Start of processing for Add_RACW_Write_Attribute
5796 Statements
:= New_List
(
5797 Pack_Node_Into_Stream_Access
(Loc
,
5798 Stream
=> Stream_Parameter
,
5800 Make_Function_Call
(Loc
,
5802 New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
5803 Parameter_Associations
=> New_List
(
5804 PolyORB_Support
.Helpers
.Build_To_Any_Call
5805 (Object
, Declarations
))),
5806 Etyp
=> RTE
(RE_Object_Ref
)));
5808 Build_Stream_Procedure
5809 (Loc
, RACW_Type
, Body_Node
,
5810 Make_Defining_Identifier
(Loc
, Procedure_Name
),
5811 Statements
, Outp
=> False);
5814 Make_Subprogram_Declaration
(Loc
,
5815 Copy_Specification
(Loc
, Specification
(Body_Node
)));
5818 Make_Attribute_Definition_Clause
(Loc
,
5819 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
5820 Chars
=> Name_Write
,
5823 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
5825 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
5826 Insert_After
(Proc_Decl
, Attr_Decl
);
5827 Append_To
(Declarations
, Body_Node
);
5828 end Add_RACW_Write_Attribute
;
5830 -----------------------
5831 -- Add_RAST_Features --
5832 -----------------------
5834 procedure Add_RAST_Features
5835 (Vis_Decl
: Node_Id
;
5836 RAS_Type
: Entity_Id
;
5840 Add_RAS_Access_TSS
(Vis_Decl
);
5842 Add_RAS_From_Any
(RAS_Type
, Decls
);
5843 Add_RAS_TypeCode
(RAS_Type
, Decls
);
5845 -- To_Any uses TypeCode, and therefore needs to be generated last
5847 Add_RAS_To_Any
(RAS_Type
, Decls
);
5848 end Add_RAST_Features
;
5850 ------------------------
5851 -- Add_RAS_Access_TSS --
5852 ------------------------
5854 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
5855 Loc
: constant Source_Ptr
:= Sloc
(N
);
5857 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
5858 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
5859 -- Ras_Type is the access to subprogram type; Fat_Type is the
5860 -- corresponding record type.
5862 RACW_Type
: constant Entity_Id
:=
5863 Underlying_RACW_Type
(Ras_Type
);
5864 Desig
: constant Entity_Id
:=
5865 Etype
(Designated_Type
(RACW_Type
));
5867 Stub_Elements
: constant Stub_Structure
:=
5868 Stubs_Table
.Get
(Desig
);
5869 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5871 Proc
: constant Entity_Id
:=
5872 Make_Defining_Identifier
(Loc
,
5873 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
5875 Proc_Spec
: Node_Id
;
5877 -- Formal parameters
5879 Package_Name
: constant Entity_Id
:=
5880 Make_Defining_Identifier
(Loc
,
5885 Subp_Id
: constant Entity_Id
:=
5886 Make_Defining_Identifier
(Loc
,
5889 -- Target subprogram
5891 Asynch_P
: constant Entity_Id
:=
5892 Make_Defining_Identifier
(Loc
,
5893 Chars
=> Name_Asynchronous
);
5894 -- Is the procedure to which the 'Access applies asynchronous?
5896 All_Calls_Remote
: constant Entity_Id
:=
5897 Make_Defining_Identifier
(Loc
,
5898 Chars
=> Name_All_Calls_Remote
);
5899 -- True if an All_Calls_Remote pragma applies to the RCI unit
5900 -- that contains the subprogram.
5902 -- Common local variables
5904 Proc_Decls
: List_Id
;
5905 Proc_Statements
: List_Id
;
5907 Subp_Ref
: constant Entity_Id
:=
5908 Make_Defining_Identifier
(Loc
, Name_R
);
5909 -- Reference that designates the target subprogram (returned
5910 -- by Get_RAS_Info).
5912 Is_Local
: constant Entity_Id
:=
5913 Make_Defining_Identifier
(Loc
, Name_L
);
5914 Local_Addr
: constant Entity_Id
:=
5915 Make_Defining_Identifier
(Loc
, Name_A
);
5916 -- For the call to Get_Local_Address
5918 -- Additional local variables for the remote case
5920 Local_Stub
: constant Entity_Id
:=
5921 Make_Defining_Identifier
(Loc
,
5922 Chars
=> New_Internal_Name
('L'));
5924 Stub_Ptr
: constant Entity_Id
:=
5925 Make_Defining_Identifier
(Loc
,
5926 Chars
=> New_Internal_Name
('S'));
5929 (Field_Name
: Name_Id
;
5930 Value
: Node_Id
) return Node_Id
;
5931 -- Construct an assignment that sets the named component in the
5939 (Field_Name
: Name_Id
;
5940 Value
: Node_Id
) return Node_Id
5944 Make_Assignment_Statement
(Loc
,
5946 Make_Selected_Component
(Loc
,
5948 Selector_Name
=> Field_Name
),
5949 Expression
=> Value
);
5952 -- Start of processing for Add_RAS_Access_TSS
5955 Proc_Decls
:= New_List
(
5957 -- Common declarations
5959 Make_Object_Declaration
(Loc
,
5960 Defining_Identifier
=> Subp_Ref
,
5961 Object_Definition
=>
5962 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
5964 Make_Object_Declaration
(Loc
,
5965 Defining_Identifier
=> Is_Local
,
5966 Object_Definition
=>
5967 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
5969 Make_Object_Declaration
(Loc
,
5970 Defining_Identifier
=> Local_Addr
,
5971 Object_Definition
=>
5972 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
5974 Make_Object_Declaration
(Loc
,
5975 Defining_Identifier
=> Local_Stub
,
5976 Aliased_Present
=> True,
5977 Object_Definition
=>
5978 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
5980 Make_Object_Declaration
(Loc
,
5981 Defining_Identifier
=>
5983 Object_Definition
=>
5984 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
5986 Make_Attribute_Reference
(Loc
,
5987 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
5988 Attribute_Name
=> Name_Unchecked_Access
)));
5990 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
5991 -- Build_Get_Unique_RP_Call needs this information
5993 -- Get_RAS_Info (Pkg, Subp, R);
5994 -- Obtain a reference to the target subprogram
5996 Proc_Statements
:= New_List
(
5997 Make_Procedure_Call_Statement
(Loc
,
5999 New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
6000 Parameter_Associations
=> New_List
(
6001 New_Occurrence_Of
(Package_Name
, Loc
),
6002 New_Occurrence_Of
(Subp_Id
, Loc
),
6003 New_Occurrence_Of
(Subp_Ref
, Loc
))),
6005 -- Get_Local_Address (R, L, A);
6006 -- Determine whether the subprogram is local (L), and if so
6007 -- obtain the local address of its proxy (A).
6009 Make_Procedure_Call_Statement
(Loc
,
6011 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6012 Parameter_Associations
=> New_List
(
6013 New_Occurrence_Of
(Subp_Ref
, Loc
),
6014 New_Occurrence_Of
(Is_Local
, Loc
),
6015 New_Occurrence_Of
(Local_Addr
, Loc
))));
6017 -- Note: Here we assume that the Fat_Type is a record containing just
6018 -- an access to a proxy or stub object.
6020 Append_To
(Proc_Statements
,
6024 Make_Implicit_If_Statement
(N
,
6026 New_Occurrence_Of
(Is_Local
, Loc
),
6028 Then_Statements
=> New_List
(
6030 -- if A.Target = null then
6032 Make_Implicit_If_Statement
(N
,
6035 Make_Selected_Component
(Loc
,
6037 Unchecked_Convert_To
(
6038 RTE
(RE_RAS_Proxy_Type_Access
),
6039 New_Occurrence_Of
(Local_Addr
, Loc
)),
6041 Make_Identifier
(Loc
, Name_Target
)),
6044 Then_Statements
=> New_List
(
6046 -- A.Target := Entity_Of (Ref);
6048 Make_Assignment_Statement
(Loc
,
6050 Make_Selected_Component
(Loc
,
6052 Unchecked_Convert_To
(
6053 RTE
(RE_RAS_Proxy_Type_Access
),
6054 New_Occurrence_Of
(Local_Addr
, Loc
)),
6056 Make_Identifier
(Loc
, Name_Target
)),
6058 Make_Function_Call
(Loc
,
6060 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6061 Parameter_Associations
=> New_List
(
6062 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6064 -- Inc_Usage (A.Target);
6066 Make_Procedure_Call_Statement
(Loc
,
6068 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6069 Parameter_Associations
=> New_List
(
6070 Make_Selected_Component
(Loc
,
6072 Unchecked_Convert_To
(
6073 RTE
(RE_RAS_Proxy_Type_Access
),
6074 New_Occurrence_Of
(Local_Addr
, Loc
)),
6075 Selector_Name
=> Make_Identifier
(Loc
,
6079 -- if not All_Calls_Remote then
6080 -- return Fat_Type!(A);
6083 Make_Implicit_If_Statement
(N
,
6086 New_Occurrence_Of
(All_Calls_Remote
, Loc
)),
6088 Then_Statements
=> New_List
(
6089 Make_Return_Statement
(Loc
,
6090 Unchecked_Convert_To
(Fat_Type
,
6091 New_Occurrence_Of
(Local_Addr
, Loc
))))))));
6093 Append_List_To
(Proc_Statements
, New_List
(
6095 -- Stub.Target := Entity_Of (Ref);
6097 Set_Field
(Name_Target
,
6098 Make_Function_Call
(Loc
,
6100 New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6101 Parameter_Associations
=> New_List
(
6102 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6104 -- Inc_Usage (Stub.Target);
6106 Make_Procedure_Call_Statement
(Loc
,
6108 New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6109 Parameter_Associations
=> New_List
(
6110 Make_Selected_Component
(Loc
,
6112 Selector_Name
=> Name_Target
))),
6114 -- E.4.1(9) A remote call is asynchronous if it is a call to
6115 -- a procedure, or a call through a value of an access-to-procedure
6116 -- type, to which a pragma Asynchronous applies.
6118 -- Parameter Asynch_P is true when the procedure is asynchronous;
6119 -- Expression Asynch_T is true when the type is asynchronous.
6121 Set_Field
(Name_Asynchronous
,
6123 New_Occurrence_Of
(Asynch_P
, Loc
),
6124 New_Occurrence_Of
(Boolean_Literals
(
6125 Is_Asynchronous
(Ras_Type
)), Loc
)))));
6127 Append_List_To
(Proc_Statements
,
6128 Build_Get_Unique_RP_Call
(Loc
,
6129 Stub_Ptr
, Stub_Elements
.Stub_Type
));
6131 Append_To
(Proc_Statements
,
6132 Make_Return_Statement
(Loc
,
6134 Unchecked_Convert_To
(Fat_Type
,
6135 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
6138 Make_Function_Specification
(Loc
,
6139 Defining_Unit_Name
=> Proc
,
6140 Parameter_Specifications
=> New_List
(
6141 Make_Parameter_Specification
(Loc
,
6142 Defining_Identifier
=> Package_Name
,
6144 New_Occurrence_Of
(Standard_String
, Loc
)),
6146 Make_Parameter_Specification
(Loc
,
6147 Defining_Identifier
=> Subp_Id
,
6149 New_Occurrence_Of
(Standard_String
, Loc
)),
6151 Make_Parameter_Specification
(Loc
,
6152 Defining_Identifier
=> Asynch_P
,
6154 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6156 Make_Parameter_Specification
(Loc
,
6157 Defining_Identifier
=> All_Calls_Remote
,
6159 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
6162 New_Occurrence_Of
(Fat_Type
, Loc
));
6164 -- Set the kind and return type of the function to prevent
6165 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6167 Set_Ekind
(Proc
, E_Function
);
6168 Set_Etype
(Proc
, Fat_Type
);
6171 Make_Subprogram_Body
(Loc
,
6172 Specification
=> Proc_Spec
,
6173 Declarations
=> Proc_Decls
,
6174 Handled_Statement_Sequence
=>
6175 Make_Handled_Sequence_Of_Statements
(Loc
,
6176 Statements
=> Proc_Statements
)));
6178 Set_TSS
(Fat_Type
, Proc
);
6179 end Add_RAS_Access_TSS
;
6181 ----------------------
6182 -- Add_RAS_From_Any --
6183 ----------------------
6185 procedure Add_RAS_From_Any
6186 (RAS_Type
: Entity_Id
;
6187 Declarations
: List_Id
)
6189 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6191 Fnam
: constant Entity_Id
:=
6192 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F'));
6194 Func_Spec
: Node_Id
;
6195 Func_Decl
: Node_Id
;
6196 Func_Body
: Node_Id
;
6198 Statements
: List_Id
;
6200 Any_Parameter
: constant Entity_Id
:=
6201 Make_Defining_Identifier
(Loc
, Name_A
);
6204 Statements
:= New_List
(
6205 Make_Return_Statement
(Loc
,
6207 Make_Aggregate
(Loc
,
6208 Component_Associations
=> New_List
(
6209 Make_Component_Association
(Loc
,
6210 Choices
=> New_List
(
6211 Make_Identifier
(Loc
, Name_Ras
)),
6213 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
6214 Underlying_RACW_Type
(RAS_Type
),
6215 New_Occurrence_Of
(Any_Parameter
, Loc
),
6219 Make_Function_Specification
(Loc
,
6220 Defining_Unit_Name
=>
6222 Parameter_Specifications
=> New_List
(
6223 Make_Parameter_Specification
(Loc
,
6224 Defining_Identifier
=>
6227 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
6228 Subtype_Mark
=> New_Occurrence_Of
(RAS_Type
, Loc
));
6230 -- NOTE: The usage occurrences of RACW_Parameter must
6231 -- refer to the entity in the declaration spec, not those
6232 -- of the body spec.
6234 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
6237 Make_Subprogram_Body
(Loc
,
6239 Copy_Specification
(Loc
, Func_Spec
),
6240 Declarations
=> No_List
,
6241 Handled_Statement_Sequence
=>
6242 Make_Handled_Sequence_Of_Statements
(Loc
,
6243 Statements
=> Statements
));
6245 Insert_After
(Declaration_Node
(RAS_Type
), Func_Decl
);
6246 Append_To
(Declarations
, Func_Body
);
6248 Set_Renaming_TSS
(RAS_Type
, Fnam
, Name_uFrom_Any
);
6249 end Add_RAS_From_Any
;
6251 --------------------
6252 -- Add_RAS_To_Any --
6253 --------------------
6255 procedure Add_RAS_To_Any
6256 (RAS_Type
: Entity_Id
;
6257 Declarations
: List_Id
)
6259 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6264 Statements
: List_Id
;
6266 Func_Spec
: Node_Id
;
6267 Func_Decl
: Node_Id
;
6268 Func_Body
: Node_Id
;
6270 Any
: constant Entity_Id
:=
6271 Make_Defining_Identifier
(Loc
,
6272 Chars
=> New_Internal_Name
('A'));
6273 RAS_Parameter
: constant Entity_Id
:=
6274 Make_Defining_Identifier
(Loc
,
6275 Chars
=> New_Internal_Name
('R'));
6276 RACW_Parameter
: constant Node_Id
:=
6277 Make_Selected_Component
(Loc
,
6278 Prefix
=> RAS_Parameter
,
6279 Selector_Name
=> Name_Ras
);
6282 -- Object declarations
6284 Set_Etype
(RACW_Parameter
, Underlying_RACW_Type
(RAS_Type
));
6286 Make_Object_Declaration
(Loc
,
6287 Defining_Identifier
=>
6289 Object_Definition
=>
6290 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
6292 PolyORB_Support
.Helpers
.Build_To_Any_Call
6293 (RACW_Parameter
, No_List
)));
6295 Statements
:= New_List
(
6296 Make_Procedure_Call_Statement
(Loc
,
6298 New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
6299 Parameter_Associations
=> New_List
(
6300 New_Occurrence_Of
(Any
, Loc
),
6301 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
6303 Make_Return_Statement
(Loc
,
6305 New_Occurrence_Of
(Any
, Loc
)));
6307 Fnam
:= Make_Defining_Identifier
(
6308 Loc
, New_Internal_Name
('T'));
6311 Make_Function_Specification
(Loc
,
6312 Defining_Unit_Name
=>
6314 Parameter_Specifications
=> New_List
(
6315 Make_Parameter_Specification
(Loc
,
6316 Defining_Identifier
=>
6319 New_Occurrence_Of
(RAS_Type
, Loc
))),
6320 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
6322 -- NOTE: The usage occurrences of RAS_Parameter must
6323 -- refer to the entity in the declaration spec, not in
6326 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
6329 Make_Subprogram_Body
(Loc
,
6331 Copy_Specification
(Loc
, Func_Spec
),
6332 Declarations
=> Decls
,
6333 Handled_Statement_Sequence
=>
6334 Make_Handled_Sequence_Of_Statements
(Loc
,
6335 Statements
=> Statements
));
6337 Insert_After
(Declaration_Node
(RAS_Type
), Func_Decl
);
6338 Append_To
(Declarations
, Func_Body
);
6340 Set_Renaming_TSS
(RAS_Type
, Fnam
, Name_uTo_Any
);
6343 ----------------------
6344 -- Add_RAS_TypeCode --
6345 ----------------------
6347 procedure Add_RAS_TypeCode
6348 (RAS_Type
: Entity_Id
;
6349 Declarations
: List_Id
)
6351 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6355 Func_Spec
: Node_Id
;
6356 Func_Decl
: Node_Id
;
6357 Func_Body
: Node_Id
;
6359 Decls
: constant List_Id
:= New_List
;
6360 Name_String
, Repo_Id_String
: String_Id
;
6362 RAS_Parameter
: constant Entity_Id
:=
6363 Make_Defining_Identifier
(Loc
, Name_R
);
6368 Make_Defining_Identifier
(Loc
,
6369 Chars
=> New_Internal_Name
('T'));
6371 -- The spec for this subprogram has a dummy 'access RAS'
6372 -- argument, which serves only for overloading purposes.
6375 Make_Function_Specification
(Loc
,
6376 Defining_Unit_Name
=>
6378 Parameter_Specifications
=> New_List
(
6379 Make_Parameter_Specification
(Loc
,
6380 Defining_Identifier
=>
6383 Make_Access_Definition
(Loc
,
6384 Subtype_Mark
=> New_Occurrence_Of
(RAS_Type
, Loc
)))),
6385 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6387 -- NOTE: The usage occurrences of RAS_Parameter must
6388 -- refer to the entity in the declaration spec, not those
6389 -- of the body spec.
6391 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
6393 PolyORB_Support
.Helpers
.Build_Name_And_Repository_Id
6394 (RAS_Type
, Name_Str
=> Name_String
, Repo_Id_Str
=> Repo_Id_String
);
6397 Make_Subprogram_Body
(Loc
,
6399 Copy_Specification
(Loc
, Func_Spec
),
6400 Declarations
=> Decls
,
6401 Handled_Statement_Sequence
=>
6402 Make_Handled_Sequence_Of_Statements
(Loc
,
6403 Statements
=> New_List
(
6404 Make_Return_Statement
(Loc
,
6406 Make_Function_Call
(Loc
,
6408 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
6409 Parameter_Associations
=> New_List
(
6410 New_Occurrence_Of
(RTE
(RE_TC_Object
), Loc
),
6411 Make_Aggregate
(Loc
,
6414 Make_Function_Call
(Loc
,
6415 Name
=> New_Occurrence_Of
(
6416 RTE
(RE_TA_String
), Loc
),
6417 Parameter_Associations
=> New_List
(
6418 Make_String_Literal
(Loc
, Name_String
))),
6419 Make_Function_Call
(Loc
,
6420 Name
=> New_Occurrence_Of
(
6421 RTE
(RE_TA_String
), Loc
),
6422 Parameter_Associations
=> New_List
(
6423 Make_String_Literal
(Loc
,
6424 Repo_Id_String
)))))))))));
6426 Insert_After
(Declaration_Node
(RAS_Type
), Func_Decl
);
6427 Append_To
(Declarations
, Func_Body
);
6429 Set_Renaming_TSS
(RAS_Type
, Fnam
, Name_uTypeCode
);
6430 end Add_RAS_TypeCode
;
6432 -----------------------------------------
6433 -- Add_Receiving_Stubs_To_Declarations --
6434 -----------------------------------------
6436 procedure Add_Receiving_Stubs_To_Declarations
6437 (Pkg_Spec
: Node_Id
;
6440 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
6442 Pkg_RPC_Receiver
: constant Entity_Id
:=
6443 Make_Defining_Identifier
(Loc
,
6444 New_Internal_Name
('H'));
6445 Pkg_RPC_Receiver_Object
: Node_Id
;
6447 Pkg_RPC_Receiver_Body
: Node_Id
;
6448 Pkg_RPC_Receiver_Decls
: List_Id
;
6449 Pkg_RPC_Receiver_Statements
: List_Id
;
6450 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
6451 -- A Pkg_RPC_Receiver is built to decode the request
6454 -- Request object received from neutral layer
6456 Subp_Id
: Entity_Id
;
6457 -- Subprogram identifier as received from the neutral
6458 -- distribution core.
6460 Subp_Index
: Entity_Id
;
6461 -- Internal index as determined by matching either the
6462 -- method name from the request structure, or the local
6463 -- subprogram address (in case of a RAS).
6465 Is_Local
: constant Entity_Id
:=
6466 Make_Defining_Identifier
(Loc
, New_Internal_Name
('L'));
6467 Local_Address
: constant Entity_Id
:=
6468 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
6469 -- Address of a local subprogram designated by a
6470 -- reference corresponding to a RAS.
6472 Dispatch_On_Address
: constant List_Id
:= New_List
;
6473 Dispatch_On_Name
: constant List_Id
:= New_List
;
6475 Current_Declaration
: Node_Id
;
6476 Current_Stubs
: Node_Id
;
6477 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
6479 Subp_Info_Array
: constant Entity_Id
:=
6480 Make_Defining_Identifier
(Loc
,
6481 Chars
=> New_Internal_Name
('I'));
6483 Subp_Info_List
: constant List_Id
:= New_List
;
6485 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
6487 All_Calls_Remote_E
: Entity_Id
;
6489 procedure Append_Stubs_To
6490 (RPC_Receiver_Cases
: List_Id
;
6491 Declaration
: Node_Id
;
6494 Subp_Dist_Name
: Entity_Id
;
6495 Subp_Proxy_Addr
: Entity_Id
);
6496 -- Add one case to the specified RPC receiver case list associating
6497 -- Subprogram_Number with the subprogram declared by Declaration, for
6498 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6499 -- subprogram index. Subp_Dist_Name is the string used to call the
6500 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6501 -- object, used in the context of calls through remote
6502 -- access-to-subprogram types.
6504 ---------------------
6505 -- Append_Stubs_To --
6506 ---------------------
6508 procedure Append_Stubs_To
6509 (RPC_Receiver_Cases
: List_Id
;
6510 Declaration
: Node_Id
;
6513 Subp_Dist_Name
: Entity_Id
;
6514 Subp_Proxy_Addr
: Entity_Id
)
6516 Case_Stmts
: List_Id
;
6518 Case_Stmts
:= New_List
(
6519 Make_Procedure_Call_Statement
(Loc
,
6522 Defining_Entity
(Stubs
), Loc
),
6523 Parameter_Associations
=>
6524 New_List
(New_Occurrence_Of
(Request
, Loc
))));
6525 if Nkind
(Specification
(Declaration
))
6526 = N_Function_Specification
6528 Is_Asynchronous
(Defining_Entity
(Specification
(Declaration
)))
6530 Append_To
(Case_Stmts
, Make_Return_Statement
(Loc
));
6533 Append_To
(RPC_Receiver_Cases
,
6534 Make_Case_Statement_Alternative
(Loc
,
6536 New_List
(Make_Integer_Literal
(Loc
, Subp_Number
)),
6540 Append_To
(Dispatch_On_Name
,
6541 Make_Elsif_Part
(Loc
,
6543 Make_Function_Call
(Loc
,
6545 New_Occurrence_Of
(RTE
(RE_Caseless_String_Eq
), Loc
),
6546 Parameter_Associations
=> New_List
(
6547 New_Occurrence_Of
(Subp_Id
, Loc
),
6548 New_Occurrence_Of
(Subp_Dist_Name
, Loc
))),
6549 Then_Statements
=> New_List
(
6550 Make_Assignment_Statement
(Loc
,
6551 New_Occurrence_Of
(Subp_Index
, Loc
),
6552 Make_Integer_Literal
(Loc
,
6555 Append_To
(Dispatch_On_Address
,
6556 Make_Elsif_Part
(Loc
,
6560 New_Occurrence_Of
(Local_Address
, Loc
),
6562 New_Occurrence_Of
(Subp_Proxy_Addr
, Loc
)),
6563 Then_Statements
=> New_List
(
6564 Make_Assignment_Statement
(Loc
,
6565 New_Occurrence_Of
(Subp_Index
, Loc
),
6566 Make_Integer_Literal
(Loc
,
6568 end Append_Stubs_To
;
6570 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6573 -- Building receiving stubs consist in several operations:
6575 -- - a package RPC receiver must be built. This subprogram
6576 -- will get a Subprogram_Id from the incoming stream
6577 -- and will dispatch the call to the right subprogram
6579 -- - a receiving stub for any subprogram visible in the package
6580 -- spec. This stub will read all the parameters from the stream,
6581 -- and put the result as well as the exception occurrence in the
6584 -- - a dummy package with an empty spec and a body made of an
6585 -- elaboration part, whose job is to register the receiving
6586 -- part of this RCI package on the name server. This is done
6587 -- by calling System.Partition_Interface.Register_Receiving_Stub
6589 Build_RPC_Receiver_Body
(
6590 RPC_Receiver
=> Pkg_RPC_Receiver
,
6593 Subp_Index
=> Subp_Index
,
6594 Stmts
=> Pkg_RPC_Receiver_Statements
,
6595 Decl
=> Pkg_RPC_Receiver_Body
);
6596 Pkg_RPC_Receiver_Decls
:= Declarations
(Pkg_RPC_Receiver_Body
);
6598 -- Extract local address information from the target reference:
6599 -- if non-null, that means that this is a reference that denotes
6600 -- one particular operation, and hence that the operation name
6601 -- must not be taken into account for dispatching.
6603 Append_To
(Pkg_RPC_Receiver_Decls
,
6604 Make_Object_Declaration
(Loc
,
6605 Defining_Identifier
=>
6607 Object_Definition
=>
6608 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
6609 Append_To
(Pkg_RPC_Receiver_Decls
,
6610 Make_Object_Declaration
(Loc
,
6611 Defining_Identifier
=>
6613 Object_Definition
=>
6614 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6615 Append_To
(Pkg_RPC_Receiver_Statements
,
6616 Make_Procedure_Call_Statement
(Loc
,
6618 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6619 Parameter_Associations
=> New_List
(
6620 Make_Selected_Component
(Loc
,
6622 Selector_Name
=> Name_Target
),
6623 New_Occurrence_Of
(Is_Local
, Loc
),
6624 New_Occurrence_Of
(Local_Address
, Loc
))));
6626 -- Determine whether the reference that was used to make
6627 -- the call was the base RCI reference (in which case
6628 -- Local_Address is 0, and the method identifier from the
6629 -- request must be used to determine which subprogram is
6630 -- called) or a reference identifying one particular subprogram
6631 -- (in which case Local_Address is the address of that
6632 -- subprogram, and the method name from the request is
6634 -- In each case, cascaded elsifs are used to determine the
6635 -- proper subprogram index. Using hash tables might be
6638 Append_To
(Pkg_RPC_Receiver_Statements
,
6639 Make_Implicit_If_Statement
(Pkg_Spec
,
6642 Left_Opnd
=> New_Occurrence_Of
(Local_Address
, Loc
),
6643 Right_Opnd
=> New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)),
6644 Then_Statements
=> New_List
(
6645 Make_Implicit_If_Statement
(Pkg_Spec
,
6647 New_Occurrence_Of
(Standard_False
, Loc
),
6648 Then_Statements
=> New_List
(
6649 Make_Null_Statement
(Loc
)),
6651 Dispatch_On_Address
)),
6652 Else_Statements
=> New_List
(
6653 Make_Implicit_If_Statement
(Pkg_Spec
,
6655 New_Occurrence_Of
(Standard_False
, Loc
),
6656 Then_Statements
=> New_List
(
6657 Make_Null_Statement
(Loc
)),
6659 Dispatch_On_Name
))));
6661 -- For each subprogram, the receiving stub will be built and a
6662 -- case statement will be made on the Subprogram_Id to dispatch
6663 -- to the right subprogram.
6665 All_Calls_Remote_E
:= Boolean_Literals
(
6666 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
6668 Overload_Counter_Table
.Reset
;
6669 Reserve_NamingContext_Methods
;
6671 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
6672 while Present
(Current_Declaration
) loop
6673 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
6674 and then Comes_From_Source
(Current_Declaration
)
6677 Loc
: constant Source_Ptr
:=
6678 Sloc
(Current_Declaration
);
6679 -- While specifically processing Current_Declaration, use
6680 -- its Sloc as the location of all generated nodes.
6682 Subp_Def
: constant Entity_Id
:=
6684 (Specification
(Current_Declaration
));
6686 Subp_Val
: String_Id
;
6688 Subp_Dist_Name
: constant Entity_Id
:=
6689 Make_Defining_Identifier
(Loc
,
6691 Related_Id
=> Chars
(Subp_Def
),
6693 Suffix_Index
=> -1));
6695 Proxy_Object_Addr
: Entity_Id
;
6698 pragma Assert
(Current_Subprogram_Number
=
6699 Get_Subprogram_Id
(Subp_Def
));
6701 -- Build receiving stub
6704 Build_Subprogram_Receiving_Stubs
6705 (Vis_Decl
=> Current_Declaration
,
6707 Nkind
(Specification
(Current_Declaration
)) =
6708 N_Procedure_Specification
6709 and then Is_Asynchronous
(Subp_Def
));
6711 Append_To
(Decls
, Current_Stubs
);
6712 Analyze
(Current_Stubs
);
6716 Add_RAS_Proxy_And_Analyze
(Decls
,
6718 Current_Declaration
,
6719 All_Calls_Remote_E
=>
6721 Proxy_Object_Addr
=>
6724 -- Compute distribution identifier
6726 Assign_Subprogram_Identifier
(
6728 Current_Subprogram_Number
,
6732 Make_Object_Declaration
(Loc
,
6733 Defining_Identifier
=> Subp_Dist_Name
,
6734 Constant_Present
=> True,
6735 Object_Definition
=> New_Occurrence_Of
(
6736 Standard_String
, Loc
),
6738 Make_String_Literal
(Loc
, Subp_Val
)));
6739 Analyze
(Last
(Decls
));
6741 -- Add subprogram descriptor (RCI_Subp_Info) to the
6742 -- subprograms table for this receiver. The aggregate
6743 -- below must be kept consistent with the declaration
6744 -- of type RCI_Subp_Info in System.Partition_Interface.
6746 Append_To
(Subp_Info_List
,
6747 Make_Component_Association
(Loc
,
6748 Choices
=> New_List
(
6749 Make_Integer_Literal
(Loc
,
6750 Current_Subprogram_Number
)),
6752 Make_Aggregate
(Loc
,
6753 Expressions
=> New_List
(
6754 Make_Attribute_Reference
(Loc
,
6757 Subp_Dist_Name
, Loc
),
6758 Attribute_Name
=> Name_Address
),
6759 Make_Attribute_Reference
(Loc
,
6762 Subp_Dist_Name
, Loc
),
6763 Attribute_Name
=> Name_Length
),
6764 New_Occurrence_Of
(Proxy_Object_Addr
, Loc
)))));
6766 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
6767 Declaration
=> Current_Declaration
,
6768 Stubs
=> Current_Stubs
,
6769 Subp_Number
=> Current_Subprogram_Number
,
6770 Subp_Dist_Name
=> Subp_Dist_Name
,
6771 Subp_Proxy_Addr
=> Proxy_Object_Addr
);
6774 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
6777 Next
(Current_Declaration
);
6780 -- If we receive an invalid Subprogram_Id, it is best to do nothing
6781 -- rather than raising an exception since we do not want someone
6782 -- to crash a remote partition by sending invalid subprogram ids.
6783 -- This is consistent with the other parts of the case statement
6784 -- since even in presence of incorrect parameters in the stream,
6785 -- every exception will be caught and (if the subprogram is not an
6786 -- APC) put into the result stream and sent away.
6788 Append_To
(Pkg_RPC_Receiver_Cases
,
6789 Make_Case_Statement_Alternative
(Loc
,
6791 New_List
(Make_Others_Choice
(Loc
)),
6793 New_List
(Make_Null_Statement
(Loc
))));
6795 Append_To
(Pkg_RPC_Receiver_Statements
,
6796 Make_Case_Statement
(Loc
,
6798 New_Occurrence_Of
(Subp_Index
, Loc
),
6799 Alternatives
=> Pkg_RPC_Receiver_Cases
));
6802 Make_Object_Declaration
(Loc
,
6803 Defining_Identifier
=> Subp_Info_Array
,
6804 Constant_Present
=> True,
6805 Aliased_Present
=> True,
6806 Object_Definition
=>
6807 Make_Subtype_Indication
(Loc
,
6809 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
6811 Make_Index_Or_Discriminant_Constraint
(Loc
,
6814 Low_Bound
=> Make_Integer_Literal
(Loc
,
6815 First_RCI_Subprogram_Id
),
6817 Make_Integer_Literal
(Loc
,
6818 First_RCI_Subprogram_Id
6819 + List_Length
(Subp_Info_List
) - 1))))),
6821 Make_Aggregate
(Loc
,
6822 Component_Associations
=> Subp_Info_List
)));
6823 Analyze
(Last
(Decls
));
6825 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
6826 Analyze
(Last
(Decls
));
6828 Pkg_RPC_Receiver_Object
:=
6829 Make_Object_Declaration
(Loc
,
6830 Defining_Identifier
=>
6831 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
6832 Aliased_Present
=> True,
6833 Object_Definition
=>
6834 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
6835 Append_To
(Decls
, Pkg_RPC_Receiver_Object
);
6836 Analyze
(Last
(Decls
));
6838 Get_Library_Unit_Name_String
(Pkg_Spec
);
6839 Append_To
(Register_Pkg_Actuals
,
6841 Make_String_Literal
(Loc
,
6842 Strval
=> String_From_Name_Buffer
));
6844 Append_To
(Register_Pkg_Actuals
,
6846 Make_Attribute_Reference
(Loc
,
6849 (Defining_Entity
(Pkg_Spec
), Loc
),
6853 Append_To
(Register_Pkg_Actuals
,
6855 Make_Attribute_Reference
(Loc
,
6857 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
6858 Attribute_Name
=> Name_Access
));
6860 Append_To
(Register_Pkg_Actuals
,
6862 Make_Attribute_Reference
(Loc
,
6865 Defining_Identifier
(
6866 Pkg_RPC_Receiver_Object
), Loc
),
6870 Append_To
(Register_Pkg_Actuals
,
6872 Make_Attribute_Reference
(Loc
,
6874 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
6878 Append_To
(Register_Pkg_Actuals
,
6880 Make_Attribute_Reference
(Loc
,
6882 New_Occurrence_Of
(Subp_Info_Array
, Loc
),
6886 Append_To
(Register_Pkg_Actuals
,
6887 -- Is_All_Calls_Remote
6888 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
));
6891 Make_Procedure_Call_Statement
(Loc
,
6893 New_Occurrence_Of
(RTE
(RE_Register_Pkg_Receiving_Stub
), Loc
),
6894 Parameter_Associations
=> Register_Pkg_Actuals
));
6895 Analyze
(Last
(Decls
));
6897 end Add_Receiving_Stubs_To_Declarations
;
6899 ---------------------------------
6900 -- Build_General_Calling_Stubs --
6901 ---------------------------------
6903 procedure Build_General_Calling_Stubs
6905 Statements
: List_Id
;
6906 Target_Object
: Node_Id
;
6907 Subprogram_Id
: Node_Id
;
6908 Asynchronous
: Node_Id
:= Empty
;
6909 Is_Known_Asynchronous
: Boolean := False;
6910 Is_Known_Non_Asynchronous
: Boolean := False;
6911 Is_Function
: Boolean;
6913 Stub_Type
: Entity_Id
:= Empty
;
6914 RACW_Type
: Entity_Id
:= Empty
;
6917 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
6919 Arguments
: Node_Id
;
6920 -- Name of the named values list used to transmit parameters
6921 -- to the remote package
6924 -- The request object constructed by these stubs
6927 -- Name of the result named value (in non-APC cases) which get the
6928 -- result of the remote subprogram.
6930 Result_TC
: Node_Id
;
6931 -- Typecode expression for the result of the request (void
6932 -- typecode for procedures).
6934 Exception_Return_Parameter
: Node_Id
;
6935 -- Name of the parameter which will hold the exception sent by the
6936 -- remote subprogram.
6938 Current_Parameter
: Node_Id
;
6939 -- Current parameter being handled
6941 Ordered_Parameters_List
: constant List_Id
:=
6942 Build_Ordered_Parameters_List
(Spec
);
6944 Asynchronous_P
: Node_Id
;
6945 -- A Boolean expression indicating whether this call is asynchronous
6947 Asynchronous_Statements
: List_Id
:= No_List
;
6948 Non_Asynchronous_Statements
: List_Id
:= No_List
;
6949 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
6951 Extra_Formal_Statements
: constant List_Id
:= New_List
;
6952 -- List of statements for extra formal parameters. It will appear
6953 -- after the regular statements for writing out parameters.
6955 After_Statements
: constant List_Id
:= New_List
;
6956 -- Statements to be executed after call returns (to assign
6957 -- in out or out parameter values).
6960 -- The type of the formal parameter being processed
6962 Is_Controlling_Formal
: Boolean;
6963 Is_First_Controlling_Formal
: Boolean;
6964 First_Controlling_Formal_Seen
: Boolean := False;
6965 -- Controlling formal parameters of distributed object
6966 -- primitives require special handling, and the first
6967 -- such parameter needs even more.
6970 -- ??? document general form of stub subprograms for the PolyORB case
6972 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
6975 Make_Object_Declaration
(Loc
,
6976 Defining_Identifier
=> Request
,
6977 Aliased_Present
=> False,
6978 Object_Definition
=>
6979 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
)));
6982 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
6985 Result_TC
:= PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
6986 Etype
(Subtype_Mark
(Spec
)), Decls
);
6988 Result_TC
:= New_Occurrence_Of
(RTE
(RE_TC_Void
), Loc
);
6992 Make_Object_Declaration
(Loc
,
6993 Defining_Identifier
=> Result
,
6994 Aliased_Present
=> False,
6995 Object_Definition
=>
6996 New_Occurrence_Of
(RTE
(RE_NamedValue
), Loc
),
6998 Make_Aggregate
(Loc
,
6999 Component_Associations
=> New_List
(
7000 Make_Component_Association
(Loc
,
7001 Choices
=> New_List
(
7002 Make_Identifier
(Loc
, Name_Name
)),
7004 New_Occurrence_Of
(RTE
(RE_Result_Name
), Loc
)),
7005 Make_Component_Association
(Loc
,
7006 Choices
=> New_List
(
7007 Make_Identifier
(Loc
, Name_Argument
)),
7009 Make_Function_Call
(Loc
,
7011 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7012 Parameter_Associations
=> New_List
(
7014 Make_Component_Association
(Loc
,
7015 Choices
=> New_List
(
7016 Make_Identifier
(Loc
, Name_Arg_Modes
)),
7018 Make_Integer_Literal
(Loc
, 0))))));
7020 if not Is_Known_Asynchronous
then
7021 Exception_Return_Parameter
:=
7022 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
7025 Make_Object_Declaration
(Loc
,
7026 Defining_Identifier
=> Exception_Return_Parameter
,
7027 Object_Definition
=>
7028 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
7031 Exception_Return_Parameter
:= Empty
;
7034 -- Initialize and fill in arguments list
7037 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
7038 Declare_Create_NVList
(Loc
, Arguments
, Decls
, Statements
);
7040 Current_Parameter
:= First
(Ordered_Parameters_List
);
7041 while Present
(Current_Parameter
) loop
7043 if Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
) then
7044 Is_Controlling_Formal
:= True;
7045 Is_First_Controlling_Formal
:=
7046 not First_Controlling_Formal_Seen
;
7047 First_Controlling_Formal_Seen
:= True;
7049 Is_Controlling_Formal
:= False;
7050 Is_First_Controlling_Formal
:= False;
7053 if Is_Controlling_Formal
then
7055 -- In the case of a controlling formal argument, we send
7061 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7064 -- The first controlling formal parameter is treated
7065 -- specially: it is used to set the target object of
7068 if not Is_First_Controlling_Formal
then
7071 Constrained
: constant Boolean :=
7072 Is_Constrained
(Etyp
)
7073 or else Is_Elementary_Type
(Etyp
);
7075 Any
: constant Entity_Id
:=
7076 Make_Defining_Identifier
(Loc
,
7077 New_Internal_Name
('A'));
7079 Actual_Parameter
: Node_Id
:=
7081 Defining_Identifier
(
7082 Current_Parameter
), Loc
);
7087 if Is_Controlling_Formal
then
7089 -- For a controlling formal parameter (other
7090 -- than the first one), use the corresponding
7091 -- RACW. If the parameter is not an anonymous
7092 -- access parameter, that involves taking
7093 -- its 'Unrestricted_Access.
7095 if Nkind
(Parameter_Type
(Current_Parameter
))
7096 = N_Access_Definition
7098 Actual_Parameter
:= OK_Convert_To
7099 (Etyp
, Actual_Parameter
);
7101 Actual_Parameter
:= OK_Convert_To
(Etyp
,
7102 Make_Attribute_Reference
(Loc
,
7106 Name_Unrestricted_Access
));
7111 if In_Present
(Current_Parameter
)
7112 or else not Out_Present
(Current_Parameter
)
7113 or else not Constrained
7114 or else Is_Controlling_Formal
7116 -- The parameter has an input value, is constrained
7117 -- at runtime by an input value, or is a controlling
7118 -- formal parameter (always passed as a reference)
7119 -- other than the first one.
7121 Expr
:= PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7122 Actual_Parameter
, Decls
);
7124 Expr
:= Make_Function_Call
(Loc
,
7126 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7127 Parameter_Associations
=> New_List
(
7128 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
7133 Make_Object_Declaration
(Loc
,
7134 Defining_Identifier
=>
7136 Aliased_Present
=> False,
7137 Object_Definition
=>
7138 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7142 Append_To
(Statements
,
7143 Add_Parameter_To_NVList
(Loc
,
7144 Parameter
=> Current_Parameter
,
7145 NVList
=> Arguments
,
7146 Constrained
=> Constrained
,
7149 if Out_Present
(Current_Parameter
)
7150 and then not Is_Controlling_Formal
7152 Append_To
(After_Statements
,
7153 Make_Assignment_Statement
(Loc
,
7156 Defining_Identifier
(Current_Parameter
), Loc
),
7158 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7159 Etype
(Parameter_Type
(Current_Parameter
)),
7160 New_Occurrence_Of
(Any
, Loc
),
7167 -- If the current parameter has a dynamic constrained status,
7168 -- then this status is transmitted as well.
7169 -- This should be done for accessibility as well ???
7171 if Nkind
(Parameter_Type
(Current_Parameter
))
7172 /= N_Access_Definition
7173 and then Need_Extra_Constrained
(Current_Parameter
)
7175 -- In this block, we do not use the extra formal that has been
7176 -- created because it does not exist at the time of expansion
7177 -- when building calling stubs for remote access to subprogram
7178 -- types. We create an extra variable of this type and push it
7179 -- in the stream after the regular parameters.
7182 Extra_Any_Parameter
: constant Entity_Id
:=
7183 Make_Defining_Identifier
7184 (Loc
, New_Internal_Name
('P'));
7188 Make_Object_Declaration
(Loc
,
7189 Defining_Identifier
=>
7190 Extra_Any_Parameter
,
7191 Aliased_Present
=> False,
7192 Object_Definition
=>
7193 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7195 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7196 Make_Attribute_Reference
(Loc
,
7199 Defining_Identifier
(Current_Parameter
), Loc
),
7200 Attribute_Name
=> Name_Constrained
),
7202 Append_To
(Extra_Formal_Statements
,
7203 Add_Parameter_To_NVList
(Loc
,
7204 Parameter
=> Extra_Any_Parameter
,
7205 NVList
=> Arguments
,
7206 Constrained
=> True,
7207 Any
=> Extra_Any_Parameter
));
7211 Next
(Current_Parameter
);
7214 -- Append the formal statements list to the statements
7216 Append_List_To
(Statements
, Extra_Formal_Statements
);
7218 Append_To
(Statements
,
7219 Make_Procedure_Call_Statement
(Loc
,
7221 New_Occurrence_Of
(RTE
(RE_Request_Create
), Loc
),
7222 Parameter_Associations
=> New_List
(
7225 New_Occurrence_Of
(Arguments
, Loc
),
7226 New_Occurrence_Of
(Result
, Loc
),
7227 New_Occurrence_Of
(RTE
(RE_Nil_Exc_List
), Loc
))));
7229 Append_To
(Parameter_Associations
(Last
(Statements
)),
7230 New_Occurrence_Of
(Request
, Loc
));
7233 not (Is_Known_Non_Asynchronous
and Is_Known_Asynchronous
));
7234 if Is_Known_Non_Asynchronous
or Is_Known_Asynchronous
then
7235 Asynchronous_P
:= New_Occurrence_Of
(
7236 Boolean_Literals
(Is_Known_Asynchronous
), Loc
);
7238 pragma Assert
(Present
(Asynchronous
));
7239 Asynchronous_P
:= New_Copy_Tree
(Asynchronous
);
7240 -- The expression node Asynchronous will be used to build
7241 -- an 'if' statement at the end of Build_General_Calling_Stubs:
7242 -- we need to make a copy here.
7245 Append_To
(Parameter_Associations
(Last
(Statements
)),
7246 Make_Indexed_Component
(Loc
,
7249 RTE
(RE_Asynchronous_P_To_Sync_Scope
), Loc
),
7250 Expressions
=> New_List
(Asynchronous_P
)));
7252 Append_To
(Statements
,
7253 Make_Procedure_Call_Statement
(Loc
,
7255 New_Occurrence_Of
(RTE
(RE_Request_Invoke
), Loc
),
7256 Parameter_Associations
=> New_List
(
7257 New_Occurrence_Of
(Request
, Loc
))));
7259 Non_Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7260 Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7262 if not Is_Known_Asynchronous
then
7264 -- Reraise an exception occurrence from the completed request.
7265 -- If the exception occurrence is empty, this is a no-op.
7267 Append_To
(Non_Asynchronous_Statements
,
7268 Make_Procedure_Call_Statement
(Loc
,
7270 New_Occurrence_Of
(RTE
(RE_Request_Raise_Occurrence
), Loc
),
7271 Parameter_Associations
=> New_List
(
7272 New_Occurrence_Of
(Request
, Loc
))));
7276 -- If this is a function call, then read the value and
7279 Append_To
(Non_Asynchronous_Statements
,
7280 Make_Tag_Check
(Loc
,
7281 Make_Return_Statement
(Loc
,
7282 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7283 Etype
(Subtype_Mark
(Spec
)),
7284 Make_Selected_Component
(Loc
,
7286 Selector_Name
=> Name_Argument
),
7291 Append_List_To
(Non_Asynchronous_Statements
,
7294 if Is_Known_Asynchronous
then
7295 Append_List_To
(Statements
, Asynchronous_Statements
);
7297 elsif Is_Known_Non_Asynchronous
then
7298 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
7301 pragma Assert
(Present
(Asynchronous
));
7302 Append_To
(Statements
,
7303 Make_Implicit_If_Statement
(Nod
,
7304 Condition
=> Asynchronous
,
7305 Then_Statements
=> Asynchronous_Statements
,
7306 Else_Statements
=> Non_Asynchronous_Statements
));
7308 end Build_General_Calling_Stubs
;
7310 -----------------------
7311 -- Build_Stub_Target --
7312 -----------------------
7314 function Build_Stub_Target
7317 RCI_Locator
: Entity_Id
;
7318 Controlling_Parameter
: Entity_Id
) return RPC_Target
7320 Target_Info
: RPC_Target
(PCS_Kind
=> Name_PolyORB_DSA
);
7321 Target_Reference
: constant Entity_Id
:=
7322 Make_Defining_Identifier
(Loc
,
7323 New_Internal_Name
('T'));
7325 if Present
(Controlling_Parameter
) then
7327 Make_Object_Declaration
(Loc
,
7328 Defining_Identifier
=> Target_Reference
,
7329 Object_Definition
=>
7330 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
7332 Make_Function_Call
(Loc
,
7334 New_Occurrence_Of
(RTE
(RE_Make_Ref
), Loc
),
7335 Parameter_Associations
=> New_List
(
7336 Make_Selected_Component
(Loc
,
7337 Prefix
=> Controlling_Parameter
,
7338 Selector_Name
=> Name_Target
)))));
7339 -- Controlling_Parameter has the same components
7340 -- as System.Partition_Interface.RACW_Stub_Type.
7342 Target_Info
.Object
:= New_Occurrence_Of
(Target_Reference
, Loc
);
7345 Target_Info
.Object
:=
7346 Make_Selected_Component
(Loc
,
7348 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
7350 Make_Identifier
(Loc
, Name_Get_RCI_Package_Ref
));
7353 end Build_Stub_Target
;
7355 ---------------------
7356 -- Build_Stub_Type --
7357 ---------------------
7359 procedure Build_Stub_Type
7360 (RACW_Type
: Entity_Id
;
7361 Stub_Type
: Entity_Id
;
7362 Stub_Type_Decl
: out Node_Id
;
7363 RPC_Receiver_Decl
: out Node_Id
)
7365 Loc
: constant Source_Ptr
:= Sloc
(Stub_Type
);
7366 pragma Warnings
(Off
);
7367 pragma Unreferenced
(RACW_Type
);
7368 pragma Warnings
(On
);
7372 Make_Full_Type_Declaration
(Loc
,
7373 Defining_Identifier
=> Stub_Type
,
7375 Make_Record_Definition
(Loc
,
7376 Tagged_Present
=> True,
7377 Limited_Present
=> True,
7379 Make_Component_List
(Loc
,
7380 Component_Items
=> New_List
(
7382 Make_Component_Declaration
(Loc
,
7383 Defining_Identifier
=>
7384 Make_Defining_Identifier
(Loc
, Name_Target
),
7385 Component_Definition
=>
7386 Make_Component_Definition
(Loc
,
7389 Subtype_Indication
=>
7390 New_Occurrence_Of
(RTE
(RE_Entity_Ptr
), Loc
))),
7392 Make_Component_Declaration
(Loc
,
7393 Defining_Identifier
=>
7394 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
7395 Component_Definition
=>
7396 Make_Component_Definition
(Loc
,
7397 Aliased_Present
=> False,
7398 Subtype_Indication
=>
7400 Standard_Boolean
, Loc
)))))));
7402 RPC_Receiver_Decl
:=
7403 Make_Object_Declaration
(Loc
,
7404 Defining_Identifier
=> Make_Defining_Identifier
(Loc
,
7405 New_Internal_Name
('R')),
7406 Aliased_Present
=> True,
7407 Object_Definition
=>
7408 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7409 end Build_Stub_Type
;
7411 -----------------------------
7412 -- Build_RPC_Receiver_Body --
7413 -----------------------------
7415 procedure Build_RPC_Receiver_Body
7416 (RPC_Receiver
: Entity_Id
;
7417 Request
: out Entity_Id
;
7418 Subp_Id
: out Entity_Id
;
7419 Subp_Index
: out Entity_Id
;
7420 Stmts
: out List_Id
;
7423 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
7425 RPC_Receiver_Spec
: Node_Id
;
7426 RPC_Receiver_Decls
: List_Id
;
7429 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
7431 RPC_Receiver_Spec
:=
7432 Build_RPC_Receiver_Specification
(
7433 RPC_Receiver
=> RPC_Receiver
,
7434 Request_Parameter
=> Request
);
7436 Subp_Id
:= Make_Defining_Identifier
(Loc
, Name_P
);
7437 Subp_Index
:= Make_Defining_Identifier
(Loc
, Name_I
);
7439 RPC_Receiver_Decls
:= New_List
(
7440 Make_Object_Renaming_Declaration
(Loc
,
7441 Defining_Identifier
=> Subp_Id
,
7442 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
7444 Make_Explicit_Dereference
(Loc
,
7446 Make_Selected_Component
(Loc
,
7448 Selector_Name
=> Name_Operation
))),
7450 Make_Object_Declaration
(Loc
,
7451 Defining_Identifier
=> Subp_Index
,
7452 Object_Definition
=>
7453 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7455 Make_Attribute_Reference
(Loc
,
7457 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7458 Attribute_Name
=> Name_Last
)));
7463 Make_Subprogram_Body
(Loc
,
7464 Specification
=> RPC_Receiver_Spec
,
7465 Declarations
=> RPC_Receiver_Decls
,
7466 Handled_Statement_Sequence
=>
7467 Make_Handled_Sequence_Of_Statements
(Loc
,
7468 Statements
=> Stmts
));
7469 end Build_RPC_Receiver_Body
;
7471 --------------------------------------
7472 -- Build_Subprogram_Receiving_Stubs --
7473 --------------------------------------
7475 function Build_Subprogram_Receiving_Stubs
7476 (Vis_Decl
: Node_Id
;
7477 Asynchronous
: Boolean;
7478 Dynamically_Asynchronous
: Boolean := False;
7479 Stub_Type
: Entity_Id
:= Empty
;
7480 RACW_Type
: Entity_Id
:= Empty
;
7481 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
7483 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
7485 Request_Parameter
: Node_Id
;
7488 Outer_Decls
: constant List_Id
:= New_List
;
7489 -- At the outermost level, an NVList and Any's are
7490 -- declared for all parameters. The Dynamic_Async
7491 -- flag also needs to be declared there to be visible
7492 -- from the exception handling code.
7494 Outer_Statements
: constant List_Id
:= New_List
;
7495 -- Statements that occur prior to the declaration of the actual
7496 -- parameter variables.
7498 Decls
: constant List_Id
:= New_List
;
7499 -- All the parameters will get declared before calling the real
7500 -- subprograms. Also the out parameters will be declared.
7501 -- At this level, parameters may be unconstrained.
7503 Statements
: constant List_Id
:= New_List
;
7505 Extra_Formal_Statements
: constant List_Id
:= New_List
;
7506 -- Statements concerning extra formal parameters
7508 After_Statements
: constant List_Id
:= New_List
;
7509 -- Statements to be executed after the subprogram call
7511 Inner_Decls
: List_Id
:= No_List
;
7512 -- In case of a function, the inner declarations are needed since
7513 -- the result may be unconstrained.
7515 Excep_Handlers
: List_Id
:= No_List
;
7517 Parameter_List
: constant List_Id
:= New_List
;
7518 -- List of parameters to be passed to the subprogram
7520 First_Controlling_Formal_Seen
: Boolean := False;
7522 Current_Parameter
: Node_Id
;
7524 Ordered_Parameters_List
: constant List_Id
:=
7525 Build_Ordered_Parameters_List
7526 (Specification
(Vis_Decl
));
7528 Arguments
: Node_Id
;
7529 -- Name of the named values list used to retrieve parameters
7531 Subp_Spec
: Node_Id
;
7532 -- Subprogram specification
7534 Called_Subprogram
: Node_Id
;
7535 -- The subprogram to call
7538 if Present
(RACW_Type
) then
7539 Called_Subprogram
:=
7540 New_Occurrence_Of
(Parent_Primitive
, Loc
);
7542 Called_Subprogram
:=
7544 Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
7547 Request_Parameter
:=
7548 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
7551 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
7552 Declare_Create_NVList
(Loc
, Arguments
, Outer_Decls
, Outer_Statements
);
7554 -- Loop through every parameter and get its value from the stream. If
7555 -- the parameter is unconstrained, then the parameter is read using
7556 -- 'Input at the point of declaration.
7558 Current_Parameter
:= First
(Ordered_Parameters_List
);
7559 while Present
(Current_Parameter
) loop
7562 Constrained
: Boolean;
7563 Any
: Entity_Id
:= Empty
;
7564 Object
: constant Entity_Id
:=
7565 Make_Defining_Identifier
(Loc
,
7566 New_Internal_Name
('P'));
7567 Expr
: Node_Id
:= Empty
;
7569 Is_Controlling_Formal
: constant Boolean
7570 := Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
);
7572 Is_First_Controlling_Formal
: Boolean := False;
7574 Set_Ekind
(Object
, E_Variable
);
7576 if Is_Controlling_Formal
then
7578 -- Controlling formals in distributed object primitive
7579 -- operations are handled specially:
7580 -- - the first controlling formal is used as the
7581 -- target of the call;
7582 -- - the remaining controlling formals are transmitted
7586 Is_First_Controlling_Formal
:=
7587 not First_Controlling_Formal_Seen
;
7588 First_Controlling_Formal_Seen
:= True;
7590 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7594 Is_Constrained
(Etyp
)
7595 or else Is_Elementary_Type
(Etyp
);
7597 if not Is_First_Controlling_Formal
then
7598 Any
:= Make_Defining_Identifier
(Loc
,
7599 New_Internal_Name
('A'));
7600 Append_To
(Outer_Decls
,
7601 Make_Object_Declaration
(Loc
,
7602 Defining_Identifier
=>
7604 Object_Definition
=>
7605 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7607 Make_Function_Call
(Loc
,
7609 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7610 Parameter_Associations
=> New_List
(
7611 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
7612 Etyp
, Outer_Decls
)))));
7614 Append_To
(Outer_Statements
,
7615 Add_Parameter_To_NVList
(Loc
,
7616 Parameter
=> Current_Parameter
,
7617 NVList
=> Arguments
,
7618 Constrained
=> Constrained
,
7622 if Is_First_Controlling_Formal
then
7624 Addr
: constant Entity_Id
:=
7625 Make_Defining_Identifier
(Loc
,
7626 New_Internal_Name
('A'));
7627 Is_Local
: constant Entity_Id
:=
7628 Make_Defining_Identifier
(Loc
,
7629 New_Internal_Name
('L'));
7632 -- Special case: obtain the first controlling
7633 -- formal from the target of the remote call,
7634 -- instead of the argument list.
7636 Append_To
(Outer_Decls
,
7637 Make_Object_Declaration
(Loc
,
7638 Defining_Identifier
=>
7640 Object_Definition
=>
7641 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
7642 Append_To
(Outer_Decls
,
7643 Make_Object_Declaration
(Loc
,
7644 Defining_Identifier
=>
7646 Object_Definition
=>
7647 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7648 Append_To
(Outer_Statements
,
7649 Make_Procedure_Call_Statement
(Loc
,
7652 RTE
(RE_Get_Local_Address
), Loc
),
7653 Parameter_Associations
=> New_List
(
7654 Make_Selected_Component
(Loc
,
7657 Request_Parameter
, Loc
),
7659 Make_Identifier
(Loc
, Name_Target
)),
7660 New_Occurrence_Of
(Is_Local
, Loc
),
7661 New_Occurrence_Of
(Addr
, Loc
))));
7663 Expr
:= Unchecked_Convert_To
(RACW_Type
,
7664 New_Occurrence_Of
(Addr
, Loc
));
7667 elsif In_Present
(Current_Parameter
)
7668 or else not Out_Present
(Current_Parameter
)
7669 or else not Constrained
7671 -- If an input parameter is contrained, then its reading is
7672 -- deferred until the beginning of the subprogram body. If
7673 -- it is unconstrained, then an expression is built for
7674 -- the object declaration and the variable is set using
7675 -- 'Input instead of 'Read.
7677 Expr
:= PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7678 Etyp
, New_Occurrence_Of
(Any
, Loc
), Decls
);
7682 Append_To
(Statements
,
7683 Make_Assignment_Statement
(Loc
,
7685 New_Occurrence_Of
(Object
, Loc
),
7691 -- Expr will be used to initialize (and constrain)
7692 -- the parameter when it is declared.
7697 -- If we do not have to output the current parameter, then
7698 -- it can well be flagged as constant. This may allow further
7699 -- optimizations done by the back end.
7702 Make_Object_Declaration
(Loc
,
7703 Defining_Identifier
=> Object
,
7704 Constant_Present
=> not Constrained
7705 and then not Out_Present
(Current_Parameter
),
7706 Object_Definition
=>
7707 New_Occurrence_Of
(Etyp
, Loc
),
7708 Expression
=> Expr
));
7709 Set_Etype
(Object
, Etyp
);
7711 -- An out parameter may be written back using a 'Write
7712 -- attribute instead of a 'Output because it has been
7713 -- constrained by the parameter given to the caller. Note that
7714 -- out controlling arguments in the case of a RACW are not put
7715 -- back in the stream because the pointer on them has not
7718 if Out_Present
(Current_Parameter
)
7719 and then not Is_Controlling_Formal
7721 Append_To
(After_Statements
,
7722 Make_Procedure_Call_Statement
(Loc
,
7724 New_Occurrence_Of
(RTE
(RE_Copy_Any_Value
), Loc
),
7725 Parameter_Associations
=> New_List
(
7726 New_Occurrence_Of
(Any
, Loc
),
7727 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7728 New_Occurrence_Of
(Object
, Loc
),
7732 -- For RACW controlling formals, the Etyp of Object is always
7733 -- an RACW, even if the parameter is not of an anonymous access
7734 -- type. In such case, we need to dereference it at call time.
7736 if Is_Controlling_Formal
then
7737 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7740 Append_To
(Parameter_List
,
7741 Make_Parameter_Association
(Loc
,
7744 Defining_Identifier
(Current_Parameter
), Loc
),
7745 Explicit_Actual_Parameter
=>
7746 Make_Explicit_Dereference
(Loc
,
7747 Unchecked_Convert_To
(RACW_Type
,
7748 OK_Convert_To
(RTE
(RE_Address
),
7749 New_Occurrence_Of
(Object
, Loc
))))));
7752 Append_To
(Parameter_List
,
7753 Make_Parameter_Association
(Loc
,
7756 Defining_Identifier
(Current_Parameter
), Loc
),
7757 Explicit_Actual_Parameter
=>
7758 Unchecked_Convert_To
(RACW_Type
,
7759 OK_Convert_To
(RTE
(RE_Address
),
7760 New_Occurrence_Of
(Object
, Loc
)))));
7764 Append_To
(Parameter_List
,
7765 Make_Parameter_Association
(Loc
,
7768 Defining_Identifier
(Current_Parameter
), Loc
),
7769 Explicit_Actual_Parameter
=>
7770 New_Occurrence_Of
(Object
, Loc
)));
7773 -- If the current parameter needs an extra formal, then read it
7774 -- from the stream and set the corresponding semantic field in
7775 -- the variable. If the kind of the parameter identifier is
7776 -- E_Void, then this is a compiler generated parameter that
7777 -- doesn't need an extra constrained status.
7779 -- The case of Extra_Accessibility should also be handled ???
7781 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7784 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
7786 Present
(Extra_Constrained
7787 (Defining_Identifier
(Current_Parameter
)))
7790 Extra_Parameter
: constant Entity_Id
:=
7792 (Defining_Identifier
7793 (Current_Parameter
));
7794 Extra_Any
: constant Entity_Id
:=
7795 Make_Defining_Identifier
7796 (Loc
, New_Internal_Name
('A'));
7797 Formal_Entity
: constant Entity_Id
:=
7798 Make_Defining_Identifier
7799 (Loc
, Chars
(Extra_Parameter
));
7801 Formal_Type
: constant Entity_Id
:=
7802 Etype
(Extra_Parameter
);
7804 Append_To
(Outer_Decls
,
7805 Make_Object_Declaration
(Loc
,
7806 Defining_Identifier
=>
7808 Object_Definition
=>
7809 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
7811 Append_To
(Outer_Statements
,
7812 Add_Parameter_To_NVList
(Loc
,
7813 Parameter
=> Extra_Parameter
,
7814 NVList
=> Arguments
,
7815 Constrained
=> True,
7819 Make_Object_Declaration
(Loc
,
7820 Defining_Identifier
=> Formal_Entity
,
7821 Object_Definition
=>
7822 New_Occurrence_Of
(Formal_Type
, Loc
)));
7824 Append_To
(Extra_Formal_Statements
,
7825 Make_Assignment_Statement
(Loc
,
7827 New_Occurrence_Of
(Extra_Parameter
, Loc
),
7829 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
7830 Etype
(Extra_Parameter
),
7831 New_Occurrence_Of
(Extra_Any
, Loc
),
7833 Set_Extra_Constrained
(Object
, Formal_Entity
);
7839 Next
(Current_Parameter
);
7842 Append_To
(Outer_Statements
,
7843 Make_Procedure_Call_Statement
(Loc
,
7845 New_Occurrence_Of
(RTE
(RE_Request_Arguments
), Loc
),
7846 Parameter_Associations
=> New_List
(
7847 New_Occurrence_Of
(Request_Parameter
, Loc
),
7848 New_Occurrence_Of
(Arguments
, Loc
))));
7850 Append_List_To
(Statements
, Extra_Formal_Statements
);
7852 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
7854 -- The remote subprogram is a function. We build an inner block to
7855 -- be able to hold a potentially unconstrained result in a
7859 Etyp
: constant Entity_Id
:=
7860 Etype
(Subtype_Mark
(Specification
(Vis_Decl
)));
7861 Result
: constant Node_Id
:=
7862 Make_Defining_Identifier
(Loc
,
7863 New_Internal_Name
('R'));
7865 Inner_Decls
:= New_List
(
7866 Make_Object_Declaration
(Loc
,
7867 Defining_Identifier
=> Result
,
7868 Constant_Present
=> True,
7869 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
7871 Make_Function_Call
(Loc
,
7872 Name
=> Called_Subprogram
,
7873 Parameter_Associations
=> Parameter_List
)));
7875 Set_Etype
(Result
, Etyp
);
7876 Append_To
(After_Statements
,
7877 Make_Procedure_Call_Statement
(Loc
,
7879 New_Occurrence_Of
(RTE
(RE_Set_Result
), Loc
),
7880 Parameter_Associations
=> New_List
(
7881 New_Occurrence_Of
(Request_Parameter
, Loc
),
7882 PolyORB_Support
.Helpers
.Build_To_Any_Call
(
7883 New_Occurrence_Of
(Result
, Loc
),
7885 -- A DSA function does not have out or inout arguments
7888 Append_To
(Statements
,
7889 Make_Block_Statement
(Loc
,
7890 Declarations
=> Inner_Decls
,
7891 Handled_Statement_Sequence
=>
7892 Make_Handled_Sequence_Of_Statements
(Loc
,
7893 Statements
=> After_Statements
)));
7896 -- The remote subprogram is a procedure. We do not need any inner
7897 -- block in this case. No specific processing is required here for
7898 -- the dynamically asynchronous case: the indication of whether
7899 -- call is asynchronous or not is managed by the Sync_Scope
7900 -- attibute of the request, and is handled entirely in the
7903 Append_To
(After_Statements
,
7904 Make_Procedure_Call_Statement
(Loc
,
7906 New_Occurrence_Of
(RTE
(RE_Request_Set_Out
), Loc
),
7907 Parameter_Associations
=> New_List
(
7908 New_Occurrence_Of
(Request_Parameter
, Loc
))));
7910 Append_To
(Statements
,
7911 Make_Procedure_Call_Statement
(Loc
,
7912 Name
=> Called_Subprogram
,
7913 Parameter_Associations
=> Parameter_List
));
7915 Append_List_To
(Statements
, After_Statements
);
7919 Make_Procedure_Specification
(Loc
,
7920 Defining_Unit_Name
=>
7921 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
7923 Parameter_Specifications
=> New_List
(
7924 Make_Parameter_Specification
(Loc
,
7925 Defining_Identifier
=> Request_Parameter
,
7927 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
7929 -- An exception raised during the execution of an incoming
7930 -- remote subprogram call and that needs to be sent back
7931 -- to the caller is propagated by the receiving stubs, and
7932 -- will be handled by the caller (the distribution runtime).
7934 if Asynchronous
and then not Dynamically_Asynchronous
then
7936 -- For an asynchronous procedure, add a null exception handler
7938 Excep_Handlers
:= New_List
(
7939 Make_Exception_Handler
(Loc
,
7940 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7941 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
7945 -- In the other cases, if an exception is raised, then the
7946 -- exception occurrence is propagated.
7951 Append_To
(Outer_Statements
,
7952 Make_Block_Statement
(Loc
,
7955 Handled_Statement_Sequence
=>
7956 Make_Handled_Sequence_Of_Statements
(Loc
,
7957 Statements
=> Statements
)));
7960 Make_Subprogram_Body
(Loc
,
7961 Specification
=> Subp_Spec
,
7962 Declarations
=> Outer_Decls
,
7963 Handled_Statement_Sequence
=>
7964 Make_Handled_Sequence_Of_Statements
(Loc
,
7965 Statements
=> Outer_Statements
,
7966 Exception_Handlers
=> Excep_Handlers
));
7967 end Build_Subprogram_Receiving_Stubs
;
7972 package body Helpers
is
7974 -----------------------
7975 -- Local Subprograms --
7976 -----------------------
7978 function Find_Inherited_TSS
7980 Nam
: Name_Id
) return Entity_Id
;
7981 -- A TSS reference for a representation aspect of a derived tagged
7982 -- type must take into account inheritance of that aspect from
7983 -- ancestor types. (copied from exp_attr.adb, should be shared???)
7985 function Find_Numeric_Representation
7986 (Typ
: Entity_Id
) return Entity_Id
;
7987 -- Given a numeric type Typ, return the smallest integer or floarting
7988 -- point type from Standard, or the smallest unsigned (modular) type
7989 -- from System.Unsigned_Types, whose range encompasses that of Typ.
7991 function Make_Stream_Procedure_Function_Name
7994 Nam
: Name_Id
) return Entity_Id
;
7995 -- Return the name to be assigned for stream subprogram Nam of Typ.
7996 -- (copied from exp_strm.adb, should be shared???)
7998 ------------------------------------------------------------
7999 -- Common subprograms for building various tree fragments --
8000 ------------------------------------------------------------
8002 function Build_Get_Aggregate_Element
8006 Idx
: Node_Id
) return Node_Id
;
8007 -- Build a call to Get_Aggregate_Element on Any
8008 -- for typecode TC, returning the Idx'th element.
8011 Subprogram
: Entity_Id
;
8012 -- Reference location for constructed nodes
8015 -- For 'Range and Etype
8018 -- For the construction of the innermost element expression
8020 with procedure Add_Process_Element
8023 Counter
: Entity_Id
;
8026 procedure Append_Array_Traversal
8029 Counter
: Entity_Id
:= Empty
;
8031 -- Build nested loop statements that iterate over the elements of an
8032 -- array Arry. The statement(s) built by Add_Process_Element are
8033 -- executed for each element; Indices is the list of indices to be
8034 -- used in the construction of the indexed component that denotes the
8035 -- current element. Subprogram is the entity for the subprogram for
8036 -- which this iterator is generated. The generated statements are
8037 -- appended to Stmts.
8041 -- The record entity being dealt with
8043 with procedure Add_Process_Element
8045 Container
: Node_Or_Entity_Id
;
8046 Counter
: in out Int
;
8049 -- Rec is the instance of the record type, or Empty.
8050 -- Field is either the N_Defining_Identifier for a component,
8051 -- or an N_Variant_Part.
8053 procedure Append_Record_Traversal
8056 Container
: Node_Or_Entity_Id
;
8057 Counter
: in out Int
);
8058 -- Process component list Clist. Individual fields are passed
8059 -- to Field_Processing. Each variant part is also processed.
8060 -- Container is the outer Any (for From_Any/To_Any),
8061 -- the outer typecode (for TC) to which the operation applies.
8063 -----------------------------
8064 -- Append_Record_Traversal --
8065 -----------------------------
8067 procedure Append_Record_Traversal
8070 Container
: Node_Or_Entity_Id
;
8071 Counter
: in out Int
)
8073 CI
: constant List_Id
:= Component_Items
(Clist
);
8074 VP
: constant Node_Id
:= Variant_Part
(Clist
);
8076 Item
: Node_Id
:= First
(CI
);
8080 while Present
(Item
) loop
8081 Def
:= Defining_Identifier
(Item
);
8082 if not Is_Internal_Name
(Chars
(Def
)) then
8084 (Stmts
, Container
, Counter
, Rec
, Def
);
8089 if Present
(VP
) then
8090 Add_Process_Element
(Stmts
, Container
, Counter
, Rec
, VP
);
8092 end Append_Record_Traversal
;
8094 -------------------------
8095 -- Build_From_Any_Call --
8096 -------------------------
8098 function Build_From_Any_Call
8101 Decls
: List_Id
) return Node_Id
8103 Loc
: constant Source_Ptr
:= Sloc
(N
);
8105 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
8107 Fnam
: Entity_Id
:= Empty
;
8108 Lib_RE
: RE_Id
:= RE_Null
;
8112 -- First simple case where the From_Any function is present
8113 -- in the type's TSS.
8115 Fnam
:= Find_Inherited_TSS
(U_Type
, Name_uFrom_Any
);
8117 if Sloc
(U_Type
) <= Standard_Location
then
8118 U_Type
:= Base_Type
(U_Type
);
8121 -- Check first for Boolean and Character. These are enumeration
8122 -- types, but we treat them specially, since they may require
8123 -- special handling in the transfer protocol. However, this
8124 -- special handling only applies if they have standard
8125 -- representation, otherwise they are treated like any other
8126 -- enumeration type.
8128 if Present
(Fnam
) then
8131 elsif U_Type
= Standard_Boolean
then
8134 elsif U_Type
= Standard_Character
then
8137 elsif U_Type
= Standard_Wide_Character
then
8140 -- Floating point types
8142 elsif U_Type
= Standard_Short_Float
then
8145 elsif U_Type
= Standard_Float
then
8148 elsif U_Type
= Standard_Long_Float
then
8151 elsif U_Type
= Standard_Long_Long_Float
then
8152 Lib_RE
:= RE_FA_LLF
;
8156 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
8157 Lib_RE
:= RE_FA_SSI
;
8159 elsif U_Type
= Etype
(Standard_Short_Integer
) then
8162 elsif U_Type
= Etype
(Standard_Integer
) then
8165 elsif U_Type
= Etype
(Standard_Long_Integer
) then
8168 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
8169 Lib_RE
:= RE_FA_LLI
;
8171 -- Unsigned integer types
8173 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
8174 Lib_RE
:= RE_FA_SSU
;
8176 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
8179 elsif U_Type
= RTE
(RE_Unsigned
) then
8182 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
8185 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
8186 Lib_RE
:= RE_FA_LLU
;
8188 elsif U_Type
= Standard_String
then
8189 Lib_RE
:= RE_FA_String
;
8191 -- Other (non-primitive) types
8197 Build_From_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
8198 Append_To
(Decls
, Decl
);
8202 -- Call the function
8204 if Lib_RE
/= RE_Null
then
8205 pragma Assert
(No
(Fnam
));
8206 Fnam
:= RTE
(Lib_RE
);
8210 Make_Function_Call
(Loc
,
8211 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
8212 Parameter_Associations
=> New_List
(N
));
8213 end Build_From_Any_Call
;
8215 -----------------------------
8216 -- Build_From_Any_Function --
8217 -----------------------------
8219 procedure Build_From_Any_Function
8223 Fnam
: out Entity_Id
)
8226 Decls
: constant List_Id
:= New_List
;
8227 Stms
: constant List_Id
:= New_List
;
8228 Any_Parameter
: constant Entity_Id
8229 := Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
8231 Fnam
:= Make_Stream_Procedure_Function_Name
(Loc
,
8232 Typ
, Name_uFrom_Any
);
8235 Make_Function_Specification
(Loc
,
8236 Defining_Unit_Name
=> Fnam
,
8237 Parameter_Specifications
=> New_List
(
8238 Make_Parameter_Specification
(Loc
,
8239 Defining_Identifier
=>
8242 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
8243 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
));
8245 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8248 (not (Is_Remote_Access_To_Class_Wide_Type
(Typ
)));
8251 if Is_Derived_Type
(Typ
)
8252 and then not Is_Tagged_Type
(Typ
)
8255 Make_Return_Statement
(Loc
,
8259 Build_From_Any_Call
(
8261 New_Occurrence_Of
(Any_Parameter
, Loc
),
8264 elsif Is_Record_Type
(Typ
)
8265 and then not Is_Derived_Type
(Typ
)
8266 and then not Is_Tagged_Type
(Typ
)
8268 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
8270 Make_Return_Statement
(Loc
,
8274 Build_From_Any_Call
(
8276 New_Occurrence_Of
(Any_Parameter
, Loc
),
8280 Disc
: Entity_Id
:= Empty
;
8281 Discriminant_Associations
: List_Id
;
8282 Rdef
: constant Node_Id
:=
8283 Type_Definition
(Declaration_Node
(Typ
));
8284 Component_Counter
: Int
:= 0;
8286 -- The returned object
8288 Res
: constant Entity_Id
:=
8289 Make_Defining_Identifier
(Loc
,
8290 New_Internal_Name
('R'));
8292 Res_Definition
: Node_Id
:= New_Occurrence_Of
(Typ
, Loc
);
8294 procedure FA_Rec_Add_Process_Element
8297 Counter
: in out Int
;
8301 procedure FA_Append_Record_Traversal
is
8302 new Append_Record_Traversal
8304 Add_Process_Element
=> FA_Rec_Add_Process_Element
);
8306 --------------------------------
8307 -- FA_Rec_Add_Process_Element --
8308 --------------------------------
8310 procedure FA_Rec_Add_Process_Element
8313 Counter
: in out Int
;
8318 if Nkind
(Field
) = N_Defining_Identifier
then
8320 -- A regular component
8323 Make_Assignment_Statement
(Loc
,
8324 Name
=> Make_Selected_Component
(Loc
,
8326 New_Occurrence_Of
(Rec
, Loc
),
8328 New_Occurrence_Of
(Field
, Loc
)),
8330 Build_From_Any_Call
(Etype
(Field
),
8331 Build_Get_Aggregate_Element
(Loc
,
8333 Tc
=> Build_TypeCode_Call
(Loc
,
8334 Etype
(Field
), Decls
),
8335 Idx
=> Make_Integer_Literal
(Loc
,
8344 Struct_Counter
: Int
:= 0;
8346 Block_Decls
: constant List_Id
:= New_List
;
8347 Block_Stmts
: constant List_Id
:= New_List
;
8350 Alt_List
: constant List_Id
:= New_List
;
8351 Choice_List
: List_Id
;
8353 Struct_Any
: constant Entity_Id
:=
8354 Make_Defining_Identifier
(Loc
,
8355 New_Internal_Name
('S'));
8359 Make_Object_Declaration
(Loc
,
8360 Defining_Identifier
=>
8364 Object_Definition
=>
8365 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8367 Make_Function_Call
(Loc
,
8368 Name
=> New_Occurrence_Of
(
8369 RTE
(RE_Extract_Union_Value
), Loc
),
8370 Parameter_Associations
=> New_List
(
8371 Build_Get_Aggregate_Element
(Loc
,
8373 Tc
=> Make_Function_Call
(Loc
,
8374 Name
=> New_Occurrence_Of
(
8375 RTE
(RE_Any_Member_Type
), Loc
),
8376 Parameter_Associations
=>
8378 New_Occurrence_Of
(Any
, Loc
),
8379 Make_Integer_Literal
(Loc
,
8381 Idx
=> Make_Integer_Literal
(Loc
,
8385 Make_Block_Statement
(Loc
,
8388 Handled_Statement_Sequence
=>
8389 Make_Handled_Sequence_Of_Statements
(Loc
,
8390 Statements
=> Block_Stmts
)));
8392 Append_To
(Block_Stmts
,
8393 Make_Case_Statement
(Loc
,
8395 Make_Selected_Component
(Loc
,
8398 Chars
(Name
(Field
))),
8402 Variant
:= First_Non_Pragma
(Variants
(Field
));
8404 while Present
(Variant
) loop
8405 Choice_List
:= New_Copy_List_Tree
8406 (Discrete_Choices
(Variant
));
8408 VP_Stmts
:= New_List
;
8409 FA_Append_Record_Traversal
(
8411 Clist
=> Component_List
(Variant
),
8412 Container
=> Struct_Any
,
8413 Counter
=> Struct_Counter
);
8415 Append_To
(Alt_List
,
8416 Make_Case_Statement_Alternative
(Loc
,
8417 Discrete_Choices
=> Choice_List
,
8420 Next_Non_Pragma
(Variant
);
8424 Counter
:= Counter
+ 1;
8425 end FA_Rec_Add_Process_Element
;
8428 -- First all discriminants
8430 if Has_Discriminants
(Typ
) then
8431 Disc
:= First_Discriminant
(Typ
);
8432 Discriminant_Associations
:= New_List
;
8434 while Present
(Disc
) loop
8436 Disc_Var_Name
: constant Entity_Id
:=
8437 Make_Defining_Identifier
(Loc
, Chars
(Disc
));
8438 Disc_Type
: constant Entity_Id
:=
8442 Make_Object_Declaration
(Loc
,
8443 Defining_Identifier
=>
8445 Constant_Present
=> True,
8446 Object_Definition
=>
8447 New_Occurrence_Of
(Disc_Type
, Loc
),
8449 Build_From_Any_Call
(Etype
(Disc
),
8450 Build_Get_Aggregate_Element
(Loc
,
8451 Any
=> Any_Parameter
,
8452 Tc
=> Build_TypeCode_Call
8453 (Loc
, Etype
(Disc
), Decls
),
8454 Idx
=> Make_Integer_Literal
8455 (Loc
, Component_Counter
)),
8457 Component_Counter
:= Component_Counter
+ 1;
8459 Append_To
(Discriminant_Associations
,
8460 Make_Discriminant_Association
(Loc
,
8461 Selector_Names
=> New_List
(
8462 New_Occurrence_Of
(Disc
, Loc
)),
8464 New_Occurrence_Of
(Disc_Var_Name
, Loc
)));
8466 Next_Discriminant
(Disc
);
8469 Res_Definition
:= Make_Subtype_Indication
(Loc
,
8470 Subtype_Mark
=> Res_Definition
,
8472 Make_Index_Or_Discriminant_Constraint
(Loc
,
8473 Discriminant_Associations
));
8476 -- Now we have all the discriminants in variables, we can
8477 -- declared a constrained object. Note that we are not
8478 -- initializing (non-discriminant) components directly in
8479 -- the object declarations, because which fields to
8480 -- initialize depends (at run time) on the discriminant
8484 Make_Object_Declaration
(Loc
,
8485 Defining_Identifier
=>
8487 Object_Definition
=>
8490 -- ... then all components
8492 FA_Append_Record_Traversal
(Stms
,
8493 Clist
=> Component_List
(Rdef
),
8494 Container
=> Any_Parameter
,
8495 Counter
=> Component_Counter
);
8498 Make_Return_Statement
(Loc
,
8499 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
8503 elsif Is_Array_Type
(Typ
) then
8505 Constrained
: constant Boolean := Is_Constrained
(Typ
);
8507 procedure FA_Ary_Add_Process_Element
8510 Counter
: Entity_Id
;
8512 -- Assign the current element (as identified by Counter) of
8513 -- Any to the variable denoted by name Datum, and advance
8514 -- Counter by 1. If Datum is not an Any, a call to From_Any
8515 -- for its type is inserted.
8517 --------------------------------
8518 -- FA_Ary_Add_Process_Element --
8519 --------------------------------
8521 procedure FA_Ary_Add_Process_Element
8524 Counter
: Entity_Id
;
8527 Assignment
: constant Node_Id
:=
8528 Make_Assignment_Statement
(Loc
,
8530 Expression
=> Empty
);
8532 Element_Any
: constant Node_Id
:=
8533 Build_Get_Aggregate_Element
(Loc
,
8535 Tc
=> Build_TypeCode_Call
(Loc
,
8536 Etype
(Datum
), Decls
),
8537 Idx
=> New_Occurrence_Of
(Counter
, Loc
));
8540 -- Note: here we *prepend* statements to Stmts, so
8541 -- we must do it in reverse order.
8544 Make_Assignment_Statement
(Loc
,
8546 New_Occurrence_Of
(Counter
, Loc
),
8550 New_Occurrence_Of
(Counter
, Loc
),
8552 Make_Integer_Literal
(Loc
, 1))));
8554 if Nkind
(Datum
) /= N_Attribute_Reference
then
8556 -- We ignore the value of the length of each
8557 -- dimension, since the target array has already
8558 -- been constrained anyway.
8560 if Etype
(Datum
) /= RTE
(RE_Any
) then
8561 Set_Expression
(Assignment
,
8562 Build_From_Any_Call
(
8563 Component_Type
(Typ
),
8567 Set_Expression
(Assignment
, Element_Any
);
8569 Prepend_To
(Stmts
, Assignment
);
8571 end FA_Ary_Add_Process_Element
;
8573 Counter
: constant Entity_Id
:=
8574 Make_Defining_Identifier
(Loc
, Name_J
);
8576 Initial_Counter_Value
: Int
:= 0;
8578 Component_TC
: constant Entity_Id
:=
8579 Make_Defining_Identifier
(Loc
, Name_T
);
8581 Res
: constant Entity_Id
:=
8582 Make_Defining_Identifier
(Loc
, Name_R
);
8584 procedure Append_From_Any_Array_Iterator
is
8585 new Append_Array_Traversal
(
8588 Indices
=> New_List
,
8589 Add_Process_Element
=> FA_Ary_Add_Process_Element
);
8591 Res_Subtype_Indication
: Node_Id
:=
8592 New_Occurrence_Of
(Typ
, Loc
);
8595 if not Constrained
then
8597 Ndim
: constant Int
:= Number_Dimensions
(Typ
);
8600 Indx
: Node_Id
:= First_Index
(Typ
);
8603 Ranges
: constant List_Id
:= New_List
;
8606 for J
in 1 .. Ndim
loop
8607 Lnam
:= New_External_Name
('L', J
);
8608 Hnam
:= New_External_Name
('H', J
);
8609 Indt
:= Etype
(Indx
);
8612 Make_Object_Declaration
(Loc
,
8613 Defining_Identifier
=>
8614 Make_Defining_Identifier
(Loc
, Lnam
),
8617 Object_Definition
=>
8618 New_Occurrence_Of
(Indt
, Loc
),
8620 Build_From_Any_Call
(
8622 Build_Get_Aggregate_Element
(Loc
,
8623 Any
=> Any_Parameter
,
8624 Tc
=> Build_TypeCode_Call
(Loc
,
8626 Idx
=> Make_Integer_Literal
(Loc
, J
- 1)),
8630 Make_Object_Declaration
(Loc
,
8631 Defining_Identifier
=>
8632 Make_Defining_Identifier
(Loc
, Hnam
),
8635 Object_Definition
=>
8636 New_Occurrence_Of
(Indt
, Loc
),
8637 Expression
=> Make_Attribute_Reference
(Loc
,
8639 New_Occurrence_Of
(Indt
, Loc
),
8640 Attribute_Name
=> Name_Val
,
8641 Expressions
=> New_List
(
8642 Make_Op_Subtract
(Loc
,
8646 Make_Attribute_Reference
(Loc
,
8648 New_Occurrence_Of
(Indt
, Loc
),
8651 Expressions
=> New_List
(
8652 Make_Identifier
(Loc
, Lnam
))),
8654 Make_Function_Call
(Loc
,
8655 Name
=> New_Occurrence_Of
(RTE
(
8656 RE_Get_Nested_Sequence_Length
),
8658 Parameter_Associations
=>
8661 Any_Parameter
, Loc
),
8662 Make_Integer_Literal
(Loc
,
8665 Make_Integer_Literal
(Loc
, 1))))));
8669 Low_Bound
=> Make_Identifier
(Loc
, Lnam
),
8670 High_Bound
=> Make_Identifier
(Loc
, Hnam
)));
8675 -- Now we have all the necessary bound information:
8676 -- apply the set of range constraints to the
8677 -- (unconstrained) nominal subtype of Res.
8679 Initial_Counter_Value
:= Ndim
;
8680 Res_Subtype_Indication
:= Make_Subtype_Indication
(Loc
,
8682 Res_Subtype_Indication
,
8684 Make_Index_Or_Discriminant_Constraint
(Loc
,
8685 Constraints
=> Ranges
));
8690 Make_Object_Declaration
(Loc
,
8691 Defining_Identifier
=> Res
,
8692 Object_Definition
=> Res_Subtype_Indication
));
8693 Set_Etype
(Res
, Typ
);
8696 Make_Object_Declaration
(Loc
,
8697 Defining_Identifier
=> Counter
,
8698 Object_Definition
=>
8699 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
8701 Make_Integer_Literal
(Loc
, Initial_Counter_Value
)));
8704 Make_Object_Declaration
(Loc
,
8705 Defining_Identifier
=> Component_TC
,
8706 Constant_Present
=> True,
8707 Object_Definition
=>
8708 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
),
8710 Build_TypeCode_Call
(Loc
,
8711 Component_Type
(Typ
), Decls
)));
8713 Append_From_Any_Array_Iterator
(Stms
,
8714 Any_Parameter
, Counter
);
8717 Make_Return_Statement
(Loc
,
8718 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
8721 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
8723 Make_Return_Statement
(Loc
,
8725 Unchecked_Convert_To
(
8727 Build_From_Any_Call
(
8728 Find_Numeric_Representation
(Typ
),
8729 New_Occurrence_Of
(Any_Parameter
, Loc
),
8733 -- Default: type is represented as an opaque sequence of bytes
8736 Strm
: constant Entity_Id
:=
8737 Make_Defining_Identifier
(Loc
,
8738 Chars
=> New_Internal_Name
('S'));
8739 Res
: constant Entity_Id
:=
8740 Make_Defining_Identifier
(Loc
,
8741 Chars
=> New_Internal_Name
('R'));
8744 -- Strm : Buffer_Stream_Type;
8747 Make_Object_Declaration
(Loc
,
8748 Defining_Identifier
=>
8752 Object_Definition
=>
8753 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
8755 -- Any_To_BS (Strm, A);
8758 Make_Procedure_Call_Statement
(Loc
,
8760 New_Occurrence_Of
(RTE
(RE_Any_To_BS
), Loc
),
8761 Parameter_Associations
=> New_List
(
8762 New_Occurrence_Of
(Any_Parameter
, Loc
),
8763 New_Occurrence_Of
(Strm
, Loc
))));
8766 -- Res : constant T := T'Input (Strm);
8768 -- Release_Buffer (Strm);
8772 Append_To
(Stms
, Make_Block_Statement
(Loc
,
8773 Declarations
=> New_List
(
8774 Make_Object_Declaration
(Loc
,
8775 Defining_Identifier
=> Res
,
8776 Constant_Present
=> True,
8777 Object_Definition
=>
8778 New_Occurrence_Of
(Typ
, Loc
),
8780 Make_Attribute_Reference
(Loc
,
8781 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
8782 Attribute_Name
=> Name_Input
,
8783 Expressions
=> New_List
(
8784 Make_Attribute_Reference
(Loc
,
8785 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
8786 Attribute_Name
=> Name_Access
))))),
8788 Handled_Statement_Sequence
=>
8789 Make_Handled_Sequence_Of_Statements
(Loc
,
8790 Statements
=> New_List
(
8791 Make_Procedure_Call_Statement
(Loc
,
8793 New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
8794 Parameter_Associations
=>
8796 New_Occurrence_Of
(Strm
, Loc
))),
8797 Make_Return_Statement
(Loc
,
8798 Expression
=> New_Occurrence_Of
(Res
, Loc
))))));
8804 Make_Subprogram_Body
(Loc
,
8805 Specification
=> Spec
,
8806 Declarations
=> Decls
,
8807 Handled_Statement_Sequence
=>
8808 Make_Handled_Sequence_Of_Statements
(Loc
,
8809 Statements
=> Stms
));
8810 end Build_From_Any_Function
;
8812 ---------------------------------
8813 -- Build_Get_Aggregate_Element --
8814 ---------------------------------
8816 function Build_Get_Aggregate_Element
8820 Idx
: Node_Id
) return Node_Id
8823 return Make_Function_Call
(Loc
,
8826 RTE
(RE_Get_Aggregate_Element
), Loc
),
8827 Parameter_Associations
=> New_List
(
8828 New_Occurrence_Of
(Any
, Loc
),
8831 end Build_Get_Aggregate_Element
;
8833 -------------------------
8834 -- Build_Reposiroty_Id --
8835 -------------------------
8837 procedure Build_Name_And_Repository_Id
8839 Name_Str
: out String_Id
;
8840 Repo_Id_Str
: out String_Id
)
8844 Store_String_Chars
("DSA:");
8845 Get_Library_Unit_Name_String
(Scope
(E
));
8846 Store_String_Chars
(
8847 Name_Buffer
(Name_Buffer
'First
8848 .. Name_Buffer
'First + Name_Len
- 1));
8849 Store_String_Char
('.');
8850 Get_Name_String
(Chars
(E
));
8851 Store_String_Chars
(
8852 Name_Buffer
(Name_Buffer
'First
8853 .. Name_Buffer
'First + Name_Len
- 1));
8854 Store_String_Chars
(":1.0");
8855 Repo_Id_Str
:= End_String
;
8856 Name_Str
:= String_From_Name_Buffer
;
8857 end Build_Name_And_Repository_Id
;
8859 -----------------------
8860 -- Build_To_Any_Call --
8861 -----------------------
8863 function Build_To_Any_Call
8865 Decls
: List_Id
) return Node_Id
8867 Loc
: constant Source_Ptr
:= Sloc
(N
);
8869 Typ
: Entity_Id
:= Etype
(N
);
8872 Fnam
: Entity_Id
:= Empty
;
8873 Lib_RE
: RE_Id
:= RE_Null
;
8876 -- If N is a selected component, then maybe its Etype
8877 -- has not been set yet: try to use the Etype of the
8878 -- selector_name in that case.
8880 if No
(Typ
) and then Nkind
(N
) = N_Selected_Component
then
8881 Typ
:= Etype
(Selector_Name
(N
));
8883 pragma Assert
(Present
(Typ
));
8885 -- The full view, if Typ is private; the completion,
8886 -- if Typ is incomplete.
8888 U_Type
:= Underlying_Type
(Typ
);
8890 -- First simple case where the To_Any function is present
8891 -- in the type's TSS.
8893 Fnam
:= Find_Inherited_TSS
(U_Type
, Name_uTo_Any
);
8895 -- Check first for Boolean and Character. These are enumeration
8896 -- types, but we treat them specially, since they may require
8897 -- special handling in the transfer protocol. However, this
8898 -- special handling only applies if they have standard
8899 -- representation, otherwise they are treated like any other
8900 -- enumeration type.
8902 if Sloc
(U_Type
) <= Standard_Location
then
8903 U_Type
:= Base_Type
(U_Type
);
8906 if Present
(Fnam
) then
8909 elsif U_Type
= Standard_Boolean
then
8912 elsif U_Type
= Standard_Character
then
8915 elsif U_Type
= Standard_Wide_Character
then
8918 -- Floating point types
8920 elsif U_Type
= Standard_Short_Float
then
8923 elsif U_Type
= Standard_Float
then
8926 elsif U_Type
= Standard_Long_Float
then
8929 elsif U_Type
= Standard_Long_Long_Float
then
8930 Lib_RE
:= RE_TA_LLF
;
8934 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
8935 Lib_RE
:= RE_TA_SSI
;
8937 elsif U_Type
= Etype
(Standard_Short_Integer
) then
8940 elsif U_Type
= Etype
(Standard_Integer
) then
8943 elsif U_Type
= Etype
(Standard_Long_Integer
) then
8946 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
8947 Lib_RE
:= RE_TA_LLI
;
8949 -- Unsigned integer types
8951 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
8952 Lib_RE
:= RE_TA_SSU
;
8954 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
8957 elsif U_Type
= RTE
(RE_Unsigned
) then
8960 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
8963 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
8964 Lib_RE
:= RE_TA_LLU
;
8966 elsif U_Type
= Standard_String
then
8967 Lib_RE
:= RE_TA_String
;
8969 elsif U_Type
= Underlying_Type
(RTE
(RE_TypeCode
)) then
8972 -- Other (non-primitive) types
8978 Build_To_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
8979 Append_To
(Decls
, Decl
);
8983 -- Call the function
8985 if Lib_RE
/= RE_Null
then
8986 pragma Assert
(No
(Fnam
));
8987 Fnam
:= RTE
(Lib_RE
);
8991 Make_Function_Call
(Loc
,
8992 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
8993 Parameter_Associations
=> New_List
(N
));
8994 end Build_To_Any_Call
;
8996 ---------------------------
8997 -- Build_To_Any_Function --
8998 ---------------------------
9000 procedure Build_To_Any_Function
9004 Fnam
: out Entity_Id
)
9007 Decls
: constant List_Id
:= New_List
;
9008 Stms
: constant List_Id
:= New_List
;
9010 Expr_Parameter
: constant Entity_Id
:=
9011 Make_Defining_Identifier
(Loc
, Name_E
);
9013 Any
: constant Entity_Id
:=
9014 Make_Defining_Identifier
(Loc
, Name_A
);
9017 Result_TC
: Node_Id
:= Build_TypeCode_Call
(Loc
, Typ
, Decls
);
9020 Fnam
:= Make_Stream_Procedure_Function_Name
(Loc
,
9024 Make_Function_Specification
(Loc
,
9025 Defining_Unit_Name
=> Fnam
,
9026 Parameter_Specifications
=> New_List
(
9027 Make_Parameter_Specification
(Loc
,
9028 Defining_Identifier
=>
9031 New_Occurrence_Of
(Typ
, Loc
))),
9032 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9033 Set_Etype
(Expr_Parameter
, Typ
);
9036 Make_Object_Declaration
(Loc
,
9037 Defining_Identifier
=>
9039 Object_Definition
=>
9040 New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9042 if Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9044 Rt_Type
: constant Entity_Id
9046 Expr
: constant Node_Id
9049 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9051 Set_Expression
(Any_Decl
, Build_To_Any_Call
(Expr
, Decls
));
9054 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9055 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
9057 Rt_Type
: constant Entity_Id
9059 Expr
: constant Node_Id
9062 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9065 Set_Expression
(Any_Decl
,
9066 Build_To_Any_Call
(Expr
, Decls
));
9071 Disc
: Entity_Id
:= Empty
;
9072 Rdef
: constant Node_Id
:=
9073 Type_Definition
(Declaration_Node
(Typ
));
9075 Elements
: constant List_Id
:= New_List
;
9077 procedure TA_Rec_Add_Process_Element
9079 Container
: Node_Or_Entity_Id
;
9080 Counter
: in out Int
;
9084 procedure TA_Append_Record_Traversal
is
9085 new Append_Record_Traversal
9086 (Rec
=> Expr_Parameter
,
9087 Add_Process_Element
=> TA_Rec_Add_Process_Element
);
9089 --------------------------------
9090 -- TA_Rec_Add_Process_Element --
9091 --------------------------------
9093 procedure TA_Rec_Add_Process_Element
9095 Container
: Node_Or_Entity_Id
;
9096 Counter
: in out Int
;
9100 Field_Ref
: Node_Id
;
9103 if Nkind
(Field
) = N_Defining_Identifier
then
9105 -- A regular component
9107 Field_Ref
:= Make_Selected_Component
(Loc
,
9108 Prefix
=> New_Occurrence_Of
(Rec
, Loc
),
9109 Selector_Name
=> New_Occurrence_Of
(Field
, Loc
));
9110 Set_Etype
(Field_Ref
, Etype
(Field
));
9113 Make_Procedure_Call_Statement
(Loc
,
9116 RTE
(RE_Add_Aggregate_Element
), Loc
),
9117 Parameter_Associations
=> New_List
(
9118 New_Occurrence_Of
(Any
, Loc
),
9119 Build_To_Any_Call
(Field_Ref
, Decls
))));
9126 Struct_Counter
: Int
:= 0;
9128 Block_Decls
: constant List_Id
:= New_List
;
9129 Block_Stmts
: constant List_Id
:= New_List
;
9132 Alt_List
: constant List_Id
:= New_List
;
9133 Choice_List
: List_Id
;
9135 Union_Any
: constant Entity_Id
:=
9136 Make_Defining_Identifier
(Loc
,
9137 New_Internal_Name
('U'));
9139 Struct_Any
: constant Entity_Id
:=
9140 Make_Defining_Identifier
(Loc
,
9141 New_Internal_Name
('S'));
9143 function Make_Discriminant_Reference
9145 -- Build a selected component for the
9146 -- discriminant of this variant part.
9148 ---------------------------------
9149 -- Make_Discriminant_Reference --
9150 ---------------------------------
9152 function Make_Discriminant_Reference
9155 Nod
: constant Node_Id
:=
9156 Make_Selected_Component
(Loc
,
9159 Chars
(Name
(Field
)));
9161 Set_Etype
(Nod
, Name
(Field
));
9163 end Make_Discriminant_Reference
;
9167 Make_Block_Statement
(Loc
,
9170 Handled_Statement_Sequence
=>
9171 Make_Handled_Sequence_Of_Statements
(Loc
,
9172 Statements
=> Block_Stmts
)));
9174 Append_To
(Block_Decls
,
9175 Make_Object_Declaration
(Loc
,
9176 Defining_Identifier
=> Union_Any
,
9177 Object_Definition
=>
9178 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9180 Make_Function_Call
(Loc
,
9181 Name
=> New_Occurrence_Of
(
9182 RTE
(RE_Create_Any
), Loc
),
9183 Parameter_Associations
=> New_List
(
9184 Make_Function_Call
(Loc
,
9187 RTE
(RE_Any_Member_Type
), Loc
),
9188 Parameter_Associations
=> New_List
(
9189 New_Occurrence_Of
(Container
, Loc
),
9190 Make_Integer_Literal
(Loc
,
9193 Append_To
(Block_Decls
,
9194 Make_Object_Declaration
(Loc
,
9195 Defining_Identifier
=> Struct_Any
,
9196 Object_Definition
=>
9197 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9199 Make_Function_Call
(Loc
,
9200 Name
=> New_Occurrence_Of
(
9201 RTE
(RE_Create_Any
), Loc
),
9202 Parameter_Associations
=> New_List
(
9203 Make_Function_Call
(Loc
,
9206 RTE
(RE_Any_Member_Type
), Loc
),
9207 Parameter_Associations
=> New_List
(
9208 New_Occurrence_Of
(Union_Any
, Loc
),
9209 Make_Integer_Literal
(Loc
,
9212 Append_To
(Block_Stmts
,
9213 Make_Case_Statement
(Loc
,
9215 Make_Discriminant_Reference
,
9219 Variant
:= First_Non_Pragma
(Variants
(Field
));
9220 while Present
(Variant
) loop
9221 Choice_List
:= New_Copy_List_Tree
9222 (Discrete_Choices
(Variant
));
9224 VP_Stmts
:= New_List
;
9225 TA_Append_Record_Traversal
(
9227 Clist
=> Component_List
(Variant
),
9228 Container
=> Struct_Any
,
9229 Counter
=> Struct_Counter
);
9231 -- Append discriminant value and inner struct
9232 -- to union aggregate.
9234 Append_To
(VP_Stmts
,
9235 Make_Procedure_Call_Statement
(Loc
,
9238 RTE
(RE_Add_Aggregate_Element
), Loc
),
9239 Parameter_Associations
=> New_List
(
9240 New_Occurrence_Of
(Union_Any
, Loc
),
9242 Make_Discriminant_Reference
,
9245 Append_To
(VP_Stmts
,
9246 Make_Procedure_Call_Statement
(Loc
,
9249 RTE
(RE_Add_Aggregate_Element
), Loc
),
9250 Parameter_Associations
=> New_List
(
9251 New_Occurrence_Of
(Union_Any
, Loc
),
9252 New_Occurrence_Of
(Struct_Any
, Loc
))));
9254 -- Append union to outer aggregate
9256 Append_To
(VP_Stmts
,
9257 Make_Procedure_Call_Statement
(Loc
,
9260 RTE
(RE_Add_Aggregate_Element
), Loc
),
9261 Parameter_Associations
=> New_List
(
9262 New_Occurrence_Of
(Container
, Loc
),
9263 Make_Function_Call
(Loc
,
9264 Name
=> New_Occurrence_Of
(
9265 RTE
(RE_Any_Aggregate_Build
), Loc
),
9266 Parameter_Associations
=> New_List
(
9268 Union_Any
, Loc
))))));
9270 Append_To
(Alt_List
,
9271 Make_Case_Statement_Alternative
(Loc
,
9272 Discrete_Choices
=> Choice_List
,
9275 Next_Non_Pragma
(Variant
);
9279 end TA_Rec_Add_Process_Element
;
9282 -- First all discriminants
9284 if Has_Discriminants
(Typ
) then
9285 Disc
:= First_Discriminant
(Typ
);
9287 while Present
(Disc
) loop
9288 Append_To
(Elements
,
9289 Make_Component_Association
(Loc
,
9290 Choices
=> New_List
(
9291 Make_Integer_Literal
(Loc
, Counter
)),
9294 Make_Selected_Component
(Loc
,
9295 Prefix
=> Expr_Parameter
,
9296 Selector_Name
=> Chars
(Disc
)),
9298 Counter
:= Counter
+ 1;
9299 Next_Discriminant
(Disc
);
9303 -- Make elements an empty array
9306 Dummy_Any
: constant Entity_Id
:=
9307 Make_Defining_Identifier
(Loc
,
9308 Chars
=> New_Internal_Name
('A'));
9312 Make_Object_Declaration
(Loc
,
9313 Defining_Identifier
=> Dummy_Any
,
9314 Object_Definition
=>
9315 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
9317 Append_To
(Elements
,
9318 Make_Component_Association
(Loc
,
9319 Choices
=> New_List
(
9322 Make_Integer_Literal
(Loc
, 1),
9324 Make_Integer_Literal
(Loc
, 0))),
9326 New_Occurrence_Of
(Dummy_Any
, Loc
)));
9330 Set_Expression
(Any_Decl
,
9331 Make_Function_Call
(Loc
,
9332 Name
=> New_Occurrence_Of
(
9333 RTE
(RE_Any_Aggregate_Build
), Loc
),
9334 Parameter_Associations
=> New_List
(
9336 Make_Aggregate
(Loc
,
9337 Component_Associations
=> Elements
))));
9340 -- ... then all components
9342 TA_Append_Record_Traversal
(Stms
,
9343 Clist
=> Component_List
(Rdef
),
9345 Counter
=> Counter
);
9349 elsif Is_Array_Type
(Typ
) then
9351 Constrained
: constant Boolean := Is_Constrained
(Typ
);
9353 procedure TA_Ary_Add_Process_Element
9356 Counter
: Entity_Id
;
9359 --------------------------------
9360 -- TA_Ary_Add_Process_Element --
9361 --------------------------------
9363 procedure TA_Ary_Add_Process_Element
9366 Counter
: Entity_Id
;
9369 pragma Warnings
(Off
);
9370 pragma Unreferenced
(Counter
);
9371 pragma Warnings
(On
);
9373 Element_Any
: Node_Id
;
9376 if Etype
(Datum
) = RTE
(RE_Any
) then
9377 Element_Any
:= Datum
;
9379 Element_Any
:= Build_To_Any_Call
(Datum
, Decls
);
9383 Make_Procedure_Call_Statement
(Loc
,
9384 Name
=> New_Occurrence_Of
(
9385 RTE
(RE_Add_Aggregate_Element
), Loc
),
9386 Parameter_Associations
=> New_List
(
9387 New_Occurrence_Of
(Any
, Loc
),
9389 end TA_Ary_Add_Process_Element
;
9391 procedure Append_To_Any_Array_Iterator
is
9392 new Append_Array_Traversal
(
9394 Arry
=> Expr_Parameter
,
9395 Indices
=> New_List
,
9396 Add_Process_Element
=> TA_Ary_Add_Process_Element
);
9401 Set_Expression
(Any_Decl
,
9402 Make_Function_Call
(Loc
,
9404 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
9405 Parameter_Associations
=> New_List
(Result_TC
)));
9408 if not Constrained
then
9409 Index
:= First_Index
(Typ
);
9410 for J
in 1 .. Number_Dimensions
(Typ
) loop
9412 Make_Procedure_Call_Statement
(Loc
,
9415 RTE
(RE_Add_Aggregate_Element
), Loc
),
9416 Parameter_Associations
=> New_List
(
9417 New_Occurrence_Of
(Any
, Loc
),
9419 OK_Convert_To
(Etype
(Index
),
9420 Make_Attribute_Reference
(Loc
,
9422 New_Occurrence_Of
(Expr_Parameter
, Loc
),
9423 Attribute_Name
=> Name_First
,
9424 Expressions
=> New_List
(
9425 Make_Integer_Literal
(Loc
, J
)))),
9431 Append_To_Any_Array_Iterator
(Stms
, Any
);
9434 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9435 Set_Expression
(Any_Decl
,
9438 Find_Numeric_Representation
(Typ
),
9439 New_Occurrence_Of
(Expr_Parameter
, Loc
)),
9443 -- Default: type is represented as an opaque sequence of bytes
9446 Strm
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
9447 New_Internal_Name
('S'));
9450 -- Strm : aliased Buffer_Stream_Type;
9453 Make_Object_Declaration
(Loc
,
9454 Defining_Identifier
=>
9458 Object_Definition
=>
9459 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
9461 -- Allocate_Buffer (Strm);
9464 Make_Procedure_Call_Statement
(Loc
,
9466 New_Occurrence_Of
(RTE
(RE_Allocate_Buffer
), Loc
),
9467 Parameter_Associations
=> New_List
(
9468 New_Occurrence_Of
(Strm
, Loc
))));
9470 -- T'Output (Strm'Access, E);
9473 Make_Attribute_Reference
(Loc
,
9474 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
9475 Attribute_Name
=> Name_Output
,
9476 Expressions
=> New_List
(
9477 Make_Attribute_Reference
(Loc
,
9478 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
9479 Attribute_Name
=> Name_Access
),
9480 New_Occurrence_Of
(Expr_Parameter
, Loc
))));
9482 -- BS_To_Any (Strm, A);
9485 Make_Procedure_Call_Statement
(Loc
,
9487 New_Occurrence_Of
(RTE
(RE_BS_To_Any
), Loc
),
9488 Parameter_Associations
=> New_List
(
9489 New_Occurrence_Of
(Strm
, Loc
),
9490 New_Occurrence_Of
(Any
, Loc
))));
9492 -- Release_Buffer (Strm);
9495 Make_Procedure_Call_Statement
(Loc
,
9497 New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
9498 Parameter_Associations
=> New_List
(
9499 New_Occurrence_Of
(Strm
, Loc
))));
9503 Append_To
(Decls
, Any_Decl
);
9505 if Present
(Result_TC
) then
9507 Make_Procedure_Call_Statement
(Loc
,
9508 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
9509 Parameter_Associations
=> New_List
(
9510 New_Occurrence_Of
(Any
, Loc
),
9515 Make_Return_Statement
(Loc
,
9516 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
9519 Make_Subprogram_Body
(Loc
,
9520 Specification
=> Spec
,
9521 Declarations
=> Decls
,
9522 Handled_Statement_Sequence
=>
9523 Make_Handled_Sequence_Of_Statements
(Loc
,
9524 Statements
=> Stms
));
9525 end Build_To_Any_Function
;
9527 -------------------------
9528 -- Build_TypeCode_Call --
9529 -------------------------
9531 function Build_TypeCode_Call
9534 Decls
: List_Id
) return Node_Id
9536 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
9537 -- The full view, if Typ is private; the completion,
9538 -- if Typ is incomplete.
9540 Fnam
: Entity_Id
:= Empty
;
9541 Tnam
: Entity_Id
:= Empty
;
9542 Pnam
: Entity_Id
:= Empty
;
9543 Args
: List_Id
:= Empty_List
;
9544 Lib_RE
: RE_Id
:= RE_Null
;
9549 -- Special case System.PolyORB.Interface.Any: its primitives have
9550 -- not been set yet, so can't call Find_Inherited_TSS.
9552 if Typ
= RTE
(RE_Any
) then
9553 Fnam
:= RTE
(RE_TC_Any
);
9556 -- First simple case where the TypeCode is present
9557 -- in the type's TSS.
9559 Fnam
:= Find_Inherited_TSS
(U_Type
, Name_uTypeCode
);
9561 if Present
(Fnam
) then
9563 -- When a TypeCode TSS exists, it has a single parameter
9564 -- that is an anonymous access to the corresponding type.
9565 -- This parameter is not used in any way; its purpose is
9566 -- solely to provide overloading of the TSS.
9569 Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
9571 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
9574 Make_Full_Type_Declaration
(Loc
,
9575 Defining_Identifier
=> Tnam
,
9577 Make_Access_To_Object_Definition
(Loc
,
9578 Subtype_Indication
=>
9579 New_Occurrence_Of
(U_Type
, Loc
))));
9581 Make_Object_Declaration
(Loc
,
9582 Defining_Identifier
=> Pnam
,
9583 Constant_Present
=> True,
9584 Object_Definition
=> New_Occurrence_Of
(Tnam
, Loc
),
9586 -- Use a variable here to force proper freezing of Tnam
9588 Expression
=> Make_Null
(Loc
)));
9590 -- Normally, calling _TypeCode with a null access parameter
9591 -- should raise Constraint_Error, but this check is
9592 -- suppressed for expanded code, and we do not care anyway
9593 -- because we do not actually ever use this value.
9595 Args
:= New_List
(New_Occurrence_Of
(Pnam
, Loc
));
9600 if Sloc
(U_Type
) <= Standard_Location
then
9602 -- Do not try to build alias typecodes for subtypes from
9605 U_Type
:= Base_Type
(U_Type
);
9608 if Is_Itype
(U_Type
) then
9609 return Build_TypeCode_Call
9610 (Loc
, Associated_Node_For_Itype
(U_Type
), Decls
);
9613 if U_Type
= Standard_Boolean
then
9616 elsif U_Type
= Standard_Character
then
9619 elsif U_Type
= Standard_Wide_Character
then
9622 -- Floating point types
9624 elsif U_Type
= Standard_Short_Float
then
9627 elsif U_Type
= Standard_Float
then
9630 elsif U_Type
= Standard_Long_Float
then
9633 elsif U_Type
= Standard_Long_Long_Float
then
9634 Lib_RE
:= RE_TC_LLF
;
9636 -- Integer types (walk back to the base type)
9638 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
9639 Lib_RE
:= RE_TC_SSI
;
9641 elsif U_Type
= Etype
(Standard_Short_Integer
) then
9644 elsif U_Type
= Etype
(Standard_Integer
) then
9647 elsif U_Type
= Etype
(Standard_Long_Integer
) then
9650 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
9651 Lib_RE
:= RE_TC_LLI
;
9653 -- Unsigned integer types
9655 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
9656 Lib_RE
:= RE_TC_SSU
;
9658 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
9661 elsif U_Type
= RTE
(RE_Unsigned
) then
9664 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
9667 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
9668 Lib_RE
:= RE_TC_LLU
;
9670 elsif U_Type
= Standard_String
then
9671 Lib_RE
:= RE_TC_String
;
9673 -- Other (non-primitive) types
9679 Build_TypeCode_Function
(Loc
, U_Type
, Decl
, Fnam
);
9680 Append_To
(Decls
, Decl
);
9684 if Lib_RE
/= RE_Null
then
9685 Fnam
:= RTE
(Lib_RE
);
9689 -- Call the function
9692 Make_Function_Call
(Loc
,
9693 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
9694 Parameter_Associations
=> Args
);
9696 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
9698 Set_Etype
(Expr
, RTE
(RE_TypeCode
));
9701 end Build_TypeCode_Call
;
9703 -----------------------------
9704 -- Build_TypeCode_Function --
9705 -----------------------------
9707 procedure Build_TypeCode_Function
9711 Fnam
: out Entity_Id
)
9714 Decls
: constant List_Id
:= New_List
;
9715 Stms
: constant List_Id
:= New_List
;
9717 TCNam
: constant Entity_Id
:=
9718 Make_Stream_Procedure_Function_Name
(Loc
,
9719 Typ
, Name_uTypeCode
);
9721 Parameters
: List_Id
;
9723 procedure Add_String_Parameter
9725 Parameter_List
: List_Id
);
9726 -- Add a literal for S to Parameters
9728 procedure Add_TypeCode_Parameter
9730 Parameter_List
: List_Id
);
9731 -- Add the typecode for Typ to Parameters
9733 procedure Add_Long_Parameter
9734 (Expr_Node
: Node_Id
;
9735 Parameter_List
: List_Id
);
9736 -- Add a signed long integer expression to Parameters
9738 procedure Initialize_Parameter_List
9739 (Name_String
: String_Id
;
9740 Repo_Id_String
: String_Id
;
9741 Parameter_List
: out List_Id
);
9742 -- Return a list that contains the first two parameters
9743 -- for a parameterized typecode: name and repository id.
9745 function Make_Constructed_TypeCode
9747 Parameters
: List_Id
) return Node_Id
;
9748 -- Call TC_Build with the given kind and parameters
9750 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
);
9751 -- Make a return statement that calls TC_Build with the given
9752 -- typecode kind, and the constructed parameters list.
9754 procedure Return_Alias_TypeCode
(Base_TypeCode
: Node_Id
);
9755 -- Return a typecode that is a TC_Alias for the given typecode
9757 --------------------------
9758 -- Add_String_Parameter --
9759 --------------------------
9761 procedure Add_String_Parameter
9763 Parameter_List
: List_Id
)
9766 Append_To
(Parameter_List
,
9767 Make_Function_Call
(Loc
,
9769 New_Occurrence_Of
(RTE
(RE_TA_String
), Loc
),
9770 Parameter_Associations
=> New_List
(
9771 Make_String_Literal
(Loc
, S
))));
9772 end Add_String_Parameter
;
9774 ----------------------------
9775 -- Add_TypeCode_Parameter --
9776 ----------------------------
9778 procedure Add_TypeCode_Parameter
9780 Parameter_List
: List_Id
)
9783 Append_To
(Parameter_List
,
9784 Make_Function_Call
(Loc
,
9786 New_Occurrence_Of
(RTE
(RE_TA_TC
), Loc
),
9787 Parameter_Associations
=> New_List
(
9789 end Add_TypeCode_Parameter
;
9791 ------------------------
9792 -- Add_Long_Parameter --
9793 ------------------------
9795 procedure Add_Long_Parameter
9796 (Expr_Node
: Node_Id
;
9797 Parameter_List
: List_Id
)
9800 Append_To
(Parameter_List
,
9801 Make_Function_Call
(Loc
,
9803 New_Occurrence_Of
(RTE
(RE_TA_LI
), Loc
),
9804 Parameter_Associations
=> New_List
(Expr_Node
)));
9805 end Add_Long_Parameter
;
9807 -------------------------------
9808 -- Initialize_Parameter_List --
9809 -------------------------------
9811 procedure Initialize_Parameter_List
9812 (Name_String
: String_Id
;
9813 Repo_Id_String
: String_Id
;
9814 Parameter_List
: out List_Id
)
9817 Parameter_List
:= New_List
;
9818 Add_String_Parameter
(Name_String
, Parameter_List
);
9819 Add_String_Parameter
(Repo_Id_String
, Parameter_List
);
9820 end Initialize_Parameter_List
;
9822 ---------------------------
9823 -- Return_Alias_TypeCode --
9824 ---------------------------
9826 procedure Return_Alias_TypeCode
9827 (Base_TypeCode
: Node_Id
)
9830 Add_TypeCode_Parameter
(Base_TypeCode
, Parameters
);
9831 Return_Constructed_TypeCode
(RTE
(RE_TC_Alias
));
9832 end Return_Alias_TypeCode
;
9834 -------------------------------
9835 -- Make_Constructed_TypeCode --
9836 -------------------------------
9838 function Make_Constructed_TypeCode
9840 Parameters
: List_Id
) return Node_Id
9842 Constructed_TC
: constant Node_Id
:=
9843 Make_Function_Call
(Loc
,
9845 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
9846 Parameter_Associations
=> New_List
(
9847 New_Occurrence_Of
(Kind
, Loc
),
9848 Make_Aggregate
(Loc
,
9849 Expressions
=> Parameters
)));
9851 Set_Etype
(Constructed_TC
, RTE
(RE_TypeCode
));
9852 return Constructed_TC
;
9853 end Make_Constructed_TypeCode
;
9855 ---------------------------------
9856 -- Return_Constructed_TypeCode --
9857 ---------------------------------
9859 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
) is
9862 Make_Return_Statement
(Loc
,
9864 Make_Constructed_TypeCode
(Kind
, Parameters
)));
9865 end Return_Constructed_TypeCode
;
9871 procedure TC_Rec_Add_Process_Element
9874 Counter
: in out Int
;
9878 procedure TC_Append_Record_Traversal
is
9879 new Append_Record_Traversal
(
9881 Add_Process_Element
=> TC_Rec_Add_Process_Element
);
9883 --------------------------------
9884 -- TC_Rec_Add_Process_Element --
9885 --------------------------------
9887 procedure TC_Rec_Add_Process_Element
9890 Counter
: in out Int
;
9894 pragma Warnings
(Off
);
9895 pragma Unreferenced
(Any
, Counter
, Rec
);
9896 pragma Warnings
(On
);
9899 if Nkind
(Field
) = N_Defining_Identifier
then
9901 -- A regular component
9903 Add_TypeCode_Parameter
(
9904 Build_TypeCode_Call
(Loc
, Etype
(Field
), Decls
), Params
);
9905 Get_Name_String
(Chars
(Field
));
9906 Add_String_Parameter
(String_From_Name_Buffer
, Params
);
9913 Discriminant_Type
: constant Entity_Id
:=
9914 Etype
(Name
(Field
));
9916 Is_Enum
: constant Boolean :=
9917 Is_Enumeration_Type
(Discriminant_Type
);
9919 Union_TC_Params
: List_Id
;
9921 U_Name
: constant Name_Id
:=
9922 New_External_Name
(Chars
(Typ
), 'U', -1);
9924 Name_Str
: String_Id
;
9925 Struct_TC_Params
: List_Id
;
9929 Default
: constant Node_Id
:=
9930 Make_Integer_Literal
(Loc
, -1);
9932 Dummy_Counter
: Int
:= 0;
9934 procedure Add_Params_For_Variant_Components
;
9935 -- Add a struct TypeCode and a corresponding member name
9936 -- to the union parameter list.
9938 -- Ordering of declarations is a complete mess in this
9939 -- area, it is supposed to be types/varibles, then
9940 -- subprogram specs, then subprogram bodies ???
9942 ---------------------------------------
9943 -- Add_Params_For_Variant_Components --
9944 ---------------------------------------
9946 procedure Add_Params_For_Variant_Components
9948 S_Name
: constant Name_Id
:=
9949 New_External_Name
(U_Name
, 'S', -1);
9952 Get_Name_String
(S_Name
);
9953 Name_Str
:= String_From_Name_Buffer
;
9954 Initialize_Parameter_List
9955 (Name_Str
, Name_Str
, Struct_TC_Params
);
9957 -- Build struct parameters
9959 TC_Append_Record_Traversal
(Struct_TC_Params
,
9960 Component_List
(Variant
),
9964 Add_TypeCode_Parameter
9965 (Make_Constructed_TypeCode
9966 (RTE
(RE_TC_Struct
), Struct_TC_Params
),
9969 Add_String_Parameter
(Name_Str
, Union_TC_Params
);
9970 end Add_Params_For_Variant_Components
;
9973 Get_Name_String
(U_Name
);
9974 Name_Str
:= String_From_Name_Buffer
;
9976 Initialize_Parameter_List
9977 (Name_Str
, Name_Str
, Union_TC_Params
);
9979 Add_String_Parameter
(Name_Str
, Params
);
9981 -- Add union in enclosing parameter list
9983 Add_TypeCode_Parameter
9984 (Make_Constructed_TypeCode
9985 (RTE
(RE_TC_Union
), Union_TC_Params
),
9988 -- Build union parameters
9990 Add_TypeCode_Parameter
9991 (Discriminant_Type
, Union_TC_Params
);
9992 Add_Long_Parameter
(Default
, Union_TC_Params
);
9994 Variant
:= First_Non_Pragma
(Variants
(Field
));
9995 while Present
(Variant
) loop
9996 Choice
:= First
(Discrete_Choices
(Variant
));
9997 while Present
(Choice
) loop
9998 case Nkind
(Choice
) is
10001 L
: constant Uint
:=
10002 Expr_Value
(Low_Bound
(Choice
));
10003 H
: constant Uint
:=
10004 Expr_Value
(High_Bound
(Choice
));
10006 -- 3.8.1(8) guarantees that the bounds of
10007 -- this range are static.
10014 Expr
:= New_Occurrence_Of
(
10015 Get_Enum_Lit_From_Pos
(
10016 Discriminant_Type
, J
, Loc
), Loc
);
10019 Make_Integer_Literal
(Loc
, J
);
10021 Append_To
(Union_TC_Params
,
10022 Build_To_Any_Call
(Expr
, Decls
));
10023 Add_Params_For_Variant_Components
;
10028 when N_Others_Choice
=>
10029 Add_Long_Parameter
(
10030 Make_Integer_Literal
(Loc
, 0),
10032 Add_Params_For_Variant_Components
;
10035 Append_To
(Union_TC_Params
,
10036 Build_To_Any_Call
(Choice
, Decls
));
10037 Add_Params_For_Variant_Components
;
10043 Next_Non_Pragma
(Variant
);
10048 end TC_Rec_Add_Process_Element
;
10050 Type_Name_Str
: String_Id
;
10051 Type_Repo_Id_Str
: String_Id
;
10054 pragma Assert
(not Is_Itype
(Typ
));
10058 Make_Function_Specification
(Loc
,
10059 Defining_Unit_Name
=> Fnam
,
10060 Parameter_Specifications
=> Empty_List
,
10061 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
10063 Build_Name_And_Repository_Id
(Typ
,
10064 Name_Str
=> Type_Name_Str
, Repo_Id_Str
=> Type_Repo_Id_Str
);
10065 Initialize_Parameter_List
10066 (Type_Name_Str
, Type_Repo_Id_Str
, Parameters
);
10068 if Is_Derived_Type
(Typ
)
10069 and then not Is_Tagged_Type
(Typ
)
10072 D_Node
: constant Node_Id
:= Declaration_Node
(Typ
);
10073 Parent_Type
: Entity_Id
:= Etype
(Typ
);
10076 if Is_Enumeration_Type
(Typ
)
10077 and then Nkind
(D_Node
) = N_Subtype_Declaration
10078 and then Nkind
(Original_Node
(D_Node
))
10079 /= N_Subtype_Declaration
10082 -- Parent_Type is the implicit intermediate base type
10083 -- created by Build_Derived_Enumeration_Type.
10085 Parent_Type
:= Etype
(Parent_Type
);
10088 Return_Alias_TypeCode
(
10089 Build_TypeCode_Call
(Loc
, Parent_Type
, Decls
));
10092 elsif Is_Integer_Type
(Typ
)
10093 or else Is_Unsigned_Type
(Typ
)
10095 Return_Alias_TypeCode
(
10096 Build_TypeCode_Call
(Loc
,
10097 Find_Numeric_Representation
(Typ
), Decls
));
10099 elsif Is_Record_Type
(Typ
)
10100 and then not Is_Tagged_Type
(Typ
)
10102 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
10103 Return_Alias_TypeCode
(
10104 Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10107 Disc
: Entity_Id
:= Empty
;
10108 Rdef
: constant Node_Id
:=
10109 Type_Definition
(Declaration_Node
(Typ
));
10110 Dummy_Counter
: Int
:= 0;
10112 -- First all discriminants
10114 if Has_Discriminants
(Typ
) then
10115 Disc
:= First_Discriminant
(Typ
);
10117 while Present
(Disc
) loop
10118 Add_TypeCode_Parameter
(
10119 Build_TypeCode_Call
(Loc
, Etype
(Disc
), Decls
),
10121 Get_Name_String
(Chars
(Disc
));
10122 Add_String_Parameter
(
10123 String_From_Name_Buffer
,
10125 Next_Discriminant
(Disc
);
10128 -- ... then all components
10130 TC_Append_Record_Traversal
10131 (Parameters
, Component_List
(Rdef
),
10132 Empty
, Dummy_Counter
);
10133 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10137 elsif Is_Array_Type
(Typ
) then
10139 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10140 Inner_TypeCode
: Node_Id
;
10141 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10142 Indx
: Node_Id
:= First_Index
(Typ
);
10145 Inner_TypeCode
:= Build_TypeCode_Call
(Loc
,
10146 Component_Type
(Typ
),
10149 for J
in 1 .. Ndim
loop
10150 if Constrained
then
10151 Inner_TypeCode
:= Make_Constructed_TypeCode
10152 (RTE
(RE_TC_Array
), New_List
(
10153 Build_To_Any_Call
(
10154 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10155 Make_Attribute_Reference
(Loc
,
10157 New_Occurrence_Of
(Typ
, Loc
),
10160 Expressions
=> New_List
(
10161 Make_Integer_Literal
(Loc
,
10164 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10167 -- Unconstrained case: add low bound for each
10170 Add_TypeCode_Parameter
10171 (Build_TypeCode_Call
(Loc
, Etype
(Indx
), Decls
),
10173 Get_Name_String
(New_External_Name
('L', J
));
10174 Add_String_Parameter
(
10175 String_From_Name_Buffer
,
10179 Inner_TypeCode
:= Make_Constructed_TypeCode
10180 (RTE
(RE_TC_Sequence
), New_List
(
10181 Build_To_Any_Call
(
10182 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10183 Make_Integer_Literal
(Loc
, 0)),
10185 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10189 if Constrained
then
10190 Return_Alias_TypeCode
(Inner_TypeCode
);
10192 Add_TypeCode_Parameter
(Inner_TypeCode
, Parameters
);
10194 Store_String_Char
('V');
10195 Add_String_Parameter
(End_String
, Parameters
);
10196 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10201 -- Default: type is represented as an opaque sequence of bytes
10203 Return_Alias_TypeCode
10204 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10208 Make_Subprogram_Body
(Loc
,
10209 Specification
=> Spec
,
10210 Declarations
=> Decls
,
10211 Handled_Statement_Sequence
=>
10212 Make_Handled_Sequence_Of_Statements
(Loc
,
10213 Statements
=> Stms
));
10214 end Build_TypeCode_Function
;
10216 ------------------------
10217 -- Find_Inherited_TSS --
10218 ------------------------
10220 function Find_Inherited_TSS
10222 Nam
: Name_Id
) return Entity_Id
10224 P_Type
: Entity_Id
:= Typ
;
10228 Proc
:= TSS
(Base_Type
(Typ
), Nam
);
10230 -- Check first if there is a TSS given for the type itself
10232 if Present
(Proc
) then
10236 -- If Typ is a derived type, it may inherit attributes from some
10237 -- ancestor which is not the ultimate underlying one. If Typ is a
10238 -- derived tagged type, The corresponding primitive operation has
10239 -- been created explicitly.
10241 if Is_Derived_Type
(P_Type
) then
10242 if Is_Tagged_Type
(P_Type
) then
10243 return Find_Prim_Op
(P_Type
, Nam
);
10245 while Is_Derived_Type
(P_Type
) loop
10246 Proc
:= TSS
(Base_Type
(Etype
(Typ
)), Nam
);
10248 if Present
(Proc
) then
10251 P_Type
:= Base_Type
(Etype
(P_Type
));
10257 -- If nothing else, use the TSS of the root type
10259 return TSS
(Base_Type
(Underlying_Type
(Typ
)), Nam
);
10260 end Find_Inherited_TSS
;
10262 ---------------------------------
10263 -- Find_Numeric_Representation --
10264 ---------------------------------
10266 function Find_Numeric_Representation
(Typ
: Entity_Id
)
10269 FST
: constant Entity_Id
:= First_Subtype
(Typ
);
10270 P_Size
: constant Uint
:= Esize
(FST
);
10273 if Is_Unsigned_Type
(Typ
) then
10274 if P_Size
<= Standard_Short_Short_Integer_Size
then
10275 return RTE
(RE_Short_Short_Unsigned
);
10277 elsif P_Size
<= Standard_Short_Integer_Size
then
10278 return RTE
(RE_Short_Unsigned
);
10280 elsif P_Size
<= Standard_Integer_Size
then
10281 return RTE
(RE_Unsigned
);
10283 elsif P_Size
<= Standard_Long_Integer_Size
then
10284 return RTE
(RE_Long_Unsigned
);
10287 return RTE
(RE_Long_Long_Unsigned
);
10290 elsif Is_Integer_Type
(Typ
) then
10291 if P_Size
<= Standard_Short_Short_Integer_Size
then
10292 return Standard_Short_Short_Integer
;
10294 elsif P_Size
<= Standard_Short_Integer_Size
then
10295 return Standard_Short_Integer
;
10297 elsif P_Size
<= Standard_Integer_Size
then
10298 return Standard_Integer
;
10300 elsif P_Size
<= Standard_Long_Integer_Size
then
10301 return Standard_Long_Integer
;
10304 return Standard_Long_Long_Integer
;
10307 elsif Is_Floating_Point_Type
(Typ
) then
10308 if P_Size
<= Standard_Short_Float_Size
then
10309 return Standard_Short_Float
;
10311 elsif P_Size
<= Standard_Float_Size
then
10312 return Standard_Float
;
10314 elsif P_Size
<= Standard_Long_Float_Size
then
10315 return Standard_Long_Float
;
10318 return Standard_Long_Long_Float
;
10322 raise Program_Error
;
10325 -- TBD: fixed point types???
10326 -- TBverified numeric types with a biased representation???
10328 end Find_Numeric_Representation
;
10330 ---------------------------
10331 -- Append_Array_Traversal --
10332 ---------------------------
10334 procedure Append_Array_Traversal
10337 Counter
: Entity_Id
:= Empty
;
10340 Loc
: constant Source_Ptr
:= Sloc
(Subprogram
);
10341 Typ
: constant Entity_Id
:= Etype
(Arry
);
10342 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10343 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10345 Inner_Any
, Inner_Counter
: Entity_Id
;
10347 Loop_Stm
: Node_Id
;
10348 Inner_Stmts
: constant List_Id
:= New_List
;
10351 if Depth
> Ndim
then
10353 -- Processing for one element of an array
10356 Element_Expr
: constant Node_Id
:=
10357 Make_Indexed_Component
(Loc
,
10358 New_Occurrence_Of
(Arry
, Loc
),
10362 Set_Etype
(Element_Expr
, Component_Type
(Typ
));
10363 Add_Process_Element
(Stmts
,
10365 Counter
=> Counter
,
10366 Datum
=> Element_Expr
);
10372 Append_To
(Indices
,
10373 Make_Identifier
(Loc
, New_External_Name
('L', Depth
)));
10375 if Constrained
then
10377 Inner_Counter
:= Counter
;
10379 Inner_Any
:= Make_Defining_Identifier
(Loc
,
10380 New_External_Name
('A', Depth
));
10381 Set_Etype
(Inner_Any
, RTE
(RE_Any
));
10383 if Present
(Counter
) then
10384 Inner_Counter
:= Make_Defining_Identifier
(Loc
,
10385 New_External_Name
('J', Depth
));
10387 Inner_Counter
:= Empty
;
10391 Append_Array_Traversal
(Inner_Stmts
,
10393 Counter
=> Inner_Counter
,
10394 Depth
=> Depth
+ 1);
10397 Make_Implicit_Loop_Statement
(Subprogram
,
10398 Iteration_Scheme
=>
10399 Make_Iteration_Scheme
(Loc
,
10400 Loop_Parameter_Specification
=>
10401 Make_Loop_Parameter_Specification
(Loc
,
10402 Defining_Identifier
=>
10403 Make_Defining_Identifier
(Loc
,
10404 Chars
=> New_External_Name
('L', Depth
)),
10406 Discrete_Subtype_Definition
=>
10407 Make_Attribute_Reference
(Loc
,
10408 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10409 Attribute_Name
=> Name_Range
,
10411 Expressions
=> New_List
(
10412 Make_Integer_Literal
(Loc
, Depth
))))),
10413 Statements
=> Inner_Stmts
);
10415 if Constrained
then
10416 Append_To
(Stmts
, Loop_Stm
);
10421 Decls
: constant List_Id
:= New_List
;
10422 Dimen_Stmts
: constant List_Id
:= New_List
;
10423 Length_Node
: Node_Id
;
10425 Inner_Any_TypeCode
: constant Entity_Id
:=
10426 Make_Defining_Identifier
(Loc
,
10427 New_External_Name
('T', Depth
));
10429 Inner_Any_TypeCode_Expr
: Node_Id
;
10433 Inner_Any_TypeCode_Expr
:=
10434 Make_Function_Call
(Loc
,
10436 New_Occurrence_Of
(RTE
(RE_Any_Member_Type
), Loc
),
10437 Parameter_Associations
=> New_List
(
10438 New_Occurrence_Of
(Any
, Loc
),
10439 Make_Integer_Literal
(Loc
, Ndim
)));
10441 Inner_Any_TypeCode_Expr
:=
10442 Make_Function_Call
(Loc
,
10444 New_Occurrence_Of
(RTE
(RE_Content_Type
), Loc
),
10445 Parameter_Associations
=> New_List
(
10446 Make_Identifier
(Loc
,
10447 New_External_Name
('T', Depth
- 1))));
10451 Make_Object_Declaration
(Loc
,
10452 Defining_Identifier
=> Inner_Any_TypeCode
,
10453 Constant_Present
=> True,
10454 Object_Definition
=> New_Occurrence_Of
(
10455 RTE
(RE_TypeCode
), Loc
),
10456 Expression
=> Inner_Any_TypeCode_Expr
));
10458 Make_Object_Declaration
(Loc
,
10459 Defining_Identifier
=> Inner_Any
,
10460 Object_Definition
=>
10461 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
10463 Make_Function_Call
(Loc
,
10465 New_Occurrence_Of
(
10466 RTE
(RE_Create_Any
), Loc
),
10467 Parameter_Associations
=> New_List
(
10468 New_Occurrence_Of
(Inner_Any_TypeCode
, Loc
)))));
10470 if Present
(Inner_Counter
) then
10472 Make_Object_Declaration
(Loc
,
10473 Defining_Identifier
=> Inner_Counter
,
10474 Object_Definition
=>
10475 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
10477 Make_Integer_Literal
(Loc
, 0)));
10480 Length_Node
:= Make_Attribute_Reference
(Loc
,
10481 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10482 Attribute_Name
=> Name_Length
,
10484 New_List
(Make_Integer_Literal
(Loc
, Depth
)));
10485 Set_Etype
(Length_Node
, RTE
(RE_Long_Unsigned
));
10487 Add_Process_Element
(Dimen_Stmts
,
10488 Datum
=> Length_Node
,
10490 Counter
=> Inner_Counter
);
10492 -- Loop_Stm does approrpriate processing for each element
10495 Append_To
(Dimen_Stmts
, Loop_Stm
);
10497 -- Link outer and inner any
10499 Add_Process_Element
(Dimen_Stmts
,
10501 Counter
=> Counter
,
10502 Datum
=> New_Occurrence_Of
(Inner_Any
, Loc
));
10506 Make_Block_Statement
(Loc
,
10509 Handled_Statement_Sequence
=>
10510 Make_Handled_Sequence_Of_Statements
(Loc
,
10511 Statements
=> Dimen_Stmts
)));
10513 end Append_Array_Traversal
;
10515 -----------------------------------------
10516 -- Make_Stream_Procedure_Function_Name --
10517 -----------------------------------------
10519 function Make_Stream_Procedure_Function_Name
10522 Nam
: Name_Id
) return Entity_Id
10525 -- For tagged types, we use a canonical name so that it matches
10526 -- the primitive spec. For all other cases, we use a serialized
10527 -- name so that multiple generations of the same procedure do not
10530 if Is_Tagged_Type
(Typ
) then
10531 return Make_Defining_Identifier
(Loc
, Nam
);
10533 return Make_Defining_Identifier
(Loc
,
10535 New_External_Name
(Nam
, ' ', Increment_Serial_Number
));
10537 end Make_Stream_Procedure_Function_Name
;
10540 -----------------------------------
10541 -- Reserve_NamingContext_Methods --
10542 -----------------------------------
10544 procedure Reserve_NamingContext_Methods
is
10545 Str_Resolve
: constant String := "resolve";
10547 Name_Buffer
(1 .. Str_Resolve
'Length) := Str_Resolve
;
10548 Name_Len
:= Str_Resolve
'Length;
10549 Overload_Counter_Table
.Set
(Name_Find
, 1);
10550 end Reserve_NamingContext_Methods
;
10552 end PolyORB_Support
;
10554 -------------------------------
10555 -- RACW_Type_Is_Asynchronous --
10556 -------------------------------
10558 procedure RACW_Type_Is_Asynchronous
(RACW_Type
: Entity_Id
) is
10559 Asynchronous_Flag
: constant Entity_Id
:=
10560 Asynchronous_Flags_Table
.Get
(RACW_Type
);
10562 Replace
(Expression
(Parent
(Asynchronous_Flag
)),
10563 New_Occurrence_Of
(Standard_True
, Sloc
(Asynchronous_Flag
)));
10564 end RACW_Type_Is_Asynchronous
;
10566 -------------------------
10567 -- RCI_Package_Locator --
10568 -------------------------
10570 function RCI_Package_Locator
10572 Package_Spec
: Node_Id
) return Node_Id
10575 Pkg_Name
: String_Id
;
10578 Get_Library_Unit_Name_String
(Package_Spec
);
10579 Pkg_Name
:= String_From_Name_Buffer
;
10581 Make_Package_Instantiation
(Loc
,
10582 Defining_Unit_Name
=>
10583 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
10585 New_Occurrence_Of
(RTE
(RE_RCI_Locator
), Loc
),
10586 Generic_Associations
=> New_List
(
10587 Make_Generic_Association
(Loc
,
10589 Make_Identifier
(Loc
, Name_RCI_Name
),
10590 Explicit_Generic_Actual_Parameter
=>
10591 Make_String_Literal
(Loc
,
10592 Strval
=> Pkg_Name
))));
10594 RCI_Locator_Table
.Set
(Defining_Unit_Name
(Package_Spec
),
10595 Defining_Unit_Name
(Inst
));
10597 end RCI_Package_Locator
;
10599 -----------------------------------------------
10600 -- Remote_Types_Tagged_Full_View_Encountered --
10601 -----------------------------------------------
10603 procedure Remote_Types_Tagged_Full_View_Encountered
10604 (Full_View
: Entity_Id
)
10606 Stub_Elements
: constant Stub_Structure
:=
10607 Stubs_Table
.Get
(Full_View
);
10609 if Stub_Elements
/= Empty_Stub_Structure
then
10610 Add_RACW_Primitive_Declarations_And_Bodies
10612 Stub_Elements
.RPC_Receiver_Decl
,
10613 List_Containing
(Declaration_Node
(Full_View
)));
10615 end Remote_Types_Tagged_Full_View_Encountered
;
10617 -------------------
10618 -- Scope_Of_Spec --
10619 -------------------
10621 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
is
10622 Unit_Name
: Node_Id
:= Defining_Unit_Name
(Spec
);
10625 while Nkind
(Unit_Name
) /= N_Defining_Identifier
loop
10626 Unit_Name
:= Defining_Identifier
(Unit_Name
);
10632 ----------------------
10633 -- Set_Renaming_TSS --
10634 ----------------------
10636 procedure Set_Renaming_TSS
10641 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
10642 Spec
: constant Node_Id
:= Parent
(Nam
);
10644 TSS_Node
: constant Node_Id
:=
10645 Make_Subprogram_Renaming_Declaration
(Loc
,
10647 Copy_Specification
(Loc
,
10649 New_Name
=> TSS_Nam
),
10650 Name
=> New_Occurrence_Of
(Nam
, Loc
));
10652 Snam
: constant Entity_Id
:=
10653 Defining_Unit_Name
(Specification
(TSS_Node
));
10656 if Nkind
(Spec
) = N_Function_Specification
then
10657 Set_Ekind
(Snam
, E_Function
);
10658 Set_Etype
(Snam
, Entity
(Subtype_Mark
(Spec
)));
10660 Set_Ekind
(Snam
, E_Procedure
);
10661 Set_Etype
(Snam
, Standard_Void_Type
);
10664 Set_TSS
(Typ
, Snam
);
10665 end Set_Renaming_TSS
;
10667 --------------------------------
10668 -- Specific_Add_RACW_Features --
10669 --------------------------------
10671 procedure Specific_Add_RACW_Features
10672 (RACW_Type
: Entity_Id
;
10674 Stub_Type
: Entity_Id
;
10675 Stub_Type_Access
: Entity_Id
;
10676 RPC_Receiver_Decl
: Node_Id
;
10677 Declarations
: List_Id
)
10680 case Get_PCS_Name
is
10681 when Name_PolyORB_DSA
=>
10682 PolyORB_Support
.Add_RACW_Features
(
10691 GARLIC_Support
.Add_RACW_Features
(
10698 end Specific_Add_RACW_Features
;
10700 --------------------------------
10701 -- Specific_Add_RAST_Features --
10702 --------------------------------
10704 procedure Specific_Add_RAST_Features
10705 (Vis_Decl
: Node_Id
;
10706 RAS_Type
: Entity_Id
;
10710 case Get_PCS_Name
is
10711 when Name_PolyORB_DSA
=>
10712 PolyORB_Support
.Add_RAST_Features
(
10713 Vis_Decl
, RAS_Type
, Decls
);
10715 GARLIC_Support
.Add_RAST_Features
(
10716 Vis_Decl
, RAS_Type
, Decls
);
10718 end Specific_Add_RAST_Features
;
10720 --------------------------------------------------
10721 -- Specific_Add_Receiving_Stubs_To_Declarations --
10722 --------------------------------------------------
10724 procedure Specific_Add_Receiving_Stubs_To_Declarations
10725 (Pkg_Spec
: Node_Id
;
10729 case Get_PCS_Name
is
10730 when Name_PolyORB_DSA
=>
10731 PolyORB_Support
.Add_Receiving_Stubs_To_Declarations
(
10734 GARLIC_Support
.Add_Receiving_Stubs_To_Declarations
(
10737 end Specific_Add_Receiving_Stubs_To_Declarations
;
10739 ------------------------------------------
10740 -- Specific_Build_General_Calling_Stubs --
10741 ------------------------------------------
10743 procedure Specific_Build_General_Calling_Stubs
10745 Statements
: List_Id
;
10746 Target
: RPC_Target
;
10747 Subprogram_Id
: Node_Id
;
10748 Asynchronous
: Node_Id
:= Empty
;
10749 Is_Known_Asynchronous
: Boolean := False;
10750 Is_Known_Non_Asynchronous
: Boolean := False;
10751 Is_Function
: Boolean;
10753 Stub_Type
: Entity_Id
:= Empty
;
10754 RACW_Type
: Entity_Id
:= Empty
;
10758 case Get_PCS_Name
is
10759 when Name_PolyORB_DSA
=>
10760 PolyORB_Support
.Build_General_Calling_Stubs
(
10766 Is_Known_Asynchronous
,
10767 Is_Known_Non_Asynchronous
,
10774 GARLIC_Support
.Build_General_Calling_Stubs
(
10778 Target
.RPC_Receiver
,
10781 Is_Known_Asynchronous
,
10782 Is_Known_Non_Asynchronous
,
10789 end Specific_Build_General_Calling_Stubs
;
10791 --------------------------------------
10792 -- Specific_Build_RPC_Receiver_Body --
10793 --------------------------------------
10795 procedure Specific_Build_RPC_Receiver_Body
10796 (RPC_Receiver
: Entity_Id
;
10797 Request
: out Entity_Id
;
10798 Subp_Id
: out Entity_Id
;
10799 Subp_Index
: out Entity_Id
;
10800 Stmts
: out List_Id
;
10801 Decl
: out Node_Id
)
10804 case Get_PCS_Name
is
10805 when Name_PolyORB_DSA
=>
10806 PolyORB_Support
.Build_RPC_Receiver_Body
10814 GARLIC_Support
.Build_RPC_Receiver_Body
10822 end Specific_Build_RPC_Receiver_Body
;
10824 --------------------------------
10825 -- Specific_Build_Stub_Target --
10826 --------------------------------
10828 function Specific_Build_Stub_Target
10831 RCI_Locator
: Entity_Id
;
10832 Controlling_Parameter
: Entity_Id
) return RPC_Target
is
10834 case Get_PCS_Name
is
10835 when Name_PolyORB_DSA
=>
10836 return PolyORB_Support
.Build_Stub_Target
(Loc
,
10837 Decls
, RCI_Locator
, Controlling_Parameter
);
10839 return GARLIC_Support
.Build_Stub_Target
(Loc
,
10840 Decls
, RCI_Locator
, Controlling_Parameter
);
10842 end Specific_Build_Stub_Target
;
10844 ------------------------------
10845 -- Specific_Build_Stub_Type --
10846 ------------------------------
10848 procedure Specific_Build_Stub_Type
10849 (RACW_Type
: Entity_Id
;
10850 Stub_Type
: Entity_Id
;
10851 Stub_Type_Decl
: out Node_Id
;
10852 RPC_Receiver_Decl
: out Node_Id
)
10855 case Get_PCS_Name
is
10856 when Name_PolyORB_DSA
=>
10857 PolyORB_Support
.Build_Stub_Type
(
10858 RACW_Type
, Stub_Type
,
10859 Stub_Type_Decl
, RPC_Receiver_Decl
);
10861 GARLIC_Support
.Build_Stub_Type
(
10862 RACW_Type
, Stub_Type
,
10863 Stub_Type_Decl
, RPC_Receiver_Decl
);
10865 end Specific_Build_Stub_Type
;
10867 function Specific_Build_Subprogram_Receiving_Stubs
10868 (Vis_Decl
: Node_Id
;
10869 Asynchronous
: Boolean;
10870 Dynamically_Asynchronous
: Boolean := False;
10871 Stub_Type
: Entity_Id
:= Empty
;
10872 RACW_Type
: Entity_Id
:= Empty
;
10873 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
is
10875 case Get_PCS_Name
is
10876 when Name_PolyORB_DSA
=>
10877 return PolyORB_Support
.Build_Subprogram_Receiving_Stubs
(
10880 Dynamically_Asynchronous
,
10885 return GARLIC_Support
.Build_Subprogram_Receiving_Stubs
(
10888 Dynamically_Asynchronous
,
10893 end Specific_Build_Subprogram_Receiving_Stubs
;
10895 --------------------------
10896 -- Underlying_RACW_Type --
10897 --------------------------
10899 function Underlying_RACW_Type
(RAS_Typ
: Entity_Id
) return Entity_Id
is
10900 Record_Type
: Entity_Id
;
10903 if Ekind
(RAS_Typ
) = E_Record_Type
then
10904 Record_Type
:= RAS_Typ
;
10906 pragma Assert
(Present
(Equivalent_Type
(RAS_Typ
)));
10907 Record_Type
:= Equivalent_Type
(RAS_Typ
);
10911 Etype
(Subtype_Indication
(
10912 Component_Definition
(
10913 First
(Component_Items
(Component_List
(
10914 Type_Definition
(Declaration_Node
(Record_Type
))))))));
10915 end Underlying_RACW_Type
;