1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Einfo
; use Einfo
;
28 with Elists
; use Elists
;
29 with Exp_Atag
; use Exp_Atag
;
30 with Exp_Disp
; use Exp_Disp
;
31 with Exp_Strm
; use Exp_Strm
;
32 with Exp_Tss
; use Exp_Tss
;
33 with Exp_Util
; use Exp_Util
;
35 with Nlists
; use Nlists
;
36 with Nmake
; use Nmake
;
38 with Rtsfind
; use Rtsfind
;
40 with Sem_Aux
; use Sem_Aux
;
41 with Sem_Cat
; use Sem_Cat
;
42 with Sem_Ch3
; use Sem_Ch3
;
43 with Sem_Ch8
; use Sem_Ch8
;
44 with Sem_Dist
; use Sem_Dist
;
45 with Sem_Eval
; use Sem_Eval
;
46 with Sem_Util
; use Sem_Util
;
47 with Sinfo
; use Sinfo
;
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 with GNAT
.HTable
; use GNAT
.HTable
;
56 package body Exp_Dist
is
58 -- The following model has been used to implement distributed objects:
59 -- given a designated type D and a RACW type R, then a record of the form:
61 -- type Stub is tagged record
62 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
65 -- is built. This type has two properties:
67 -- 1) Since it has the same structure as RACW_Stub_Type, it can
68 -- be converted to and from this type to make it suitable for
69 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
70 -- to avoid memory leaks when the same remote object arrives on the
71 -- same partition through several paths;
73 -- 2) It also has the same dispatching table as the designated type D,
74 -- and thus can be used as an object designated by a value of type
75 -- R on any partition other than the one on which the object has
76 -- been created, since only dispatching calls will be performed and
77 -- the fields themselves will not be used. We call Derive_Subprograms
78 -- to fake half a derivation to ensure that the subprograms do have
79 -- the same dispatching table.
81 First_RCI_Subprogram_Id
: constant := 2;
82 -- RCI subprograms are numbered starting at 2. The RCI receiver for
83 -- an RCI package can thus identify calls received through remote
84 -- access-to-subprogram dereferences by the fact that they have a
85 -- (primitive) subprogram id of 0, and 1 is used for the internal RAS
86 -- information lookup operation. (This is for the Garlic code generation,
87 -- where subprograms are identified by numbers; in the PolyORB version,
88 -- they are identified by name, with a numeric suffix for homonyms.)
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 a hash
98 -- 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 name. These counters are
103 -- 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 subprogram
120 package Overload_Counter_Table
is
121 new Simple_HTable
(Header_Num
=> Hash_Index
,
127 -- Mapping between a subprogram name and an integer that counts the number
128 -- of defining subprogram names with that Name_Id encountered so far in a
129 -- given context (an interface).
131 function Get_Subprogram_Ids
(Def
: Entity_Id
) return Subprogram_Identifiers
;
132 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
;
133 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
;
134 -- Given a subprogram defined in a RCI package, get its distribution
135 -- subprogram identifiers (the distribution identifiers are a unique
136 -- subprogram number, and the non-qualified subprogram name, in the
137 -- casing used for the subprogram declaration; if the name is overloaded,
138 -- a double underscore and a serial number are appended.
140 -- The integer identifier is used to perform remote calls with GARLIC;
141 -- the string identifier is used in the case of PolyORB.
143 -- Although the PolyORB DSA receiving stubs will make a caseless comparison
144 -- when receiving a call, the calling stubs will create requests with the
145 -- exact casing of the defining unit name of the called subprogram, so as
146 -- to allow calls to subprograms on distributed nodes that do distinguish
149 -- NOTE: Another design would be to allow a representation clause on
150 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
152 pragma Warnings
(Off
, Get_Subprogram_Id
);
153 -- One homonym only is unreferenced (specific to the GARLIC version)
155 procedure Add_RAS_Dereference_TSS
(N
: Node_Id
);
156 -- Add a subprogram body for RAS Dereference TSS
158 procedure Add_RAS_Proxy_And_Analyze
161 All_Calls_Remote_E
: Entity_Id
;
162 Proxy_Object_Addr
: out Entity_Id
);
163 -- Add the proxy type required, on the receiving (server) side, to handle
164 -- calls to the subprogram declared by Vis_Decl through a remote access
165 -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma
166 -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type
167 -- is appended to Decls. Proxy_Object_Addr is a constant of type
168 -- System.Address that designates an instance of the proxy object.
170 function Build_Remote_Subprogram_Proxy_Type
172 ACR_Expression
: Node_Id
) return Node_Id
;
173 -- Build and return a tagged record type definition for an RCI subprogram
174 -- proxy type. ACR_Expression is used as the initialization value for the
175 -- All_Calls_Remote component.
177 function Build_Get_Unique_RP_Call
180 Stub_Type
: Entity_Id
) return List_Id
;
181 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
182 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
183 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
185 function Build_Stub_Tag
187 RACW_Type
: Entity_Id
) return Node_Id
;
188 -- Return an expression denoting the tag of the stub type associated with
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 itself.
203 -- It will then be converted into Stub_Type before performing the real
204 -- call. If Dynamically_Asynchronous is True, then it will be computed at
205 -- run time whether the call is asynchronous or not. Otherwise, the value
206 -- of the formal Asynchronous will be used. If Locator is not Empty, it
207 -- will be used instead of RCI_Cache. If New_Name is given, then it will
208 -- 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 function Transmit_As_Unconstrained
(Typ
: Entity_Id
) return Boolean;
224 -- True when Typ is an unconstrained type, or a null-excluding access type.
225 -- In either case, this means stubs cannot contain a default-initialized
226 -- object declaration of such type.
228 procedure Add_Calling_Stubs_To_Declarations
231 -- Add calling stubs to the declarative part
233 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean;
234 -- Return True if nothing prevents the program whose specification is
235 -- given to be asynchronous (i.e. no [IN] OUT parameters).
237 function Pack_Entity_Into_Stream_Access
241 Etyp
: Entity_Id
:= Empty
) return Node_Id
;
242 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
243 -- then Etype (Object) will be used if present. If the type is
244 -- constrained, then 'Write will be used to output the object,
245 -- If the type is unconstrained, 'Output will be used.
247 function Pack_Node_Into_Stream
251 Etyp
: Entity_Id
) return Node_Id
;
252 -- Similar to above, with an arbitrary node instead of an entity
254 function Pack_Node_Into_Stream_Access
258 Etyp
: Entity_Id
) return Node_Id
;
259 -- Similar to above, with Stream instead of Stream'Access
261 function Make_Selected_Component
264 Selector_Name
: Name_Id
) return Node_Id
;
265 -- Return a selected_component whose prefix denotes the given entity, and
266 -- with the given Selector_Name.
268 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
;
269 -- Return the scope represented by a given spec
271 procedure Set_Renaming_TSS
274 TSS_Nam
: TSS_Name_Type
);
275 -- Create a renaming declaration of subprogram Nam, and register it as a
276 -- TSS for Typ with name TSS_Nam.
278 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean;
279 -- Return True if the current parameter needs an extra formal to reflect
280 -- its constrained status.
282 function Is_RACW_Controlling_Formal
283 (Parameter
: Node_Id
;
284 Stub_Type
: Entity_Id
) return Boolean;
285 -- Return True if the current parameter is a controlling formal argument
286 -- of type Stub_Type or access to Stub_Type.
288 procedure Declare_Create_NVList
293 -- Append the declaration of NVList to Decls, and its
294 -- initialization to Stmts.
296 function Add_Parameter_To_NVList
299 Parameter
: Entity_Id
;
300 Constrained
: Boolean;
301 RACW_Ctrl
: Boolean := False;
302 Any
: Entity_Id
) return Node_Id
;
303 -- Return a call to Add_Item to add the Any corresponding to the designated
304 -- formal Parameter (with the indicated Constrained status) to NVList.
305 -- RACW_Ctrl must be set to True for controlling formals of distributed
306 -- object primitive operations.
312 -- This record describes various tree fragments associated with the
313 -- generation of RACW calling stubs. One such record exists for every
314 -- distributed object type, i.e. each tagged type that is the designated
315 -- type of one or more RACW type.
317 type Stub_Structure
is record
318 Stub_Type
: Entity_Id
;
319 -- Stub type: this type has the same primitive operations as the
320 -- designated types, but the provided bodies for these operations
321 -- a remote call to an actual target object potentially located on
322 -- another partition; each value of the stub type encapsulates a
323 -- reference to a remote object.
325 Stub_Type_Access
: Entity_Id
;
326 -- A local access type designating the stub type (this is not an RACW
329 RPC_Receiver_Decl
: Node_Id
;
330 -- Declaration for the RPC receiver entity associated with the
331 -- designated type. As an exception, for the case of an RACW that
332 -- implements a RAS, no object RPC receiver is generated. Instead,
333 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
334 -- would have been inserted.
336 Body_Decls
: List_Id
;
337 -- List of subprogram bodies to be included in generated code: bodies
338 -- for the RACW's stream attributes, and for the primitive operations
341 RACW_Type
: Entity_Id
;
342 -- One of the RACW types designating this distributed object type
343 -- (they are all interchangeable; we use any one of them in order to
344 -- avoid having to create various anonymous access types).
348 Empty_Stub_Structure
: constant Stub_Structure
:=
349 (Empty
, Empty
, Empty
, No_List
, Empty
);
351 package Stubs_Table
is
352 new Simple_HTable
(Header_Num
=> Hash_Index
,
353 Element
=> Stub_Structure
,
354 No_Element
=> Empty_Stub_Structure
,
358 -- Mapping between a RACW designated type and its stub type
360 package Asynchronous_Flags_Table
is
361 new Simple_HTable
(Header_Num
=> Hash_Index
,
362 Element
=> Entity_Id
,
367 -- Mapping between a RACW type and a constant having the value True
368 -- if the RACW is asynchronous and False otherwise.
370 package RCI_Locator_Table
is
371 new Simple_HTable
(Header_Num
=> Hash_Index
,
372 Element
=> Entity_Id
,
377 -- Mapping between a RCI package on which All_Calls_Remote applies and
378 -- the generic instantiation of RCI_Locator for this package.
380 package RCI_Calling_Stubs_Table
is
381 new Simple_HTable
(Header_Num
=> Hash_Index
,
382 Element
=> Entity_Id
,
387 -- Mapping between a RCI subprogram and the corresponding calling stubs
389 function Get_Stub_Elements
(RACW_Type
: Entity_Id
) return Stub_Structure
;
390 -- Return the stub information associated with the given RACW type
392 procedure Add_Stub_Type
393 (Designated_Type
: Entity_Id
;
394 RACW_Type
: Entity_Id
;
396 Stub_Type
: out Entity_Id
;
397 Stub_Type_Access
: out Entity_Id
;
398 RPC_Receiver_Decl
: out Node_Id
;
399 Body_Decls
: out List_Id
;
400 Existing
: out Boolean);
401 -- Add the declaration of the stub type, the access to stub type and the
402 -- object RPC receiver at the end of Decls. If these already exist,
403 -- then nothing is added in the tree but the right values are returned
404 -- anyhow and Existing is set to True.
406 function Get_And_Reset_RACW_Bodies
(RACW_Type
: Entity_Id
) return List_Id
;
407 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
408 -- structure table, reset it to No_List, and return the previous value.
410 procedure Add_RACW_Asynchronous_Flag
411 (Declarations
: List_Id
;
412 RACW_Type
: Entity_Id
);
413 -- Declare a boolean constant associated with RACW_Type whose value
414 -- indicates at run time whether a pragma Asynchronous applies to it.
416 procedure Assign_Subprogram_Identifier
420 -- Determine the distribution subprogram identifier to
421 -- be used for remote subprogram Def, return it in Id and
422 -- store it in a hash table for later retrieval by
423 -- Get_Subprogram_Id. Spn is the subprogram number.
425 function RCI_Package_Locator
427 Package_Spec
: Node_Id
) return Node_Id
;
428 -- Instantiate the generic package RCI_Locator in order to locate the
429 -- RCI package whose spec is given as argument.
431 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
;
432 -- Surround a node N by a tag check, as in:
436 -- when E : Ada.Tags.Tag_Error =>
437 -- Raise_Exception (Program_Error'Identity,
438 -- Exception_Message (E));
441 function Input_With_Tag_Check
443 Var_Type
: Entity_Id
;
444 Stream
: Node_Id
) return Node_Id
;
445 -- Return a function with the following form:
446 -- function R return Var_Type is
448 -- return Var_Type'Input (S);
450 -- when E : Ada.Tags.Tag_Error =>
451 -- Raise_Exception (Program_Error'Identity,
452 -- Exception_Message (E));
455 procedure Build_Actual_Object_Declaration
461 -- Build the declaration of an object with the given defining identifier,
462 -- initialized with Expr if provided, to serve as actual parameter in a
463 -- server stub. If Variable is true, the declared object will be a variable
464 -- (case of an out or in out formal), else it will be a constant. Object's
465 -- Ekind is set accordingly. The declaration, as well as any other
466 -- declarations it requires, are appended to Decls.
468 --------------------------------------------
469 -- Hooks for PCS-specific code generation --
470 --------------------------------------------
472 -- Part of the code generation circuitry for distribution needs to be
473 -- tailored for each implementation of the PCS. For each routine that
474 -- needs to be specialized, a Specific_<routine> wrapper is created,
475 -- which calls the corresponding <routine> in package
476 -- <pcs_implementation>_Support.
478 procedure Specific_Add_RACW_Features
479 (RACW_Type
: Entity_Id
;
481 Stub_Type
: Entity_Id
;
482 Stub_Type_Access
: Entity_Id
;
483 RPC_Receiver_Decl
: Node_Id
;
484 Body_Decls
: List_Id
);
485 -- Add declaration for TSSs for a given RACW type. The declarations are
486 -- added just after the declaration of the RACW type itself. If the RACW
487 -- appears in the main unit, Body_Decls is a list of declarations to which
488 -- the bodies are appended. Else Body_Decls is No_List.
489 -- PCS-specific ancillary subprogram for Add_RACW_Features.
491 procedure Specific_Add_RAST_Features
493 RAS_Type
: Entity_Id
);
494 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
495 -- subprogram for Add_RAST_Features.
497 -- An RPC_Target record is used during construction of calling stubs
498 -- to pass PCS-specific tree fragments corresponding to the information
499 -- necessary to locate the target of a remote subprogram call.
501 type RPC_Target
(PCS_Kind
: PCS_Names
) is record
503 when Name_PolyORB_DSA
=>
505 -- An expression whose value is a PolyORB reference to the target
509 Partition
: Entity_Id
;
510 -- A variable containing the Partition_ID of the target partition
512 RPC_Receiver
: Node_Id
;
513 -- An expression whose value is the address of the target RPC
518 procedure Specific_Build_General_Calling_Stubs
520 Statements
: List_Id
;
522 Subprogram_Id
: Node_Id
;
523 Asynchronous
: Node_Id
:= Empty
;
524 Is_Known_Asynchronous
: Boolean := False;
525 Is_Known_Non_Asynchronous
: Boolean := False;
526 Is_Function
: Boolean;
528 Stub_Type
: Entity_Id
:= Empty
;
529 RACW_Type
: Entity_Id
:= Empty
;
531 -- Build calling stubs for general purpose. The parameters are:
532 -- Decls : a place to put declarations
533 -- Statements : a place to put statements
534 -- Target : PCS-specific target information (see details
535 -- in RPC_Target declaration).
536 -- Subprogram_Id : a node containing the subprogram ID
537 -- Asynchronous : True if an APC must be made instead of an RPC.
538 -- The value needs not be supplied if one of the
539 -- Is_Known_... is True.
540 -- Is_Known_Async... : True if we know that this is asynchronous
541 -- Is_Known_Non_A... : True if we know that this is not asynchronous
542 -- Spec : a node with a Parameter_Specifications and
543 -- a Result_Definition if applicable
544 -- Stub_Type : in case of RACW stubs, parameters of type access
545 -- to Stub_Type will be marshalled using the
546 -- address of the object (the addr field) rather
547 -- than using the 'Write on the stub itself
548 -- Nod : used to provide sloc for generated code
550 function Specific_Build_Stub_Target
553 RCI_Locator
: Entity_Id
;
554 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
555 -- Build call target information nodes for use within calling stubs. In the
556 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
557 -- for an RACW, Controlling_Parameter is the entity for the controlling
558 -- formal parameter used to determine the location of the target of the
559 -- call. Decls provides a location where variable declarations can be
560 -- appended to construct the necessary values.
562 procedure Specific_Build_Stub_Type
563 (RACW_Type
: Entity_Id
;
564 Stub_Type_Comps
: out List_Id
;
565 RPC_Receiver_Decl
: out Node_Id
);
566 -- Build a components list for the stub type associated with an RACW type,
567 -- and build the necessary RPC receiver, if applicable. PCS-specific
568 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
569 -- is generated, then RPC_Receiver_Decl is set to Empty.
571 procedure Specific_Build_RPC_Receiver_Body
572 (RPC_Receiver
: Entity_Id
;
573 Request
: out Entity_Id
;
574 Subp_Id
: out Entity_Id
;
575 Subp_Index
: out Entity_Id
;
578 -- Make a subprogram body for an RPC receiver, with the given
579 -- defining unit name. On return:
580 -- - Subp_Id is the subprogram identifier from the PCS.
581 -- - Subp_Index is the index in the list of subprograms
582 -- used for dispatching (a variable of type Subprogram_Id).
583 -- - Stmts is the place where the request dispatching
584 -- statements can occur,
585 -- - Decl is the subprogram body declaration.
587 function Specific_Build_Subprogram_Receiving_Stubs
589 Asynchronous
: Boolean;
590 Dynamically_Asynchronous
: Boolean := False;
591 Stub_Type
: Entity_Id
:= Empty
;
592 RACW_Type
: Entity_Id
:= Empty
;
593 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
594 -- Build the receiving stub for a given subprogram. The subprogram
595 -- declaration is also built by this procedure, and the value returned
596 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
597 -- found in the specification, then its address is read from the stream
598 -- instead of the object itself and converted into an access to
599 -- class-wide type before doing the real call using any of the RACW type
600 -- pointing on the designated type.
602 procedure Specific_Add_Obj_RPC_Receiver_Completion
605 RPC_Receiver
: Entity_Id
;
606 Stub_Elements
: Stub_Structure
);
607 -- Add the necessary code to Decls after the completion of generation
608 -- of the RACW RPC receiver described by Stub_Elements.
610 procedure Specific_Add_Receiving_Stubs_To_Declarations
614 -- Add receiving stubs to the declarative part of an RCI unit
620 package GARLIC_Support
is
622 -- Support for generating DSA code that uses the GARLIC PCS
624 -- The subprograms below provide the GARLIC versions of the
625 -- corresponding Specific_<subprogram> routine declared above.
627 procedure Add_RACW_Features
628 (RACW_Type
: Entity_Id
;
629 Stub_Type
: Entity_Id
;
630 Stub_Type_Access
: Entity_Id
;
631 RPC_Receiver_Decl
: Node_Id
;
632 Body_Decls
: List_Id
);
634 procedure Add_RAST_Features
636 RAS_Type
: Entity_Id
);
638 procedure Build_General_Calling_Stubs
640 Statements
: List_Id
;
641 Target_Partition
: Entity_Id
; -- From RPC_Target
642 Target_RPC_Receiver
: Node_Id
; -- From RPC_Target
643 Subprogram_Id
: Node_Id
;
644 Asynchronous
: Node_Id
:= Empty
;
645 Is_Known_Asynchronous
: Boolean := False;
646 Is_Known_Non_Asynchronous
: Boolean := False;
647 Is_Function
: Boolean;
649 Stub_Type
: Entity_Id
:= Empty
;
650 RACW_Type
: Entity_Id
:= Empty
;
653 function Build_Stub_Target
656 RCI_Locator
: Entity_Id
;
657 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
659 procedure Build_Stub_Type
660 (RACW_Type
: Entity_Id
;
661 Stub_Type_Comps
: out List_Id
;
662 RPC_Receiver_Decl
: out Node_Id
);
664 function Build_Subprogram_Receiving_Stubs
666 Asynchronous
: Boolean;
667 Dynamically_Asynchronous
: Boolean := False;
668 Stub_Type
: Entity_Id
:= Empty
;
669 RACW_Type
: Entity_Id
:= Empty
;
670 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
672 procedure Add_Obj_RPC_Receiver_Completion
675 RPC_Receiver
: Entity_Id
;
676 Stub_Elements
: Stub_Structure
);
678 procedure Add_Receiving_Stubs_To_Declarations
683 procedure Build_RPC_Receiver_Body
684 (RPC_Receiver
: Entity_Id
;
685 Request
: out Entity_Id
;
686 Subp_Id
: out Entity_Id
;
687 Subp_Index
: out Entity_Id
;
693 ---------------------
694 -- PolyORB_Support --
695 ---------------------
697 package PolyORB_Support
is
699 -- Support for generating DSA code that uses the PolyORB PCS
701 -- The subprograms below provide the PolyORB versions of the
702 -- corresponding Specific_<subprogram> routine declared above.
704 procedure Add_RACW_Features
705 (RACW_Type
: Entity_Id
;
707 Stub_Type
: Entity_Id
;
708 Stub_Type_Access
: Entity_Id
;
709 RPC_Receiver_Decl
: Node_Id
;
710 Body_Decls
: List_Id
);
712 procedure Add_RAST_Features
714 RAS_Type
: Entity_Id
);
716 procedure Build_General_Calling_Stubs
718 Statements
: List_Id
;
719 Target_Object
: Node_Id
; -- From RPC_Target
720 Subprogram_Id
: Node_Id
;
721 Asynchronous
: Node_Id
:= Empty
;
722 Is_Known_Asynchronous
: Boolean := False;
723 Is_Known_Non_Asynchronous
: Boolean := False;
724 Is_Function
: Boolean;
726 Stub_Type
: Entity_Id
:= Empty
;
727 RACW_Type
: Entity_Id
:= Empty
;
730 function Build_Stub_Target
733 RCI_Locator
: Entity_Id
;
734 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
736 procedure Build_Stub_Type
737 (RACW_Type
: Entity_Id
;
738 Stub_Type_Comps
: out List_Id
;
739 RPC_Receiver_Decl
: out Node_Id
);
741 function Build_Subprogram_Receiving_Stubs
743 Asynchronous
: Boolean;
744 Dynamically_Asynchronous
: Boolean := False;
745 Stub_Type
: Entity_Id
:= Empty
;
746 RACW_Type
: Entity_Id
:= Empty
;
747 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
749 procedure Add_Obj_RPC_Receiver_Completion
752 RPC_Receiver
: Entity_Id
;
753 Stub_Elements
: Stub_Structure
);
755 procedure Add_Receiving_Stubs_To_Declarations
760 procedure Build_RPC_Receiver_Body
761 (RPC_Receiver
: Entity_Id
;
762 Request
: out Entity_Id
;
763 Subp_Id
: out Entity_Id
;
764 Subp_Index
: out Entity_Id
;
768 procedure Reserve_NamingContext_Methods
;
769 -- Mark the method names for interface NamingContext as already used in
770 -- the overload table, so no clashes occur with user code (with the
771 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
772 -- their methods to be accessed as objects, for the implementation of
773 -- remote access-to-subprogram types).
781 -- Routines to build distribution helper subprograms for user-defined
782 -- types. For implementation of the Distributed systems annex (DSA)
783 -- over the PolyORB generic middleware components, it is necessary to
784 -- generate several supporting subprograms for each application data
785 -- type used in inter-partition communication. These subprograms are:
787 -- A Typecode function returning a high-level description of the
790 -- Two conversion functions allowing conversion of values of the
791 -- type from and to the generic data containers used by PolyORB.
792 -- These generic containers are called 'Any' type values after the
793 -- CORBA terminology, and hence the conversion subprograms are
794 -- named To_Any and From_Any.
796 function Build_From_Any_Call
799 Decls
: List_Id
) return Node_Id
;
800 -- Build call to From_Any attribute function of type Typ with
801 -- expression N as actual parameter. Decls is the declarations list
802 -- for an appropriate enclosing scope of the point where the call
803 -- will be inserted; if the From_Any attribute for Typ needs to be
804 -- generated at this point, its declaration is appended to Decls.
806 procedure Build_From_Any_Function
810 Fnam
: out Entity_Id
);
811 -- Build From_Any attribute function for Typ. Loc is the reference
812 -- location for generated nodes, Typ is the type for which the
813 -- conversion function is generated. On return, Decl and Fnam contain
814 -- the declaration and entity for the newly-created function.
816 function Build_To_Any_Call
818 Decls
: List_Id
) return Node_Id
;
819 -- Build call to To_Any attribute function with expression as actual
820 -- parameter. Decls is the declarations list for an appropriate
821 -- enclosing scope of the point where the call will be inserted; if
822 -- the To_Any attribute for Typ needs to be generated at this point,
823 -- its declaration is appended to Decls.
825 procedure Build_To_Any_Function
829 Fnam
: out Entity_Id
);
830 -- Build To_Any attribute function for Typ. Loc is the reference
831 -- location for generated nodes, Typ is the type for which the
832 -- conversion function is generated. On return, Decl and Fnam contain
833 -- the declaration and entity for the newly-created function.
835 function Build_TypeCode_Call
838 Decls
: List_Id
) return Node_Id
;
839 -- Build call to TypeCode attribute function for Typ. Decls is the
840 -- declarations list for an appropriate enclosing scope of the point
841 -- where the call will be inserted; if the To_Any attribute for Typ
842 -- needs to be generated at this point, its declaration is appended
845 procedure Build_TypeCode_Function
849 Fnam
: out Entity_Id
);
850 -- Build TypeCode attribute function for Typ. Loc is the reference
851 -- location for generated nodes, Typ is the type for which the
852 -- conversion function is generated. On return, Decl and Fnam contain
853 -- the declaration and entity for the newly-created function.
855 procedure Build_Name_And_Repository_Id
857 Name_Str
: out String_Id
;
858 Repo_Id_Str
: out String_Id
);
859 -- In the PolyORB distribution model, each distributed object type
860 -- and each distributed operation has a globally unique identifier,
861 -- its Repository Id. This subprogram builds and returns two strings
862 -- for entity E (a distributed object type or operation): one
863 -- containing the name of E, the second containing its repository id.
865 procedure Assign_Opaque_From_Any
871 -- For a Target object of type Typ, which has opaque representation
872 -- as a sequence of octets determined by stream attributes (which
873 -- includes all limited types), append code to Stmts performing the
875 -- Target := Typ'From_Any (N)
877 -- or, if Target is Empty:
878 -- return Typ'From_Any (N)
884 -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
886 function Build_From_Any_Call
889 Decls
: List_Id
) return Node_Id
890 renames PolyORB_Support
.Helpers
.Build_From_Any_Call
;
892 function Build_To_Any_Call
894 Decls
: List_Id
) return Node_Id
895 renames PolyORB_Support
.Helpers
.Build_To_Any_Call
;
897 function Build_TypeCode_Call
900 Decls
: List_Id
) return Node_Id
901 renames PolyORB_Support
.Helpers
.Build_TypeCode_Call
;
903 ------------------------------------
904 -- Local variables and structures --
905 ------------------------------------
908 -- Needs comments ???
910 Output_From_Constrained
: constant array (Boolean) of Name_Id
:=
911 (False => Name_Output
,
913 -- The attribute to choose depending on the fact that the parameter
914 -- is constrained or not. There is no such thing as Input_From_Constrained
915 -- since this require separate mechanisms ('Input is a function while
916 -- 'Read is a procedure).
918 ---------------------------------------
919 -- Add_Calling_Stubs_To_Declarations --
920 ---------------------------------------
922 procedure Add_Calling_Stubs_To_Declarations
926 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
927 -- Subprogram id 0 is reserved for calls received from
928 -- remote access-to-subprogram dereferences.
930 Current_Declaration
: Node_Id
;
931 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
932 RCI_Instantiation
: Node_Id
;
933 Subp_Stubs
: Node_Id
;
934 Subp_Str
: String_Id
;
936 pragma Warnings
(Off
, Subp_Str
);
939 -- The first thing added is an instantiation of the generic package
940 -- System.Partition_Interface.RCI_Locator with the name of this remote
941 -- package. This will act as an interface with the name server to
942 -- determine the Partition_ID and the RPC_Receiver for the receiver
945 RCI_Instantiation
:= RCI_Package_Locator
(Loc
, Pkg_Spec
);
946 RCI_Cache
:= Defining_Unit_Name
(RCI_Instantiation
);
948 Append_To
(Decls
, RCI_Instantiation
);
949 Analyze
(RCI_Instantiation
);
951 -- For each subprogram declaration visible in the spec, we do build a
952 -- body. We also increment a counter to assign a different Subprogram_Id
953 -- to each subprograms. The receiving stubs processing do use the same
954 -- mechanism and will thus assign the same Id and do the correct
957 Overload_Counter_Table
.Reset
;
958 PolyORB_Support
.Reserve_NamingContext_Methods
;
960 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
961 while Present
(Current_Declaration
) loop
962 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
963 and then Comes_From_Source
(Current_Declaration
)
965 Assign_Subprogram_Identifier
966 (Defining_Unit_Name
(Specification
(Current_Declaration
)),
967 Current_Subprogram_Number
,
971 Build_Subprogram_Calling_Stubs
(
972 Vis_Decl
=> Current_Declaration
,
974 Build_Subprogram_Id
(Loc
,
975 Defining_Unit_Name
(Specification
(Current_Declaration
))),
977 Nkind
(Specification
(Current_Declaration
)) =
978 N_Procedure_Specification
980 Is_Asynchronous
(Defining_Unit_Name
(Specification
981 (Current_Declaration
))));
983 Append_To
(Decls
, Subp_Stubs
);
984 Analyze
(Subp_Stubs
);
986 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
989 Next
(Current_Declaration
);
991 end Add_Calling_Stubs_To_Declarations
;
993 -----------------------------
994 -- Add_Parameter_To_NVList --
995 -----------------------------
997 function Add_Parameter_To_NVList
1000 Parameter
: Entity_Id
;
1001 Constrained
: Boolean;
1002 RACW_Ctrl
: Boolean := False;
1003 Any
: Entity_Id
) return Node_Id
1005 Parameter_Name_String
: String_Id
;
1006 Parameter_Mode
: Node_Id
;
1008 function Parameter_Passing_Mode
1010 Parameter
: Entity_Id
;
1011 Constrained
: Boolean) return Node_Id
;
1012 -- Return an expression that denotes the parameter passing mode to be
1013 -- used for Parameter in distribution stubs, where Constrained is
1014 -- Parameter's constrained status.
1016 ----------------------------
1017 -- Parameter_Passing_Mode --
1018 ----------------------------
1020 function Parameter_Passing_Mode
1022 Parameter
: Entity_Id
;
1023 Constrained
: Boolean) return Node_Id
1028 if Out_Present
(Parameter
) then
1029 if In_Present
(Parameter
)
1030 or else not Constrained
1032 -- Unconstrained formals must be translated
1033 -- to 'in' or 'inout', not 'out', because
1034 -- they need to be constrained by the actual.
1036 Lib_RE
:= RE_Mode_Inout
;
1038 Lib_RE
:= RE_Mode_Out
;
1042 Lib_RE
:= RE_Mode_In
;
1045 return New_Occurrence_Of
(RTE
(Lib_RE
), Loc
);
1046 end Parameter_Passing_Mode
;
1048 -- Start of processing for Add_Parameter_To_NVList
1051 if Nkind
(Parameter
) = N_Defining_Identifier
then
1052 Get_Name_String
(Chars
(Parameter
));
1054 Get_Name_String
(Chars
(Defining_Identifier
(Parameter
)));
1057 Parameter_Name_String
:= String_From_Name_Buffer
;
1059 if RACW_Ctrl
or else Nkind
(Parameter
) = N_Defining_Identifier
then
1061 -- When the parameter passed to Add_Parameter_To_NVList is an
1062 -- Extra_Constrained parameter, Parameter is an N_Defining_
1063 -- Identifier, instead of a complete N_Parameter_Specification.
1064 -- Thus, we explicitly set 'in' mode in this case.
1066 Parameter_Mode
:= New_Occurrence_Of
(RTE
(RE_Mode_In
), Loc
);
1070 Parameter_Passing_Mode
(Loc
, Parameter
, Constrained
);
1074 Make_Procedure_Call_Statement
(Loc
,
1077 (RTE
(RE_NVList_Add_Item
), Loc
),
1078 Parameter_Associations
=> New_List
(
1079 New_Occurrence_Of
(NVList
, Loc
),
1080 Make_Function_Call
(Loc
,
1083 (RTE
(RE_To_PolyORB_String
), Loc
),
1084 Parameter_Associations
=> New_List
(
1085 Make_String_Literal
(Loc
,
1086 Strval
=> Parameter_Name_String
))),
1087 New_Occurrence_Of
(Any
, Loc
),
1089 end Add_Parameter_To_NVList
;
1091 --------------------------------
1092 -- Add_RACW_Asynchronous_Flag --
1093 --------------------------------
1095 procedure Add_RACW_Asynchronous_Flag
1096 (Declarations
: List_Id
;
1097 RACW_Type
: Entity_Id
)
1099 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1101 Asynchronous_Flag
: constant Entity_Id
:=
1102 Make_Defining_Identifier
(Loc
,
1103 New_External_Name
(Chars
(RACW_Type
), 'A'));
1106 -- Declare the asynchronous flag. This flag will be changed to True
1107 -- whenever it is known that the RACW type is asynchronous.
1109 Append_To
(Declarations
,
1110 Make_Object_Declaration
(Loc
,
1111 Defining_Identifier
=> Asynchronous_Flag
,
1112 Constant_Present
=> True,
1113 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
1114 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
1116 Asynchronous_Flags_Table
.Set
(RACW_Type
, Asynchronous_Flag
);
1117 end Add_RACW_Asynchronous_Flag
;
1119 -----------------------
1120 -- Add_RACW_Features --
1121 -----------------------
1123 procedure Add_RACW_Features
(RACW_Type
: Entity_Id
) is
1124 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
1125 Same_Scope
: constant Boolean := Scope
(Desig
) = Scope
(RACW_Type
);
1129 Body_Decls
: List_Id
;
1131 Stub_Type
: Entity_Id
;
1132 Stub_Type_Access
: Entity_Id
;
1133 RPC_Receiver_Decl
: Node_Id
;
1136 -- True when appropriate stubs have already been generated (this is the
1137 -- case when another RACW with the same designated type has already been
1138 -- encountered), in which case we reuse the previous stubs rather than
1139 -- generating new ones.
1142 if not Expander_Active
then
1146 -- Mark the current package declaration as containing an RACW, so that
1147 -- the bodies for the calling stubs and the RACW stream subprograms
1148 -- are attached to the tree when the corresponding body is encountered.
1150 Set_Has_RACW
(Current_Scope
);
1152 -- Look for place to declare the RACW stub type and RACW operations
1158 -- Case of declaring the RACW in the same package as its designated
1159 -- type: we know that the designated type is a private type, so we
1160 -- use the private declarations list.
1162 Pkg_Spec
:= Package_Specification_Of_Scope
(Current_Scope
);
1164 if Present
(Private_Declarations
(Pkg_Spec
)) then
1165 Decls
:= Private_Declarations
(Pkg_Spec
);
1167 Decls
:= Visible_Declarations
(Pkg_Spec
);
1171 -- Case of declaring the RACW in another package than its designated
1172 -- type: use the private declarations list if present; otherwise
1173 -- use the visible declarations.
1175 Decls
:= List_Containing
(Declaration_Node
(RACW_Type
));
1179 -- If we were unable to find the declarations, that means that the
1180 -- completion of the type was missing. We can safely return and let the
1181 -- error be caught by the semantic analysis.
1188 (Designated_Type
=> Desig
,
1189 RACW_Type
=> RACW_Type
,
1191 Stub_Type
=> Stub_Type
,
1192 Stub_Type_Access
=> Stub_Type_Access
,
1193 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1194 Body_Decls
=> Body_Decls
,
1195 Existing
=> Existing
);
1197 -- If this RACW is not in the main unit, do not generate primitive or
1200 if not Entity_Is_In_Main_Unit
(RACW_Type
) then
1201 Body_Decls
:= No_List
;
1204 Add_RACW_Asynchronous_Flag
1205 (Declarations
=> Decls
,
1206 RACW_Type
=> RACW_Type
);
1208 Specific_Add_RACW_Features
1209 (RACW_Type
=> RACW_Type
,
1211 Stub_Type
=> Stub_Type
,
1212 Stub_Type_Access
=> Stub_Type_Access
,
1213 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1214 Body_Decls
=> Body_Decls
);
1216 -- If we already have stubs for this designated type, nothing to do
1222 if Is_Frozen
(Desig
) then
1223 Validate_RACW_Primitives
(RACW_Type
);
1224 Add_RACW_Primitive_Declarations_And_Bodies
1225 (Designated_Type
=> Desig
,
1226 Insertion_Node
=> RPC_Receiver_Decl
,
1227 Body_Decls
=> Body_Decls
);
1230 -- Validate_RACW_Primitives requires the list of all primitives of
1231 -- the designated type, so defer processing until Desig is frozen.
1232 -- See Exp_Ch3.Freeze_Type.
1234 Add_Access_Type_To_Process
(E
=> Desig
, A
=> RACW_Type
);
1236 end Add_RACW_Features
;
1238 ------------------------------------------------
1239 -- Add_RACW_Primitive_Declarations_And_Bodies --
1240 ------------------------------------------------
1242 procedure Add_RACW_Primitive_Declarations_And_Bodies
1243 (Designated_Type
: Entity_Id
;
1244 Insertion_Node
: Node_Id
;
1245 Body_Decls
: List_Id
)
1247 Loc
: constant Source_Ptr
:= Sloc
(Insertion_Node
);
1248 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1249 -- the declarations are recognized as belonging to the current package.
1251 Stub_Elements
: constant Stub_Structure
:=
1252 Stubs_Table
.Get
(Designated_Type
);
1254 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
1256 Is_RAS
: constant Boolean :=
1257 not Comes_From_Source
(Stub_Elements
.RACW_Type
);
1258 -- Case of the RACW generated to implement a remote access-to-
1261 Build_Bodies
: constant Boolean :=
1262 In_Extended_Main_Code_Unit
(Stub_Elements
.Stub_Type
);
1263 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1264 -- only when the main unit is the unit that contains the stub type.
1266 Current_Insertion_Node
: Node_Id
:= Insertion_Node
;
1268 RPC_Receiver
: Entity_Id
;
1269 RPC_Receiver_Statements
: List_Id
;
1270 RPC_Receiver_Case_Alternatives
: constant List_Id
:= New_List
;
1271 RPC_Receiver_Elsif_Parts
: List_Id
;
1272 RPC_Receiver_Request
: Entity_Id
;
1273 RPC_Receiver_Subp_Id
: Entity_Id
;
1274 RPC_Receiver_Subp_Index
: Entity_Id
;
1276 Subp_Str
: String_Id
;
1278 Current_Primitive_Elmt
: Elmt_Id
;
1279 Current_Primitive
: Entity_Id
;
1280 Current_Primitive_Body
: Node_Id
;
1281 Current_Primitive_Spec
: Node_Id
;
1282 Current_Primitive_Decl
: Node_Id
;
1283 Current_Primitive_Number
: Int
:= 0;
1284 Current_Primitive_Alias
: Node_Id
;
1285 Current_Receiver
: Entity_Id
;
1286 Current_Receiver_Body
: Node_Id
;
1287 RPC_Receiver_Decl
: Node_Id
;
1288 Possibly_Asynchronous
: Boolean;
1291 if not Expander_Active
then
1296 RPC_Receiver
:= Make_Temporary
(Loc
, 'P');
1298 Specific_Build_RPC_Receiver_Body
1299 (RPC_Receiver
=> RPC_Receiver
,
1300 Request
=> RPC_Receiver_Request
,
1301 Subp_Id
=> RPC_Receiver_Subp_Id
,
1302 Subp_Index
=> RPC_Receiver_Subp_Index
,
1303 Stmts
=> RPC_Receiver_Statements
,
1304 Decl
=> RPC_Receiver_Decl
);
1306 if Get_PCS_Name
= Name_PolyORB_DSA
then
1308 -- For the case of PolyORB, we need to map a textual operation
1309 -- name into a primitive index. Currently we do so using a simple
1310 -- sequence of string comparisons.
1312 RPC_Receiver_Elsif_Parts
:= New_List
;
1316 -- Build callers, receivers for every primitive operations and a RPC
1317 -- receiver for this type.
1319 if Present
(Primitive_Operations
(Designated_Type
)) then
1320 Overload_Counter_Table
.Reset
;
1322 Current_Primitive_Elmt
:=
1323 First_Elmt
(Primitive_Operations
(Designated_Type
));
1324 while Current_Primitive_Elmt
/= No_Elmt
loop
1325 Current_Primitive
:= Node
(Current_Primitive_Elmt
);
1327 -- Copy the primitive of all the parents, except predefined ones
1328 -- that are not remotely dispatching. Also omit hidden primitives
1329 -- (occurs in the case of primitives of interface progenitors
1330 -- other than immediate ancestors of the Designated_Type).
1332 if Chars
(Current_Primitive
) /= Name_uSize
1333 and then Chars
(Current_Primitive
) /= Name_uAlignment
1335 (Is_TSS
(Current_Primitive
, TSS_Deep_Finalize
) or else
1336 Is_TSS
(Current_Primitive
, TSS_Stream_Input
) or else
1337 Is_TSS
(Current_Primitive
, TSS_Stream_Output
) or else
1338 Is_TSS
(Current_Primitive
, TSS_Stream_Read
) or else
1339 Is_TSS
(Current_Primitive
, TSS_Stream_Write
) or else
1340 Is_Predefined_Interface_Primitive
(Current_Primitive
))
1341 and then not Is_Hidden
(Current_Primitive
)
1343 -- The first thing to do is build an up-to-date copy of the
1344 -- spec with all the formals referencing Controlling_Type
1345 -- transformed into formals referencing Stub_Type. Since this
1346 -- primitive may have been inherited, go back the alias chain
1347 -- until the real primitive has been found.
1349 Current_Primitive_Alias
:= Ultimate_Alias
(Current_Primitive
);
1351 -- Copy the spec from the original declaration for the purpose
1352 -- of declaring an overriding subprogram: we need to replace
1353 -- the type of each controlling formal with Stub_Type. The
1354 -- primitive may have been declared for Controlling_Type or
1355 -- inherited from some ancestor type for which we do not have
1356 -- an easily determined Entity_Id. We have no systematic way
1357 -- of knowing which type to substitute Stub_Type for. Instead,
1358 -- Copy_Specification relies on the flag Is_Controlling_Formal
1359 -- to determine which formals to change.
1361 Current_Primitive_Spec
:=
1362 Copy_Specification
(Loc
,
1363 Spec
=> Parent
(Current_Primitive_Alias
),
1364 Ctrl_Type
=> Stub_Elements
.Stub_Type
);
1366 Current_Primitive_Decl
:=
1367 Make_Subprogram_Declaration
(Loc
,
1368 Specification
=> Current_Primitive_Spec
);
1370 Insert_After_And_Analyze
(Current_Insertion_Node
,
1371 Current_Primitive_Decl
);
1372 Current_Insertion_Node
:= Current_Primitive_Decl
;
1374 Possibly_Asynchronous
:=
1375 Nkind
(Current_Primitive_Spec
) = N_Procedure_Specification
1376 and then Could_Be_Asynchronous
(Current_Primitive_Spec
);
1378 Assign_Subprogram_Identifier
(
1379 Defining_Unit_Name
(Current_Primitive_Spec
),
1380 Current_Primitive_Number
,
1383 if Build_Bodies
then
1384 Current_Primitive_Body
:=
1385 Build_Subprogram_Calling_Stubs
1386 (Vis_Decl
=> Current_Primitive_Decl
,
1388 Build_Subprogram_Id
(Loc
,
1389 Defining_Unit_Name
(Current_Primitive_Spec
)),
1390 Asynchronous
=> Possibly_Asynchronous
,
1391 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1392 Stub_Type
=> Stub_Elements
.Stub_Type
,
1393 RACW_Type
=> Stub_Elements
.RACW_Type
);
1394 Append_To
(Body_Decls
, Current_Primitive_Body
);
1396 -- Analyzing the body here would cause the Stub type to
1397 -- be frozen, thus preventing subsequent primitive
1398 -- declarations. For this reason, it will be analyzed
1399 -- later in the regular flow (and in the context of the
1400 -- appropriate unit body, see Append_RACW_Bodies).
1404 -- Build the receiver stubs
1406 if Build_Bodies
and then not Is_RAS
then
1407 Current_Receiver_Body
:=
1408 Specific_Build_Subprogram_Receiving_Stubs
1409 (Vis_Decl
=> Current_Primitive_Decl
,
1410 Asynchronous
=> Possibly_Asynchronous
,
1411 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1412 Stub_Type
=> Stub_Elements
.Stub_Type
,
1413 RACW_Type
=> Stub_Elements
.RACW_Type
,
1414 Parent_Primitive
=> Current_Primitive
);
1416 Current_Receiver
:= Defining_Unit_Name
(
1417 Specification
(Current_Receiver_Body
));
1419 Append_To
(Body_Decls
, Current_Receiver_Body
);
1421 -- Add a case alternative to the receiver
1423 if Get_PCS_Name
= Name_PolyORB_DSA
then
1424 Append_To
(RPC_Receiver_Elsif_Parts
,
1425 Make_Elsif_Part
(Loc
,
1427 Make_Function_Call
(Loc
,
1430 RTE
(RE_Caseless_String_Eq
), Loc
),
1431 Parameter_Associations
=> New_List
(
1432 New_Occurrence_Of
(RPC_Receiver_Subp_Id
, Loc
),
1433 Make_String_Literal
(Loc
, Subp_Str
))),
1435 Then_Statements
=> New_List
(
1436 Make_Assignment_Statement
(Loc
,
1437 Name
=> New_Occurrence_Of
(
1438 RPC_Receiver_Subp_Index
, Loc
),
1440 Make_Integer_Literal
(Loc
,
1441 Intval
=> Current_Primitive_Number
)))));
1444 Append_To
(RPC_Receiver_Case_Alternatives
,
1445 Make_Case_Statement_Alternative
(Loc
,
1446 Discrete_Choices
=> New_List
(
1447 Make_Integer_Literal
(Loc
, Current_Primitive_Number
)),
1449 Statements
=> New_List
(
1450 Make_Procedure_Call_Statement
(Loc
,
1452 New_Occurrence_Of
(Current_Receiver
, Loc
),
1453 Parameter_Associations
=> New_List
(
1454 New_Occurrence_Of
(RPC_Receiver_Request
, Loc
))))));
1457 -- Increment the index of current primitive
1459 Current_Primitive_Number
:= Current_Primitive_Number
+ 1;
1462 Next_Elmt
(Current_Primitive_Elmt
);
1466 -- Build the case statement and the heart of the subprogram
1468 if Build_Bodies
and then not Is_RAS
then
1469 if Get_PCS_Name
= Name_PolyORB_DSA
1470 and then Present
(First
(RPC_Receiver_Elsif_Parts
))
1472 Append_To
(RPC_Receiver_Statements
,
1473 Make_Implicit_If_Statement
(Designated_Type
,
1474 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
1475 Then_Statements
=> New_List
,
1476 Elsif_Parts
=> RPC_Receiver_Elsif_Parts
));
1479 Append_To
(RPC_Receiver_Case_Alternatives
,
1480 Make_Case_Statement_Alternative
(Loc
,
1481 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1482 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
1484 Append_To
(RPC_Receiver_Statements
,
1485 Make_Case_Statement
(Loc
,
1487 New_Occurrence_Of
(RPC_Receiver_Subp_Index
, Loc
),
1488 Alternatives
=> RPC_Receiver_Case_Alternatives
));
1490 Append_To
(Body_Decls
, RPC_Receiver_Decl
);
1491 Specific_Add_Obj_RPC_Receiver_Completion
(Loc
,
1492 Body_Decls
, RPC_Receiver
, Stub_Elements
);
1494 -- Do not analyze RPC receiver body at this stage since it references
1495 -- subprograms that have not been analyzed yet. It will be analyzed in
1496 -- the regular flow (see Append_RACW_Bodies).
1499 end Add_RACW_Primitive_Declarations_And_Bodies
;
1501 -----------------------------
1502 -- Add_RAS_Dereference_TSS --
1503 -----------------------------
1505 procedure Add_RAS_Dereference_TSS
(N
: Node_Id
) is
1506 Loc
: constant Source_Ptr
:= Sloc
(N
);
1508 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
1509 RAS_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
1510 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(RAS_Type
);
1511 RACW_Type
: constant Entity_Id
:= Underlying_RACW_Type
(RAS_Type
);
1513 RACW_Primitive_Name
: Node_Id
;
1515 Proc
: constant Entity_Id
:=
1516 Make_Defining_Identifier
(Loc
,
1517 Chars
=> Make_TSS_Name
(RAS_Type
, TSS_RAS_Dereference
));
1519 Proc_Spec
: Node_Id
;
1520 Param_Specs
: List_Id
;
1521 Param_Assoc
: constant List_Id
:= New_List
;
1522 Stmts
: constant List_Id
:= New_List
;
1524 RAS_Parameter
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
1526 Is_Function
: constant Boolean :=
1527 Nkind
(Type_Def
) = N_Access_Function_Definition
;
1529 Is_Degenerate
: Boolean;
1530 -- Set to True if the subprogram_specification for this RAS has an
1531 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1533 Spec
: constant Node_Id
:= Type_Def
;
1535 Current_Parameter
: Node_Id
;
1537 -- Start of processing for Add_RAS_Dereference_TSS
1540 -- The Dereference TSS for a remote access-to-subprogram type has the
1543 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1546 -- This is called whenever a value of a RAS type is dereferenced
1548 -- First construct a list of parameter specifications:
1550 -- The first formal is the RAS values
1552 Param_Specs
:= New_List
(
1553 Make_Parameter_Specification
(Loc
,
1554 Defining_Identifier
=> RAS_Parameter
,
1557 New_Occurrence_Of
(Fat_Type
, Loc
)));
1559 -- The following formals are copied from the type declaration
1561 Is_Degenerate
:= False;
1562 Current_Parameter
:= First
(Parameter_Specifications
(Type_Def
));
1563 Parameters
: while Present
(Current_Parameter
) loop
1564 if Nkind
(Parameter_Type
(Current_Parameter
)) =
1567 Is_Degenerate
:= True;
1570 Append_To
(Param_Specs
,
1571 Make_Parameter_Specification
(Loc
,
1572 Defining_Identifier
=>
1573 Make_Defining_Identifier
(Loc
,
1574 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))),
1575 In_Present
=> In_Present
(Current_Parameter
),
1576 Out_Present
=> Out_Present
(Current_Parameter
),
1578 New_Copy_Tree
(Parameter_Type
(Current_Parameter
)),
1580 New_Copy_Tree
(Expression
(Current_Parameter
))));
1582 Append_To
(Param_Assoc
,
1583 Make_Identifier
(Loc
,
1584 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))));
1586 Next
(Current_Parameter
);
1587 end loop Parameters
;
1589 if Is_Degenerate
then
1590 Prepend_To
(Param_Assoc
, New_Occurrence_Of
(RAS_Parameter
, Loc
));
1592 -- Generate a dummy body. This code will never actually be executed,
1593 -- because null is the only legal value for a degenerate RAS type.
1594 -- For legality's sake (in order to avoid generating a function that
1595 -- does not contain a return statement), we include a dummy recursive
1596 -- call on the TSS itself.
1599 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Explicit_Raise
));
1600 RACW_Primitive_Name
:= New_Occurrence_Of
(Proc
, Loc
);
1603 -- For a normal RAS type, we cast the RAS formal to the corresponding
1604 -- tagged type, and perform a dispatching call to its Call primitive
1607 Prepend_To
(Param_Assoc
,
1608 Unchecked_Convert_To
(RACW_Type
,
1609 New_Occurrence_Of
(RAS_Parameter
, Loc
)));
1611 RACW_Primitive_Name
:=
1612 Make_Selected_Component
(Loc
,
1613 Prefix
=> Scope
(RACW_Type
),
1614 Selector_Name
=> Name_uCall
);
1619 Make_Simple_Return_Statement
(Loc
,
1621 Make_Function_Call
(Loc
,
1622 Name
=> RACW_Primitive_Name
,
1623 Parameter_Associations
=> Param_Assoc
)));
1627 Make_Procedure_Call_Statement
(Loc
,
1628 Name
=> RACW_Primitive_Name
,
1629 Parameter_Associations
=> Param_Assoc
));
1632 -- Build the complete subprogram
1636 Make_Function_Specification
(Loc
,
1637 Defining_Unit_Name
=> Proc
,
1638 Parameter_Specifications
=> Param_Specs
,
1639 Result_Definition
=>
1641 Entity
(Result_Definition
(Spec
)), Loc
));
1643 Set_Ekind
(Proc
, E_Function
);
1645 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
1649 Make_Procedure_Specification
(Loc
,
1650 Defining_Unit_Name
=> Proc
,
1651 Parameter_Specifications
=> Param_Specs
);
1653 Set_Ekind
(Proc
, E_Procedure
);
1654 Set_Etype
(Proc
, Standard_Void_Type
);
1658 Make_Subprogram_Body
(Loc
,
1659 Specification
=> Proc_Spec
,
1660 Declarations
=> New_List
,
1661 Handled_Statement_Sequence
=>
1662 Make_Handled_Sequence_Of_Statements
(Loc
,
1663 Statements
=> Stmts
)));
1665 Set_TSS
(Fat_Type
, Proc
);
1666 end Add_RAS_Dereference_TSS
;
1668 -------------------------------
1669 -- Add_RAS_Proxy_And_Analyze --
1670 -------------------------------
1672 procedure Add_RAS_Proxy_And_Analyze
1675 All_Calls_Remote_E
: Entity_Id
;
1676 Proxy_Object_Addr
: out Entity_Id
)
1678 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
1680 Subp_Name
: constant Entity_Id
:=
1681 Defining_Unit_Name
(Specification
(Vis_Decl
));
1683 Pkg_Name
: constant Entity_Id
:=
1684 Make_Defining_Identifier
(Loc
,
1685 Chars
=> New_External_Name
(Chars
(Subp_Name
), 'P', -1));
1687 Proxy_Type
: constant Entity_Id
:=
1688 Make_Defining_Identifier
(Loc
,
1691 (Related_Id
=> Chars
(Subp_Name
),
1694 Proxy_Type_Full_View
: constant Entity_Id
:=
1695 Make_Defining_Identifier
(Loc
,
1696 Chars
(Proxy_Type
));
1698 Subp_Decl_Spec
: constant Node_Id
:=
1699 Build_RAS_Primitive_Specification
1700 (Subp_Spec
=> Specification
(Vis_Decl
),
1701 Remote_Object_Type
=> Proxy_Type
);
1703 Subp_Body_Spec
: constant Node_Id
:=
1704 Build_RAS_Primitive_Specification
1705 (Subp_Spec
=> Specification
(Vis_Decl
),
1706 Remote_Object_Type
=> Proxy_Type
);
1708 Vis_Decls
: constant List_Id
:= New_List
;
1709 Pvt_Decls
: constant List_Id
:= New_List
;
1710 Actuals
: constant List_Id
:= New_List
;
1712 Perform_Call
: Node_Id
;
1715 -- type subpP is tagged limited private;
1717 Append_To
(Vis_Decls
,
1718 Make_Private_Type_Declaration
(Loc
,
1719 Defining_Identifier
=> Proxy_Type
,
1720 Tagged_Present
=> True,
1721 Limited_Present
=> True));
1723 -- [subprogram] Call
1724 -- (Self : access subpP;
1725 -- ...other-formals...)
1728 Append_To
(Vis_Decls
,
1729 Make_Subprogram_Declaration
(Loc
,
1730 Specification
=> Subp_Decl_Spec
));
1732 -- A : constant System.Address;
1734 Proxy_Object_Addr
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1736 Append_To
(Vis_Decls
,
1737 Make_Object_Declaration
(Loc
,
1738 Defining_Identifier
=> Proxy_Object_Addr
,
1739 Constant_Present
=> True,
1740 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
1744 -- type subpP is tagged limited record
1745 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1749 Append_To
(Pvt_Decls
,
1750 Make_Full_Type_Declaration
(Loc
,
1751 Defining_Identifier
=> Proxy_Type_Full_View
,
1753 Build_Remote_Subprogram_Proxy_Type
(Loc
,
1754 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
))));
1756 -- Trick semantic analysis into swapping the public and full view when
1757 -- freezing the public view.
1759 Set_Comes_From_Source
(Proxy_Type_Full_View
, True);
1762 -- (Self : access O;
1763 -- ...other-formals...) is
1765 -- P (...other-formals...);
1769 -- (Self : access O;
1770 -- ...other-formals...)
1773 -- return F (...other-formals...);
1776 if Nkind
(Subp_Decl_Spec
) = N_Procedure_Specification
then
1778 Make_Procedure_Call_Statement
(Loc
,
1779 Name
=> New_Occurrence_Of
(Subp_Name
, Loc
),
1780 Parameter_Associations
=> Actuals
);
1783 Make_Simple_Return_Statement
(Loc
,
1785 Make_Function_Call
(Loc
,
1786 Name
=> New_Occurrence_Of
(Subp_Name
, Loc
),
1787 Parameter_Associations
=> Actuals
));
1790 Formal
:= First
(Parameter_Specifications
(Subp_Decl_Spec
));
1791 pragma Assert
(Present
(Formal
));
1794 exit when No
(Formal
);
1796 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1799 -- O : aliased subpP;
1801 Append_To
(Pvt_Decls
,
1802 Make_Object_Declaration
(Loc
,
1803 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uO
),
1804 Aliased_Present
=> True,
1805 Object_Definition
=> New_Occurrence_Of
(Proxy_Type
, Loc
)));
1807 -- A : constant System.Address := O'Address;
1809 Append_To
(Pvt_Decls
,
1810 Make_Object_Declaration
(Loc
,
1811 Defining_Identifier
=>
1812 Make_Defining_Identifier
(Loc
, Chars
(Proxy_Object_Addr
)),
1813 Constant_Present
=> True,
1814 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
1816 Make_Attribute_Reference
(Loc
,
1817 Prefix
=> New_Occurrence_Of
(
1818 Defining_Identifier
(Last
(Pvt_Decls
)), Loc
),
1819 Attribute_Name
=> Name_Address
)));
1822 Make_Package_Declaration
(Loc
,
1823 Specification
=> Make_Package_Specification
(Loc
,
1824 Defining_Unit_Name
=> Pkg_Name
,
1825 Visible_Declarations
=> Vis_Decls
,
1826 Private_Declarations
=> Pvt_Decls
,
1827 End_Label
=> Empty
)));
1828 Analyze
(Last
(Decls
));
1831 Make_Package_Body
(Loc
,
1832 Defining_Unit_Name
=>
1833 Make_Defining_Identifier
(Loc
, Chars
(Pkg_Name
)),
1834 Declarations
=> New_List
(
1835 Make_Subprogram_Body
(Loc
,
1836 Specification
=> Subp_Body_Spec
,
1837 Declarations
=> New_List
,
1838 Handled_Statement_Sequence
=>
1839 Make_Handled_Sequence_Of_Statements
(Loc
,
1840 Statements
=> New_List
(Perform_Call
))))));
1841 Analyze
(Last
(Decls
));
1842 end Add_RAS_Proxy_And_Analyze
;
1844 -----------------------
1845 -- Add_RAST_Features --
1846 -----------------------
1848 procedure Add_RAST_Features
(Vis_Decl
: Node_Id
) is
1849 RAS_Type
: constant Entity_Id
:=
1850 Equivalent_Type
(Defining_Identifier
(Vis_Decl
));
1852 pragma Assert
(No
(TSS
(RAS_Type
, TSS_RAS_Access
)));
1853 Add_RAS_Dereference_TSS
(Vis_Decl
);
1854 Specific_Add_RAST_Features
(Vis_Decl
, RAS_Type
);
1855 end Add_RAST_Features
;
1861 procedure Add_Stub_Type
1862 (Designated_Type
: Entity_Id
;
1863 RACW_Type
: Entity_Id
;
1865 Stub_Type
: out Entity_Id
;
1866 Stub_Type_Access
: out Entity_Id
;
1867 RPC_Receiver_Decl
: out Node_Id
;
1868 Body_Decls
: out List_Id
;
1869 Existing
: out Boolean)
1871 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1873 Stub_Elements
: constant Stub_Structure
:=
1874 Stubs_Table
.Get
(Designated_Type
);
1875 Stub_Type_Comps
: List_Id
;
1876 Stub_Type_Decl
: Node_Id
;
1877 Stub_Type_Access_Decl
: Node_Id
;
1880 if Stub_Elements
/= Empty_Stub_Structure
then
1881 Stub_Type
:= Stub_Elements
.Stub_Type
;
1882 Stub_Type_Access
:= Stub_Elements
.Stub_Type_Access
;
1883 RPC_Receiver_Decl
:= Stub_Elements
.RPC_Receiver_Decl
;
1884 Body_Decls
:= Stub_Elements
.Body_Decls
;
1890 Stub_Type
:= Make_Temporary
(Loc
, 'S');
1891 Set_Ekind
(Stub_Type
, E_Record_Type
);
1892 Set_Is_RACW_Stub_Type
(Stub_Type
);
1894 Make_Defining_Identifier
(Loc
,
1895 Chars
=> New_External_Name
1896 (Related_Id
=> Chars
(Stub_Type
), Suffix
=> 'A'));
1898 Specific_Build_Stub_Type
(RACW_Type
, Stub_Type_Comps
, RPC_Receiver_Decl
);
1901 Make_Full_Type_Declaration
(Loc
,
1902 Defining_Identifier
=> Stub_Type
,
1904 Make_Record_Definition
(Loc
,
1905 Tagged_Present
=> True,
1906 Limited_Present
=> True,
1908 Make_Component_List
(Loc
,
1909 Component_Items
=> Stub_Type_Comps
)));
1911 -- Does the stub type need to explicitly implement interfaces from the
1912 -- designated type???
1914 -- In particular are there issues in the case where the designated type
1915 -- is a synchronized interface???
1917 Stub_Type_Access_Decl
:=
1918 Make_Full_Type_Declaration
(Loc
,
1919 Defining_Identifier
=> Stub_Type_Access
,
1921 Make_Access_To_Object_Definition
(Loc
,
1922 All_Present
=> True,
1923 Subtype_Indication
=> New_Occurrence_Of
(Stub_Type
, Loc
)));
1925 Append_To
(Decls
, Stub_Type_Decl
);
1926 Analyze
(Last
(Decls
));
1927 Append_To
(Decls
, Stub_Type_Access_Decl
);
1928 Analyze
(Last
(Decls
));
1930 -- We can't directly derive the stub type from the designated type,
1931 -- because we don't want any components or discriminants from the real
1932 -- type, so instead we manually fake a derivation to get an appropriate
1935 Derive_Subprograms
(Parent_Type
=> Designated_Type
,
1936 Derived_Type
=> Stub_Type
);
1938 if Present
(RPC_Receiver_Decl
) then
1939 Append_To
(Decls
, RPC_Receiver_Decl
);
1941 RPC_Receiver_Decl
:= Last
(Decls
);
1944 Body_Decls
:= New_List
;
1946 Stubs_Table
.Set
(Designated_Type
,
1947 (Stub_Type
=> Stub_Type
,
1948 Stub_Type_Access
=> Stub_Type_Access
,
1949 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1950 Body_Decls
=> Body_Decls
,
1951 RACW_Type
=> RACW_Type
));
1954 ------------------------
1955 -- Append_RACW_Bodies --
1956 ------------------------
1958 procedure Append_RACW_Bodies
(Decls
: List_Id
; Spec_Id
: Entity_Id
) is
1962 E
:= First_Entity
(Spec_Id
);
1963 while Present
(E
) loop
1964 if Is_Remote_Access_To_Class_Wide_Type
(E
) then
1965 Append_List_To
(Decls
, Get_And_Reset_RACW_Bodies
(E
));
1970 end Append_RACW_Bodies
;
1972 ----------------------------------
1973 -- Assign_Subprogram_Identifier --
1974 ----------------------------------
1976 procedure Assign_Subprogram_Identifier
1981 N
: constant Name_Id
:= Chars
(Def
);
1983 Overload_Order
: constant Int
:=
1984 Overload_Counter_Table
.Get
(N
) + 1;
1987 Overload_Counter_Table
.Set
(N
, Overload_Order
);
1989 Get_Name_String
(N
);
1991 -- Homonym handling: as in Exp_Dbug, but much simpler, because the only
1992 -- entities for which we have to generate names here need only to be
1993 -- disambiguated within their own scope.
1995 if Overload_Order
> 1 then
1996 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 2) := "__";
1997 Name_Len
:= Name_Len
+ 2;
1998 Add_Nat_To_Name_Buffer
(Overload_Order
);
2001 Id
:= String_From_Name_Buffer
;
2002 Subprogram_Identifier_Table
.Set
2004 Subprogram_Identifiers
'(Str_Identifier => Id, Int_Identifier => Spn));
2005 end Assign_Subprogram_Identifier;
2007 -------------------------------------
2008 -- Build_Actual_Object_Declaration --
2009 -------------------------------------
2011 procedure Build_Actual_Object_Declaration
2012 (Object : Entity_Id;
2018 Loc : constant Source_Ptr := Sloc (Object);
2021 -- Declare a temporary object for the actual, possibly initialized with
2022 -- a 'Input
/From_Any call
.
2024 -- Complication arises in the case of limited types, for which such a
2025 -- declaration is illegal in Ada 95. In that case, we first generate a
2026 -- renaming declaration of the 'Input call, and then if needed we
2027 -- generate an overlaid non-constant view.
2029 if Ada_Version
<= Ada_95
2030 and then Is_Limited_Type
(Etyp
)
2031 and then Present
(Expr
)
2034 -- Object : Etyp renames <func-call>
2037 Make_Object_Renaming_Declaration
(Loc
,
2038 Defining_Identifier
=> Object
,
2039 Subtype_Mark
=> New_Occurrence_Of
(Etyp
, Loc
),
2044 -- The name defined by the renaming declaration denotes a
2045 -- constant view; create a non-constant object at the same address
2046 -- to be used as the actual.
2049 Constant_Object
: constant Entity_Id
:=
2050 Make_Temporary
(Loc
, 'P');
2053 Set_Defining_Identifier
2054 (Last
(Decls
), Constant_Object
);
2056 -- We have an unconstrained Etyp: build the actual constrained
2057 -- subtype for the value we just read from the stream.
2059 -- subtype S is <actual subtype of Constant_Object>;
2062 Build_Actual_Subtype
(Etyp
,
2063 New_Occurrence_Of
(Constant_Object
, Loc
)));
2068 Make_Object_Declaration
(Loc
,
2069 Defining_Identifier
=> Object
,
2070 Object_Definition
=>
2072 (Defining_Identifier
(Last
(Decls
)), Loc
)));
2073 Set_Ekind
(Object
, E_Variable
);
2075 -- Suppress default initialization:
2076 -- pragma Import (Ada, Object);
2080 Chars
=> Name_Import
,
2081 Pragma_Argument_Associations
=> New_List
(
2082 Make_Pragma_Argument_Association
(Loc
,
2083 Chars
=> Name_Convention
,
2084 Expression
=> Make_Identifier
(Loc
, Name_Ada
)),
2085 Make_Pragma_Argument_Association
(Loc
,
2086 Chars
=> Name_Entity
,
2087 Expression
=> New_Occurrence_Of
(Object
, Loc
)))));
2089 -- for Object'Address use Constant_Object'Address;
2092 Make_Attribute_Definition_Clause
(Loc
,
2093 Name
=> New_Occurrence_Of
(Object
, Loc
),
2094 Chars
=> Name_Address
,
2096 Make_Attribute_Reference
(Loc
,
2097 Prefix
=> New_Occurrence_Of
(Constant_Object
, Loc
),
2098 Attribute_Name
=> Name_Address
)));
2103 -- General case of a regular object declaration. Object is flagged
2104 -- constant unless it has mode out or in out, to allow the backend
2105 -- to optimize where possible.
2107 -- Object : [constant] Etyp [:= <expr>];
2110 Make_Object_Declaration
(Loc
,
2111 Defining_Identifier
=> Object
,
2112 Constant_Present
=> Present
(Expr
) and then not Variable
,
2113 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
2114 Expression
=> Expr
));
2116 if Constant_Present
(Last
(Decls
)) then
2117 Set_Ekind
(Object
, E_Constant
);
2119 Set_Ekind
(Object
, E_Variable
);
2122 end Build_Actual_Object_Declaration
;
2124 ------------------------------
2125 -- Build_Get_Unique_RP_Call --
2126 ------------------------------
2128 function Build_Get_Unique_RP_Call
2130 Pointer
: Entity_Id
;
2131 Stub_Type
: Entity_Id
) return List_Id
2135 Make_Procedure_Call_Statement
(Loc
,
2137 New_Occurrence_Of
(RTE
(RE_Get_Unique_Remote_Pointer
), Loc
),
2138 Parameter_Associations
=> New_List
(
2139 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2140 New_Occurrence_Of
(Pointer
, Loc
)))),
2142 Make_Assignment_Statement
(Loc
,
2144 Make_Selected_Component
(Loc
,
2145 Prefix
=> New_Occurrence_Of
(Pointer
, Loc
),
2147 New_Occurrence_Of
(First_Tag_Component
2148 (Designated_Type
(Etype
(Pointer
))), Loc
)),
2150 Make_Attribute_Reference
(Loc
,
2151 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
2152 Attribute_Name
=> Name_Tag
)));
2154 -- Note: The assignment to Pointer._Tag is safe here because
2155 -- we carefully ensured that Stub_Type has exactly the same layout
2156 -- as System.Partition_Interface.RACW_Stub_Type.
2158 end Build_Get_Unique_RP_Call
;
2160 -----------------------------------
2161 -- Build_Ordered_Parameters_List --
2162 -----------------------------------
2164 function Build_Ordered_Parameters_List
(Spec
: Node_Id
) return List_Id
is
2165 Constrained_List
: List_Id
;
2166 Unconstrained_List
: List_Id
;
2167 Current_Parameter
: Node_Id
;
2170 First_Parameter
: Node_Id
;
2171 For_RAS
: Boolean := False;
2174 if No
(Parameter_Specifications
(Spec
)) then
2178 Constrained_List
:= New_List
;
2179 Unconstrained_List
:= New_List
;
2180 First_Parameter
:= First
(Parameter_Specifications
(Spec
));
2182 if Nkind
(Parameter_Type
(First_Parameter
)) = N_Access_Definition
2183 and then Chars
(Defining_Identifier
(First_Parameter
)) = Name_uS
2188 -- Loop through the parameters and add them to the right list. Note that
2189 -- we treat a parameter of a null-excluding access type as unconstrained
2190 -- because we can't declare an object of such a type with default
2193 Current_Parameter
:= First_Parameter
;
2194 while Present
(Current_Parameter
) loop
2195 Ptyp
:= Parameter_Type
(Current_Parameter
);
2197 if (Nkind
(Ptyp
) = N_Access_Definition
2198 or else not Transmit_As_Unconstrained
(Etype
(Ptyp
)))
2199 and then not (For_RAS
and then Current_Parameter
= First_Parameter
)
2201 Append_To
(Constrained_List
, New_Copy
(Current_Parameter
));
2203 Append_To
(Unconstrained_List
, New_Copy
(Current_Parameter
));
2206 Next
(Current_Parameter
);
2209 -- Unconstrained parameters are returned first
2211 Append_List_To
(Unconstrained_List
, Constrained_List
);
2213 return Unconstrained_List
;
2214 end Build_Ordered_Parameters_List
;
2216 ----------------------------------
2217 -- Build_Passive_Partition_Stub --
2218 ----------------------------------
2220 procedure Build_Passive_Partition_Stub
(U
: Node_Id
) is
2222 Pkg_Name
: String_Id
;
2225 Loc
: constant Source_Ptr
:= Sloc
(U
);
2228 -- Verify that the implementation supports distribution, by accessing
2229 -- a type defined in the proper version of system.rpc
2232 Dist_OK
: Entity_Id
;
2233 pragma Warnings
(Off
, Dist_OK
);
2235 Dist_OK
:= RTE
(RE_Params_Stream_Type
);
2238 -- Use body if present, spec otherwise
2240 if Nkind
(U
) = N_Package_Declaration
then
2241 Pkg_Spec
:= Specification
(U
);
2242 L
:= Visible_Declarations
(Pkg_Spec
);
2244 Pkg_Spec
:= Parent
(Corresponding_Spec
(U
));
2245 L
:= Declarations
(U
);
2248 Get_Library_Unit_Name_String
(Pkg_Spec
);
2249 Pkg_Name
:= String_From_Name_Buffer
;
2251 Make_Procedure_Call_Statement
(Loc
,
2253 New_Occurrence_Of
(RTE
(RE_Register_Passive_Package
), Loc
),
2254 Parameter_Associations
=> New_List
(
2255 Make_String_Literal
(Loc
, Pkg_Name
),
2256 Make_Attribute_Reference
(Loc
,
2258 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
2259 Attribute_Name
=> Name_Version
)));
2262 end Build_Passive_Partition_Stub
;
2264 --------------------------------------
2265 -- Build_RPC_Receiver_Specification --
2266 --------------------------------------
2268 function Build_RPC_Receiver_Specification
2269 (RPC_Receiver
: Entity_Id
;
2270 Request_Parameter
: Entity_Id
) return Node_Id
2272 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
2275 Make_Procedure_Specification
(Loc
,
2276 Defining_Unit_Name
=> RPC_Receiver
,
2277 Parameter_Specifications
=> New_List
(
2278 Make_Parameter_Specification
(Loc
,
2279 Defining_Identifier
=> Request_Parameter
,
2281 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
2282 end Build_RPC_Receiver_Specification
;
2284 ----------------------------------------
2285 -- Build_Remote_Subprogram_Proxy_Type --
2286 ----------------------------------------
2288 function Build_Remote_Subprogram_Proxy_Type
2290 ACR_Expression
: Node_Id
) return Node_Id
2294 Make_Record_Definition
(Loc
,
2295 Tagged_Present
=> True,
2296 Limited_Present
=> True,
2298 Make_Component_List
(Loc
,
2300 Component_Items
=> New_List
(
2301 Make_Component_Declaration
(Loc
,
2302 Defining_Identifier
=>
2303 Make_Defining_Identifier
(Loc
,
2304 Name_All_Calls_Remote
),
2305 Component_Definition
=>
2306 Make_Component_Definition
(Loc
,
2307 Subtype_Indication
=>
2308 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
2312 Make_Component_Declaration
(Loc
,
2313 Defining_Identifier
=>
2314 Make_Defining_Identifier
(Loc
,
2316 Component_Definition
=>
2317 Make_Component_Definition
(Loc
,
2318 Subtype_Indication
=>
2319 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2321 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)),
2323 Make_Component_Declaration
(Loc
,
2324 Defining_Identifier
=>
2325 Make_Defining_Identifier
(Loc
,
2327 Component_Definition
=>
2328 Make_Component_Definition
(Loc
,
2329 Subtype_Indication
=>
2330 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))))));
2331 end Build_Remote_Subprogram_Proxy_Type
;
2333 --------------------
2334 -- Build_Stub_Tag --
2335 --------------------
2337 function Build_Stub_Tag
2339 RACW_Type
: Entity_Id
) return Node_Id
2341 Stub_Type
: constant Entity_Id
:= Corresponding_Stub_Type
(RACW_Type
);
2344 Make_Attribute_Reference
(Loc
,
2345 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
2346 Attribute_Name
=> Name_Tag
);
2349 ------------------------------------
2350 -- Build_Subprogram_Calling_Stubs --
2351 ------------------------------------
2353 function Build_Subprogram_Calling_Stubs
2354 (Vis_Decl
: Node_Id
;
2356 Asynchronous
: Boolean;
2357 Dynamically_Asynchronous
: Boolean := False;
2358 Stub_Type
: Entity_Id
:= Empty
;
2359 RACW_Type
: Entity_Id
:= Empty
;
2360 Locator
: Entity_Id
:= Empty
;
2361 New_Name
: Name_Id
:= No_Name
) return Node_Id
2363 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
2365 Decls
: constant List_Id
:= New_List
;
2366 Statements
: constant List_Id
:= New_List
;
2368 Subp_Spec
: Node_Id
;
2369 -- The specification of the body
2371 Controlling_Parameter
: Entity_Id
:= Empty
;
2373 Asynchronous_Expr
: Node_Id
:= Empty
;
2375 RCI_Locator
: Entity_Id
;
2377 Spec_To_Use
: Node_Id
;
2379 procedure Insert_Partition_Check
(Parameter
: Node_Id
);
2380 -- Check that the parameter has been elaborated on the same partition
2381 -- than the controlling parameter (E.4(19)).
2383 ----------------------------
2384 -- Insert_Partition_Check --
2385 ----------------------------
2387 procedure Insert_Partition_Check
(Parameter
: Node_Id
) is
2388 Parameter_Entity
: constant Entity_Id
:=
2389 Defining_Identifier
(Parameter
);
2391 -- The expression that will be built is of the form:
2393 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2394 -- raise Constraint_Error;
2397 -- We do not check that Parameter is in Stub_Type since such a check
2398 -- has been inserted at the point of call already (a tag check since
2399 -- we have multiple controlling operands).
2402 Make_Raise_Constraint_Error
(Loc
,
2406 Make_Function_Call
(Loc
,
2408 New_Occurrence_Of
(RTE
(RE_Same_Partition
), Loc
),
2409 Parameter_Associations
=>
2411 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2412 New_Occurrence_Of
(Parameter_Entity
, Loc
)),
2413 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2414 New_Occurrence_Of
(Controlling_Parameter
, Loc
))))),
2415 Reason
=> CE_Partition_Check_Failed
));
2416 end Insert_Partition_Check
;
2418 -- Start of processing for Build_Subprogram_Calling_Stubs
2422 Copy_Specification
(Loc
,
2423 Spec
=> Specification
(Vis_Decl
),
2424 New_Name
=> New_Name
);
2426 if Locator
= Empty
then
2427 RCI_Locator
:= RCI_Cache
;
2428 Spec_To_Use
:= Specification
(Vis_Decl
);
2430 RCI_Locator
:= Locator
;
2431 Spec_To_Use
:= Subp_Spec
;
2434 -- Find a controlling argument if we have a stub type. Also check
2435 -- if this subprogram can be made asynchronous.
2437 if Present
(Stub_Type
)
2438 and then Present
(Parameter_Specifications
(Spec_To_Use
))
2441 Current_Parameter
: Node_Id
:=
2442 First
(Parameter_Specifications
2445 while Present
(Current_Parameter
) loop
2447 Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
)
2449 if Controlling_Parameter
= Empty
then
2450 Controlling_Parameter
:=
2451 Defining_Identifier
(Current_Parameter
);
2453 Insert_Partition_Check
(Current_Parameter
);
2457 Next
(Current_Parameter
);
2462 pragma Assert
(No
(Stub_Type
) or else Present
(Controlling_Parameter
));
2464 if Dynamically_Asynchronous
then
2465 Asynchronous_Expr
:= Make_Selected_Component
(Loc
,
2466 Prefix
=> Controlling_Parameter
,
2467 Selector_Name
=> Name_Asynchronous
);
2470 Specific_Build_General_Calling_Stubs
2472 Statements
=> Statements
,
2473 Target
=> Specific_Build_Stub_Target
(Loc
,
2474 Decls
, RCI_Locator
, Controlling_Parameter
),
2475 Subprogram_Id
=> Subp_Id
,
2476 Asynchronous
=> Asynchronous_Expr
,
2477 Is_Known_Asynchronous
=> Asynchronous
2478 and then not Dynamically_Asynchronous
,
2479 Is_Known_Non_Asynchronous
2481 and then not Dynamically_Asynchronous
,
2482 Is_Function
=> Nkind
(Spec_To_Use
) =
2483 N_Function_Specification
,
2484 Spec
=> Spec_To_Use
,
2485 Stub_Type
=> Stub_Type
,
2486 RACW_Type
=> RACW_Type
,
2489 RCI_Calling_Stubs_Table
.Set
2490 (Defining_Unit_Name
(Specification
(Vis_Decl
)),
2491 Defining_Unit_Name
(Spec_To_Use
));
2494 Make_Subprogram_Body
(Loc
,
2495 Specification
=> Subp_Spec
,
2496 Declarations
=> Decls
,
2497 Handled_Statement_Sequence
=>
2498 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
));
2499 end Build_Subprogram_Calling_Stubs
;
2501 -------------------------
2502 -- Build_Subprogram_Id --
2503 -------------------------
2505 function Build_Subprogram_Id
2507 E
: Entity_Id
) return Node_Id
2510 if Get_Subprogram_Ids
(E
).Str_Identifier
= No_String
then
2512 Current_Declaration
: Node_Id
;
2513 Current_Subp
: Entity_Id
;
2514 Current_Subp_Str
: String_Id
;
2515 Current_Subp_Number
: Int
:= First_RCI_Subprogram_Id
;
2517 pragma Warnings
(Off
, Current_Subp_Str
);
2520 -- Build_Subprogram_Id is called outside of the context of
2521 -- generating calling or receiving stubs. Hence we are processing
2522 -- an 'Access attribute_reference for an RCI subprogram, for the
2523 -- purpose of obtaining a RAS value.
2526 (Is_Remote_Call_Interface
(Scope
(E
))
2528 (Nkind
(Parent
(E
)) = N_Procedure_Specification
2530 Nkind
(Parent
(E
)) = N_Function_Specification
));
2532 Current_Declaration
:=
2533 First
(Visible_Declarations
2534 (Package_Specification_Of_Scope
(Scope
(E
))));
2535 while Present
(Current_Declaration
) loop
2536 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
2537 and then Comes_From_Source
(Current_Declaration
)
2539 Current_Subp
:= Defining_Unit_Name
(Specification
(
2540 Current_Declaration
));
2542 Assign_Subprogram_Identifier
2543 (Current_Subp
, Current_Subp_Number
, Current_Subp_Str
);
2545 Current_Subp_Number
:= Current_Subp_Number
+ 1;
2548 Next
(Current_Declaration
);
2553 case Get_PCS_Name
is
2554 when Name_PolyORB_DSA
=>
2555 return Make_String_Literal
(Loc
, Get_Subprogram_Id
(E
));
2557 return Make_Integer_Literal
(Loc
, Get_Subprogram_Id
(E
));
2559 end Build_Subprogram_Id
;
2561 ------------------------
2562 -- Copy_Specification --
2563 ------------------------
2565 function Copy_Specification
2568 Ctrl_Type
: Entity_Id
:= Empty
;
2569 New_Name
: Name_Id
:= No_Name
) return Node_Id
2571 Parameters
: List_Id
:= No_List
;
2573 Current_Parameter
: Node_Id
;
2574 Current_Identifier
: Entity_Id
;
2575 Current_Type
: Node_Id
;
2577 Name_For_New_Spec
: Name_Id
;
2579 New_Identifier
: Entity_Id
;
2581 -- Comments needed in body below ???
2584 if New_Name
= No_Name
then
2585 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
2586 or else Nkind
(Spec
) = N_Procedure_Specification
);
2588 Name_For_New_Spec
:= Chars
(Defining_Unit_Name
(Spec
));
2590 Name_For_New_Spec
:= New_Name
;
2593 if Present
(Parameter_Specifications
(Spec
)) then
2594 Parameters
:= New_List
;
2595 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2596 while Present
(Current_Parameter
) loop
2597 Current_Identifier
:= Defining_Identifier
(Current_Parameter
);
2598 Current_Type
:= Parameter_Type
(Current_Parameter
);
2600 if Nkind
(Current_Type
) = N_Access_Definition
then
2601 if Present
(Ctrl_Type
) then
2602 pragma Assert
(Is_Controlling_Formal
(Current_Identifier
));
2604 Make_Access_Definition
(Loc
,
2605 Subtype_Mark
=> New_Occurrence_Of
(Ctrl_Type
, Loc
),
2606 Null_Exclusion_Present
=>
2607 Null_Exclusion_Present
(Current_Type
));
2611 Make_Access_Definition
(Loc
,
2613 New_Copy_Tree
(Subtype_Mark
(Current_Type
)),
2614 Null_Exclusion_Present
=>
2615 Null_Exclusion_Present
(Current_Type
));
2619 if Present
(Ctrl_Type
)
2620 and then Is_Controlling_Formal
(Current_Identifier
)
2622 Current_Type
:= New_Occurrence_Of
(Ctrl_Type
, Loc
);
2624 Current_Type
:= New_Copy_Tree
(Current_Type
);
2628 New_Identifier
:= Make_Defining_Identifier
(Loc
,
2629 Chars
(Current_Identifier
));
2631 Append_To
(Parameters
,
2632 Make_Parameter_Specification
(Loc
,
2633 Defining_Identifier
=> New_Identifier
,
2634 Parameter_Type
=> Current_Type
,
2635 In_Present
=> In_Present
(Current_Parameter
),
2636 Out_Present
=> Out_Present
(Current_Parameter
),
2638 New_Copy_Tree
(Expression
(Current_Parameter
))));
2640 -- For a regular formal parameter (that needs to be marshalled
2641 -- in the context of remote calls), set the Etype now, because
2642 -- marshalling processing might need it.
2644 if Is_Entity_Name
(Current_Type
) then
2645 Set_Etype
(New_Identifier
, Entity
(Current_Type
));
2647 -- Current_Type is an access definition, special processing
2648 -- (not requiring etype) will occur for marshalling.
2654 Next
(Current_Parameter
);
2658 case Nkind
(Spec
) is
2660 when N_Function_Specification | N_Access_Function_Definition
=>
2662 Make_Function_Specification
(Loc
,
2663 Defining_Unit_Name
=>
2664 Make_Defining_Identifier
(Loc
,
2665 Chars
=> Name_For_New_Spec
),
2666 Parameter_Specifications
=> Parameters
,
2667 Result_Definition
=>
2668 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
2670 when N_Procedure_Specification | N_Access_Procedure_Definition
=>
2672 Make_Procedure_Specification
(Loc
,
2673 Defining_Unit_Name
=>
2674 Make_Defining_Identifier
(Loc
,
2675 Chars
=> Name_For_New_Spec
),
2676 Parameter_Specifications
=> Parameters
);
2679 raise Program_Error
;
2681 end Copy_Specification
;
2683 -----------------------------
2684 -- Corresponding_Stub_Type --
2685 -----------------------------
2687 function Corresponding_Stub_Type
(RACW_Type
: Entity_Id
) return Entity_Id
is
2688 Desig
: constant Entity_Id
:=
2689 Etype
(Designated_Type
(RACW_Type
));
2690 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
2692 return Stub_Elements
.Stub_Type
;
2693 end Corresponding_Stub_Type
;
2695 ---------------------------
2696 -- Could_Be_Asynchronous --
2697 ---------------------------
2699 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean is
2700 Current_Parameter
: Node_Id
;
2703 if Present
(Parameter_Specifications
(Spec
)) then
2704 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2705 while Present
(Current_Parameter
) loop
2706 if Out_Present
(Current_Parameter
) then
2710 Next
(Current_Parameter
);
2715 end Could_Be_Asynchronous
;
2717 ---------------------------
2718 -- Declare_Create_NVList --
2719 ---------------------------
2721 procedure Declare_Create_NVList
2729 Make_Object_Declaration
(Loc
,
2730 Defining_Identifier
=> NVList
,
2731 Aliased_Present
=> False,
2732 Object_Definition
=>
2733 New_Occurrence_Of
(RTE
(RE_NVList_Ref
), Loc
)));
2736 Make_Procedure_Call_Statement
(Loc
,
2737 Name
=> New_Occurrence_Of
(RTE
(RE_NVList_Create
), Loc
),
2738 Parameter_Associations
=> New_List
(
2739 New_Occurrence_Of
(NVList
, Loc
))));
2740 end Declare_Create_NVList
;
2742 ---------------------------------------------
2743 -- Expand_All_Calls_Remote_Subprogram_Call --
2744 ---------------------------------------------
2746 procedure Expand_All_Calls_Remote_Subprogram_Call
(N
: Node_Id
) is
2747 Loc
: constant Source_Ptr
:= Sloc
(N
);
2748 Called_Subprogram
: constant Entity_Id
:= Entity
(Name
(N
));
2749 RCI_Package
: constant Entity_Id
:= Scope
(Called_Subprogram
);
2750 RCI_Locator_Decl
: Node_Id
;
2751 RCI_Locator
: Entity_Id
;
2752 Calling_Stubs
: Node_Id
;
2753 E_Calling_Stubs
: Entity_Id
;
2756 E_Calling_Stubs
:= RCI_Calling_Stubs_Table
.Get
(Called_Subprogram
);
2758 if E_Calling_Stubs
= Empty
then
2759 RCI_Locator
:= RCI_Locator_Table
.Get
(RCI_Package
);
2761 -- The RCI_Locator package and calling stub are is inserted at the
2762 -- top level in the current unit, and must appear in the proper scope
2763 -- so that it is not prematurely removed by the GCC back end.
2766 Scop
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
2768 if Ekind
(Scop
) = E_Package_Body
then
2769 Push_Scope
(Spec_Entity
(Scop
));
2770 elsif Ekind
(Scop
) = E_Subprogram_Body
then
2772 (Corresponding_Spec
(Unit_Declaration_Node
(Scop
)));
2778 if RCI_Locator
= Empty
then
2781 (Loc
, Specification
(Unit_Declaration_Node
(RCI_Package
)));
2782 Prepend_To
(Current_Sem_Unit_Declarations
, RCI_Locator_Decl
);
2783 Analyze
(RCI_Locator_Decl
);
2784 RCI_Locator
:= Defining_Unit_Name
(RCI_Locator_Decl
);
2787 RCI_Locator_Decl
:= Parent
(RCI_Locator
);
2790 Calling_Stubs
:= Build_Subprogram_Calling_Stubs
2791 (Vis_Decl
=> Parent
(Parent
(Called_Subprogram
)),
2793 Build_Subprogram_Id
(Loc
, Called_Subprogram
),
2794 Asynchronous
=> Nkind
(N
) = N_Procedure_Call_Statement
2796 Is_Asynchronous
(Called_Subprogram
),
2797 Locator
=> RCI_Locator
,
2798 New_Name
=> New_Internal_Name
('S'));
2799 Insert_After
(RCI_Locator_Decl
, Calling_Stubs
);
2800 Analyze
(Calling_Stubs
);
2803 E_Calling_Stubs
:= Defining_Unit_Name
(Specification
(Calling_Stubs
));
2806 Rewrite
(Name
(N
), New_Occurrence_Of
(E_Calling_Stubs
, Loc
));
2807 end Expand_All_Calls_Remote_Subprogram_Call
;
2809 ---------------------------------
2810 -- Expand_Calling_Stubs_Bodies --
2811 ---------------------------------
2813 procedure Expand_Calling_Stubs_Bodies
(Unit_Node
: Node_Id
) is
2814 Spec
: constant Node_Id
:= Specification
(Unit_Node
);
2815 Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
2817 Push_Scope
(Scope_Of_Spec
(Spec
));
2818 Add_Calling_Stubs_To_Declarations
2819 (Specification
(Unit_Node
), Decls
);
2821 end Expand_Calling_Stubs_Bodies
;
2823 -----------------------------------
2824 -- Expand_Receiving_Stubs_Bodies --
2825 -----------------------------------
2827 procedure Expand_Receiving_Stubs_Bodies
(Unit_Node
: Node_Id
) is
2830 Stubs_Decls
: List_Id
;
2831 Stubs_Stmts
: List_Id
;
2834 if Nkind
(Unit_Node
) = N_Package_Declaration
then
2835 Spec
:= Specification
(Unit_Node
);
2836 Decls
:= Private_Declarations
(Spec
);
2839 Decls
:= Visible_Declarations
(Spec
);
2842 Push_Scope
(Scope_Of_Spec
(Spec
));
2843 Specific_Add_Receiving_Stubs_To_Declarations
(Spec
, Decls
, Decls
);
2847 Package_Specification_Of_Scope
(Corresponding_Spec
(Unit_Node
));
2848 Decls
:= Declarations
(Unit_Node
);
2850 Push_Scope
(Scope_Of_Spec
(Unit_Node
));
2851 Stubs_Decls
:= New_List
;
2852 Stubs_Stmts
:= New_List
;
2853 Specific_Add_Receiving_Stubs_To_Declarations
2854 (Spec
, Stubs_Decls
, Stubs_Stmts
);
2856 Insert_List_Before
(First
(Decls
), Stubs_Decls
);
2859 HSS_Stmts
: constant List_Id
:=
2860 Statements
(Handled_Statement_Sequence
(Unit_Node
));
2862 First_HSS_Stmt
: constant Node_Id
:= First
(HSS_Stmts
);
2865 if No
(First_HSS_Stmt
) then
2866 Append_List_To
(HSS_Stmts
, Stubs_Stmts
);
2868 Insert_List_Before
(First_HSS_Stmt
, Stubs_Stmts
);
2874 end Expand_Receiving_Stubs_Bodies
;
2876 --------------------
2877 -- GARLIC_Support --
2878 --------------------
2880 package body GARLIC_Support
is
2882 -- Local subprograms
2884 procedure Add_RACW_Read_Attribute
2885 (RACW_Type
: Entity_Id
;
2886 Stub_Type
: Entity_Id
;
2887 Stub_Type_Access
: Entity_Id
;
2888 Body_Decls
: List_Id
);
2889 -- Add Read attribute for the RACW type. The declaration and attribute
2890 -- definition clauses are inserted right after the declaration of
2891 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2892 -- appended to it (case where the RACW declaration is in the main unit).
2894 procedure Add_RACW_Write_Attribute
2895 (RACW_Type
: Entity_Id
;
2896 Stub_Type
: Entity_Id
;
2897 Stub_Type_Access
: Entity_Id
;
2898 RPC_Receiver
: Node_Id
;
2899 Body_Decls
: List_Id
);
2900 -- Same as above for the Write attribute
2902 function Stream_Parameter
return Node_Id
;
2903 function Result
return Node_Id
;
2904 function Object
return Node_Id
renames Result
;
2905 -- Functions to create occurrences of the formal parameter names of the
2906 -- 'Read and 'Write attributes.
2909 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2910 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2912 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
2913 -- Add a subprogram body for RAS Access TSS
2915 -------------------------------------
2916 -- Add_Obj_RPC_Receiver_Completion --
2917 -------------------------------------
2919 procedure Add_Obj_RPC_Receiver_Completion
2922 RPC_Receiver
: Entity_Id
;
2923 Stub_Elements
: Stub_Structure
)
2926 -- The RPC receiver body should not be the completion of the
2927 -- declaration recorded in the stub structure, because then the
2928 -- occurrences of the formal parameters within the body should refer
2929 -- to the entities from the declaration, not from the completion, to
2930 -- which we do not have easy access. Instead, the RPC receiver body
2931 -- acts as its own declaration, and the RPC receiver declaration is
2932 -- completed by a renaming-as-body.
2935 Make_Subprogram_Renaming_Declaration
(Loc
,
2937 Copy_Specification
(Loc
,
2938 Specification
(Stub_Elements
.RPC_Receiver_Decl
)),
2939 Name
=> New_Occurrence_Of
(RPC_Receiver
, Loc
)));
2940 end Add_Obj_RPC_Receiver_Completion
;
2942 -----------------------
2943 -- Add_RACW_Features --
2944 -----------------------
2946 procedure Add_RACW_Features
2947 (RACW_Type
: Entity_Id
;
2948 Stub_Type
: Entity_Id
;
2949 Stub_Type_Access
: Entity_Id
;
2950 RPC_Receiver_Decl
: Node_Id
;
2951 Body_Decls
: List_Id
)
2953 RPC_Receiver
: Node_Id
;
2954 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
2957 Loc
:= Sloc
(RACW_Type
);
2961 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2962 -- of the corresponding distributed object type. We retrieve its
2963 -- address from the local proxy object.
2965 RPC_Receiver
:= Make_Selected_Component
(Loc
,
2967 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
), Object
),
2968 Selector_Name
=> Make_Identifier
(Loc
, Name_Receiver
));
2971 RPC_Receiver
:= Make_Attribute_Reference
(Loc
,
2972 Prefix
=> New_Occurrence_Of
(
2973 Defining_Unit_Name
(Specification
(RPC_Receiver_Decl
)), Loc
),
2974 Attribute_Name
=> Name_Address
);
2977 Add_RACW_Write_Attribute
2984 Add_RACW_Read_Attribute
2989 end Add_RACW_Features
;
2991 -----------------------------
2992 -- Add_RACW_Read_Attribute --
2993 -----------------------------
2995 procedure Add_RACW_Read_Attribute
2996 (RACW_Type
: Entity_Id
;
2997 Stub_Type
: Entity_Id
;
2998 Stub_Type_Access
: Entity_Id
;
2999 Body_Decls
: List_Id
)
3001 Proc_Decl
: Node_Id
;
3002 Attr_Decl
: Node_Id
;
3004 Body_Node
: Node_Id
;
3006 Statements
: constant List_Id
:= New_List
;
3008 Local_Statements
: List_Id
;
3009 Remote_Statements
: List_Id
;
3010 -- Various parts of the procedure
3012 Pnam
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
3013 Asynchronous_Flag
: constant Entity_Id
:=
3014 Asynchronous_Flags_Table
.Get
(RACW_Type
);
3015 pragma Assert
(Present
(Asynchronous_Flag
));
3017 -- Prepare local identifiers
3019 Source_Partition
: Entity_Id
;
3020 Source_Receiver
: Entity_Id
;
3021 Source_Address
: Entity_Id
;
3022 Local_Stub
: Entity_Id
;
3023 Stubbed_Result
: Entity_Id
;
3025 -- Start of processing for Add_RACW_Read_Attribute
3028 Build_Stream_Procedure
(Loc
,
3029 RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> True);
3030 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
3031 Copy_Specification
(Loc
, Specification
(Body_Node
)));
3034 Make_Attribute_Definition_Clause
(Loc
,
3035 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
3039 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
3041 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
3042 Insert_After
(Proc_Decl
, Attr_Decl
);
3044 if No
(Body_Decls
) then
3046 -- Case of processing an RACW type from another unit than the
3047 -- main one: do not generate a body.
3052 -- Prepare local identifiers
3054 Source_Partition
:= Make_Temporary
(Loc
, 'P');
3055 Source_Receiver
:= Make_Temporary
(Loc
, 'S');
3056 Source_Address
:= Make_Temporary
(Loc
, 'P');
3057 Local_Stub
:= Make_Temporary
(Loc
, 'L');
3058 Stubbed_Result
:= Make_Temporary
(Loc
, 'S');
3060 -- Generate object declarations
3063 Make_Object_Declaration
(Loc
,
3064 Defining_Identifier
=> Source_Partition
,
3065 Object_Definition
=>
3066 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
)),
3068 Make_Object_Declaration
(Loc
,
3069 Defining_Identifier
=> Source_Receiver
,
3070 Object_Definition
=>
3071 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3073 Make_Object_Declaration
(Loc
,
3074 Defining_Identifier
=> Source_Address
,
3075 Object_Definition
=>
3076 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3078 Make_Object_Declaration
(Loc
,
3079 Defining_Identifier
=> Local_Stub
,
3080 Aliased_Present
=> True,
3081 Object_Definition
=> New_Occurrence_Of
(Stub_Type
, Loc
)),
3083 Make_Object_Declaration
(Loc
,
3084 Defining_Identifier
=> Stubbed_Result
,
3085 Object_Definition
=>
3086 New_Occurrence_Of
(Stub_Type_Access
, Loc
),
3088 Make_Attribute_Reference
(Loc
,
3090 New_Occurrence_Of
(Local_Stub
, Loc
),
3092 Name_Unchecked_Access
)));
3094 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3096 Append_List_To
(Statements
, New_List
(
3097 Make_Attribute_Reference
(Loc
,
3099 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3100 Attribute_Name
=> Name_Read
,
3101 Expressions
=> New_List
(
3103 New_Occurrence_Of
(Source_Partition
, Loc
))),
3105 Make_Attribute_Reference
(Loc
,
3107 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3110 Expressions
=> New_List
(
3112 New_Occurrence_Of
(Source_Receiver
, Loc
))),
3114 Make_Attribute_Reference
(Loc
,
3116 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3119 Expressions
=> New_List
(
3121 New_Occurrence_Of
(Source_Address
, Loc
)))));
3123 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3125 Set_Etype
(Stubbed_Result
, Stub_Type_Access
);
3127 -- If the Address is Null_Address, then return a null object, unless
3128 -- RACW_Type is null-excluding, in which case unconditionally raise
3129 -- CONSTRAINT_ERROR instead.
3132 Zero_Statements
: List_Id
;
3133 -- Statements executed when a zero value is received
3136 if Can_Never_Be_Null
(RACW_Type
) then
3137 Zero_Statements
:= New_List
(
3138 Make_Raise_Constraint_Error
(Loc
,
3139 Reason
=> CE_Null_Not_Allowed
));
3141 Zero_Statements
:= New_List
(
3142 Make_Assignment_Statement
(Loc
,
3144 Expression
=> Make_Null
(Loc
)),
3145 Make_Simple_Return_Statement
(Loc
));
3148 Append_To
(Statements
,
3149 Make_Implicit_If_Statement
(RACW_Type
,
3152 Left_Opnd
=> New_Occurrence_Of
(Source_Address
, Loc
),
3153 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
3154 Then_Statements
=> Zero_Statements
));
3157 -- If the RACW denotes an object created on the current partition,
3158 -- Local_Statements will be executed. The real object will be used.
3160 Local_Statements
:= New_List
(
3161 Make_Assignment_Statement
(Loc
,
3164 Unchecked_Convert_To
(RACW_Type
,
3165 OK_Convert_To
(RTE
(RE_Address
),
3166 New_Occurrence_Of
(Source_Address
, Loc
)))));
3168 -- If the object is located on another partition, then a stub object
3169 -- will be created with all the information needed to rebuild the
3170 -- real object at the other end.
3172 Remote_Statements
:= New_List
(
3174 Make_Assignment_Statement
(Loc
,
3175 Name
=> Make_Selected_Component
(Loc
,
3176 Prefix
=> Stubbed_Result
,
3177 Selector_Name
=> Name_Origin
),
3179 New_Occurrence_Of
(Source_Partition
, Loc
)),
3181 Make_Assignment_Statement
(Loc
,
3182 Name
=> Make_Selected_Component
(Loc
,
3183 Prefix
=> Stubbed_Result
,
3184 Selector_Name
=> Name_Receiver
),
3186 New_Occurrence_Of
(Source_Receiver
, Loc
)),
3188 Make_Assignment_Statement
(Loc
,
3189 Name
=> Make_Selected_Component
(Loc
,
3190 Prefix
=> Stubbed_Result
,
3191 Selector_Name
=> Name_Addr
),
3193 New_Occurrence_Of
(Source_Address
, Loc
)));
3195 Append_To
(Remote_Statements
,
3196 Make_Assignment_Statement
(Loc
,
3197 Name
=> Make_Selected_Component
(Loc
,
3198 Prefix
=> Stubbed_Result
,
3199 Selector_Name
=> Name_Asynchronous
),
3201 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)));
3203 Append_List_To
(Remote_Statements
,
3204 Build_Get_Unique_RP_Call
(Loc
, Stubbed_Result
, Stub_Type
));
3205 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3206 -- set on the stub type if, and only if, the RACW type has a pragma
3207 -- Asynchronous. This is incorrect for RACWs that implement RAS
3208 -- types, because in that case the /designated subprogram/ (not the
3209 -- type) might be asynchronous, and that causes the stub to need to
3210 -- be asynchronous too. A solution is to transport a RAS as a struct
3211 -- containing a RACW and an asynchronous flag, and to properly alter
3212 -- the Asynchronous component in the stub type in the RAS's Input
3215 Append_To
(Remote_Statements
,
3216 Make_Assignment_Statement
(Loc
,
3218 Expression
=> Unchecked_Convert_To
(RACW_Type
,
3219 New_Occurrence_Of
(Stubbed_Result
, Loc
))));
3221 -- Distinguish between the local and remote cases, and execute the
3222 -- appropriate piece of code.
3224 Append_To
(Statements
,
3225 Make_Implicit_If_Statement
(RACW_Type
,
3229 Make_Function_Call
(Loc
,
3230 Name
=> New_Occurrence_Of
(
3231 RTE
(RE_Get_Local_Partition_Id
), Loc
)),
3232 Right_Opnd
=> New_Occurrence_Of
(Source_Partition
, Loc
)),
3233 Then_Statements
=> Local_Statements
,
3234 Else_Statements
=> Remote_Statements
));
3236 Set_Declarations
(Body_Node
, Decls
);
3237 Append_To
(Body_Decls
, Body_Node
);
3238 end Add_RACW_Read_Attribute
;
3240 ------------------------------
3241 -- Add_RACW_Write_Attribute --
3242 ------------------------------
3244 procedure Add_RACW_Write_Attribute
3245 (RACW_Type
: Entity_Id
;
3246 Stub_Type
: Entity_Id
;
3247 Stub_Type_Access
: Entity_Id
;
3248 RPC_Receiver
: Node_Id
;
3249 Body_Decls
: List_Id
)
3251 Body_Node
: Node_Id
;
3252 Proc_Decl
: Node_Id
;
3253 Attr_Decl
: Node_Id
;
3255 Statements
: constant List_Id
:= New_List
;
3256 Local_Statements
: List_Id
;
3257 Remote_Statements
: List_Id
;
3258 Null_Statements
: List_Id
;
3260 Pnam
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
3263 Build_Stream_Procedure
3264 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> False);
3266 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
3267 Copy_Specification
(Loc
, Specification
(Body_Node
)));
3270 Make_Attribute_Definition_Clause
(Loc
,
3271 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
3272 Chars
=> Name_Write
,
3275 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
3277 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
3278 Insert_After
(Proc_Decl
, Attr_Decl
);
3280 if No
(Body_Decls
) then
3284 -- Build the code fragment corresponding to the marshalling of a
3287 Local_Statements
:= New_List
(
3289 Pack_Entity_Into_Stream_Access
(Loc
,
3290 Stream
=> Stream_Parameter
,
3291 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
3293 Pack_Node_Into_Stream_Access
(Loc
,
3294 Stream
=> Stream_Parameter
,
3295 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
), RPC_Receiver
),
3296 Etyp
=> RTE
(RE_Unsigned_64
)),
3298 Pack_Node_Into_Stream_Access
(Loc
,
3299 Stream
=> Stream_Parameter
,
3300 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
),
3301 Make_Attribute_Reference
(Loc
,
3303 Make_Explicit_Dereference
(Loc
,
3305 Attribute_Name
=> Name_Address
)),
3306 Etyp
=> RTE
(RE_Unsigned_64
)));
3308 -- Build the code fragment corresponding to the marshalling of
3311 Remote_Statements
:= New_List
(
3312 Pack_Node_Into_Stream_Access
(Loc
,
3313 Stream
=> Stream_Parameter
,
3315 Make_Selected_Component
(Loc
,
3317 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3318 Selector_Name
=> Make_Identifier
(Loc
, Name_Origin
)),
3319 Etyp
=> RTE
(RE_Partition_ID
)),
3321 Pack_Node_Into_Stream_Access
(Loc
,
3322 Stream
=> Stream_Parameter
,
3324 Make_Selected_Component
(Loc
,
3326 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3327 Selector_Name
=> Make_Identifier
(Loc
, Name_Receiver
)),
3328 Etyp
=> RTE
(RE_Unsigned_64
)),
3330 Pack_Node_Into_Stream_Access
(Loc
,
3331 Stream
=> Stream_Parameter
,
3333 Make_Selected_Component
(Loc
,
3335 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3336 Selector_Name
=> Make_Identifier
(Loc
, Name_Addr
)),
3337 Etyp
=> RTE
(RE_Unsigned_64
)));
3339 -- Build code fragment corresponding to marshalling of a null object
3341 Null_Statements
:= New_List
(
3343 Pack_Entity_Into_Stream_Access
(Loc
,
3344 Stream
=> Stream_Parameter
,
3345 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
3347 Pack_Node_Into_Stream_Access
(Loc
,
3348 Stream
=> Stream_Parameter
,
3349 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
), RPC_Receiver
),
3350 Etyp
=> RTE
(RE_Unsigned_64
)),
3352 Pack_Node_Into_Stream_Access
(Loc
,
3353 Stream
=> Stream_Parameter
,
3354 Object
=> Make_Integer_Literal
(Loc
, Uint_0
),
3355 Etyp
=> RTE
(RE_Unsigned_64
)));
3357 Append_To
(Statements
,
3358 Make_Implicit_If_Statement
(RACW_Type
,
3361 Left_Opnd
=> Object
,
3362 Right_Opnd
=> Make_Null
(Loc
)),
3364 Then_Statements
=> Null_Statements
,
3366 Elsif_Parts
=> New_List
(
3367 Make_Elsif_Part
(Loc
,
3371 Make_Attribute_Reference
(Loc
,
3373 Attribute_Name
=> Name_Tag
),
3376 Make_Attribute_Reference
(Loc
,
3377 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
3378 Attribute_Name
=> Name_Tag
)),
3379 Then_Statements
=> Remote_Statements
)),
3380 Else_Statements
=> Local_Statements
));
3382 Append_To
(Body_Decls
, Body_Node
);
3383 end Add_RACW_Write_Attribute
;
3385 ------------------------
3386 -- Add_RAS_Access_TSS --
3387 ------------------------
3389 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
3390 Loc
: constant Source_Ptr
:= Sloc
(N
);
3392 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
3393 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
3394 -- Ras_Type is the access to subprogram type while Fat_Type is the
3395 -- corresponding record type.
3397 RACW_Type
: constant Entity_Id
:=
3398 Underlying_RACW_Type
(Ras_Type
);
3399 Desig
: constant Entity_Id
:=
3400 Etype
(Designated_Type
(RACW_Type
));
3402 Stub_Elements
: constant Stub_Structure
:=
3403 Stubs_Table
.Get
(Desig
);
3404 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
3406 Proc
: constant Entity_Id
:=
3407 Make_Defining_Identifier
(Loc
,
3408 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
3410 Proc_Spec
: Node_Id
;
3412 -- Formal parameters
3414 Package_Name
: constant Entity_Id
:=
3415 Make_Defining_Identifier
(Loc
,
3419 Subp_Id
: constant Entity_Id
:=
3420 Make_Defining_Identifier
(Loc
,
3422 -- Target subprogram
3424 Asynch_P
: constant Entity_Id
:=
3425 Make_Defining_Identifier
(Loc
,
3426 Chars
=> Name_Asynchronous
);
3427 -- Is the procedure to which the 'Access applies asynchronous?
3429 All_Calls_Remote
: constant Entity_Id
:=
3430 Make_Defining_Identifier
(Loc
,
3431 Chars
=> Name_All_Calls_Remote
);
3432 -- True if an All_Calls_Remote pragma applies to the RCI unit
3433 -- that contains the subprogram.
3435 -- Common local variables
3437 Proc_Decls
: List_Id
;
3438 Proc_Statements
: List_Id
;
3440 Origin
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
3442 -- Additional local variables for the local case
3444 Proxy_Addr
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
3446 -- Additional local variables for the remote case
3448 Local_Stub
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
3449 Stub_Ptr
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
3452 (Field_Name
: Name_Id
;
3453 Value
: Node_Id
) return Node_Id
;
3454 -- Construct an assignment that sets the named component in the
3462 (Field_Name
: Name_Id
;
3463 Value
: Node_Id
) return Node_Id
3467 Make_Assignment_Statement
(Loc
,
3469 Make_Selected_Component
(Loc
,
3471 Selector_Name
=> Field_Name
),
3472 Expression
=> Value
);
3475 -- Start of processing for Add_RAS_Access_TSS
3478 Proc_Decls
:= New_List
(
3480 -- Common declarations
3482 Make_Object_Declaration
(Loc
,
3483 Defining_Identifier
=> Origin
,
3484 Constant_Present
=> True,
3485 Object_Definition
=>
3486 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3488 Make_Function_Call
(Loc
,
3490 New_Occurrence_Of
(RTE
(RE_Get_Active_Partition_Id
), Loc
),
3491 Parameter_Associations
=> New_List
(
3492 New_Occurrence_Of
(Package_Name
, Loc
)))),
3494 -- Declaration use only in the local case: proxy address
3496 Make_Object_Declaration
(Loc
,
3497 Defining_Identifier
=> Proxy_Addr
,
3498 Object_Definition
=>
3499 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3501 -- Declarations used only in the remote case: stub object and
3504 Make_Object_Declaration
(Loc
,
3505 Defining_Identifier
=> Local_Stub
,
3506 Aliased_Present
=> True,
3507 Object_Definition
=>
3508 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
3510 Make_Object_Declaration
(Loc
,
3511 Defining_Identifier
=>
3513 Object_Definition
=>
3514 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
3516 Make_Attribute_Reference
(Loc
,
3517 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
3518 Attribute_Name
=> Name_Unchecked_Access
)));
3520 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
3522 -- Build_Get_Unique_RP_Call needs above information
3524 -- Note: Here we assume that the Fat_Type is a record
3525 -- containing just a pointer to a proxy or stub object.
3527 Proc_Statements
:= New_List
(
3531 -- Get_RAS_Info (Pkg, Subp, PA);
3532 -- if Origin = Local_Partition_Id
3533 -- and then not All_Calls_Remote
3535 -- return Fat_Type!(PA);
3538 Make_Procedure_Call_Statement
(Loc
,
3539 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
3540 Parameter_Associations
=> New_List
(
3541 New_Occurrence_Of
(Package_Name
, Loc
),
3542 New_Occurrence_Of
(Subp_Id
, Loc
),
3543 New_Occurrence_Of
(Proxy_Addr
, Loc
))),
3545 Make_Implicit_If_Statement
(N
,
3551 New_Occurrence_Of
(Origin
, Loc
),
3553 Make_Function_Call
(Loc
,
3555 RTE
(RE_Get_Local_Partition_Id
), Loc
))),
3559 New_Occurrence_Of
(All_Calls_Remote
, Loc
))),
3561 Then_Statements
=> New_List
(
3562 Make_Simple_Return_Statement
(Loc
,
3563 Unchecked_Convert_To
(Fat_Type
,
3564 OK_Convert_To
(RTE
(RE_Address
),
3565 New_Occurrence_Of
(Proxy_Addr
, Loc
)))))),
3567 Set_Field
(Name_Origin
,
3568 New_Occurrence_Of
(Origin
, Loc
)),
3570 Set_Field
(Name_Receiver
,
3571 Make_Function_Call
(Loc
,
3573 New_Occurrence_Of
(RTE
(RE_Get_RCI_Package_Receiver
), Loc
),
3574 Parameter_Associations
=> New_List
(
3575 New_Occurrence_Of
(Package_Name
, Loc
)))),
3577 Set_Field
(Name_Addr
, New_Occurrence_Of
(Proxy_Addr
, Loc
)),
3579 -- E.4.1(9) A remote call is asynchronous if it is a call to
3580 -- a procedure or a call through a value of an access-to-procedure
3581 -- type to which a pragma Asynchronous applies.
3583 -- Asynch_P is true when the procedure is asynchronous;
3584 -- Asynch_T is true when the type is asynchronous.
3586 Set_Field
(Name_Asynchronous
,
3588 New_Occurrence_Of
(Asynch_P
, Loc
),
3589 New_Occurrence_Of
(Boolean_Literals
(
3590 Is_Asynchronous
(Ras_Type
)), Loc
))));
3592 Append_List_To
(Proc_Statements
,
3593 Build_Get_Unique_RP_Call
3594 (Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
3596 -- Return the newly created value
3598 Append_To
(Proc_Statements
,
3599 Make_Simple_Return_Statement
(Loc
,
3601 Unchecked_Convert_To
(Fat_Type
,
3602 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
3605 Make_Function_Specification
(Loc
,
3606 Defining_Unit_Name
=> Proc
,
3607 Parameter_Specifications
=> New_List
(
3608 Make_Parameter_Specification
(Loc
,
3609 Defining_Identifier
=> Package_Name
,
3611 New_Occurrence_Of
(Standard_String
, Loc
)),
3613 Make_Parameter_Specification
(Loc
,
3614 Defining_Identifier
=> Subp_Id
,
3616 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
)),
3618 Make_Parameter_Specification
(Loc
,
3619 Defining_Identifier
=> Asynch_P
,
3621 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3623 Make_Parameter_Specification
(Loc
,
3624 Defining_Identifier
=> All_Calls_Remote
,
3626 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
3628 Result_Definition
=>
3629 New_Occurrence_Of
(Fat_Type
, Loc
));
3631 -- Set the kind and return type of the function to prevent
3632 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3634 Set_Ekind
(Proc
, E_Function
);
3635 Set_Etype
(Proc
, Fat_Type
);
3638 Make_Subprogram_Body
(Loc
,
3639 Specification
=> Proc_Spec
,
3640 Declarations
=> Proc_Decls
,
3641 Handled_Statement_Sequence
=>
3642 Make_Handled_Sequence_Of_Statements
(Loc
,
3643 Statements
=> Proc_Statements
)));
3645 Set_TSS
(Fat_Type
, Proc
);
3646 end Add_RAS_Access_TSS
;
3648 -----------------------
3649 -- Add_RAST_Features --
3650 -----------------------
3652 procedure Add_RAST_Features
3653 (Vis_Decl
: Node_Id
;
3654 RAS_Type
: Entity_Id
)
3656 pragma Unreferenced
(RAS_Type
);
3658 Add_RAS_Access_TSS
(Vis_Decl
);
3659 end Add_RAST_Features
;
3661 -----------------------------------------
3662 -- Add_Receiving_Stubs_To_Declarations --
3663 -----------------------------------------
3665 procedure Add_Receiving_Stubs_To_Declarations
3666 (Pkg_Spec
: Node_Id
;
3670 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
3672 Request_Parameter
: Node_Id
;
3674 Pkg_RPC_Receiver
: constant Entity_Id
:=
3675 Make_Temporary
(Loc
, 'H');
3676 Pkg_RPC_Receiver_Statements
: List_Id
;
3677 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
3678 Pkg_RPC_Receiver_Body
: Node_Id
;
3679 -- A Pkg_RPC_Receiver is built to decode the request
3681 Lookup_RAS_Info
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
3682 -- A remote subprogram is created to allow peers to look up RAS
3683 -- information using subprogram ids.
3685 Subp_Id
: Entity_Id
;
3686 Subp_Index
: Entity_Id
;
3687 -- Subprogram_Id as read from the incoming stream
3689 Current_Declaration
: Node_Id
;
3690 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
3691 Current_Stubs
: Node_Id
;
3693 Subp_Info_Array
: constant Entity_Id
:= Make_Temporary
(Loc
, 'I');
3694 Subp_Info_List
: constant List_Id
:= New_List
;
3696 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
3698 All_Calls_Remote_E
: Entity_Id
;
3699 Proxy_Object_Addr
: Entity_Id
;
3701 procedure Append_Stubs_To
3702 (RPC_Receiver_Cases
: List_Id
;
3704 Subprogram_Number
: Int
);
3705 -- Add one case to the specified RPC receiver case list
3706 -- associating Subprogram_Number with the subprogram declared
3707 -- by Declaration, for which we have receiving stubs in Stubs.
3709 ---------------------
3710 -- Append_Stubs_To --
3711 ---------------------
3713 procedure Append_Stubs_To
3714 (RPC_Receiver_Cases
: List_Id
;
3716 Subprogram_Number
: Int
)
3719 Append_To
(RPC_Receiver_Cases
,
3720 Make_Case_Statement_Alternative
(Loc
,
3722 New_List
(Make_Integer_Literal
(Loc
, Subprogram_Number
)),
3725 Make_Procedure_Call_Statement
(Loc
,
3727 New_Occurrence_Of
(Defining_Entity
(Stubs
), Loc
),
3728 Parameter_Associations
=> New_List
(
3729 New_Occurrence_Of
(Request_Parameter
, Loc
))))));
3730 end Append_Stubs_To
;
3732 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3735 -- Building receiving stubs consist in several operations:
3737 -- - a package RPC receiver must be built. This subprogram
3738 -- will get a Subprogram_Id from the incoming stream
3739 -- and will dispatch the call to the right subprogram;
3741 -- - a receiving stub for each subprogram visible in the package
3742 -- spec. This stub will read all the parameters from the stream,
3743 -- and put the result as well as the exception occurrence in the
3746 -- - a dummy package with an empty spec and a body made of an
3747 -- elaboration part, whose job is to register the receiving
3748 -- part of this RCI package on the name server. This is done
3749 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3751 Build_RPC_Receiver_Body
(
3752 RPC_Receiver
=> Pkg_RPC_Receiver
,
3753 Request
=> Request_Parameter
,
3755 Subp_Index
=> Subp_Index
,
3756 Stmts
=> Pkg_RPC_Receiver_Statements
,
3757 Decl
=> Pkg_RPC_Receiver_Body
);
3758 pragma Assert
(Subp_Id
= Subp_Index
);
3760 -- A null subp_id denotes a call through a RAS, in which case the
3761 -- next Uint_64 element in the stream is the address of the local
3762 -- proxy object, from which we can retrieve the actual subprogram id.
3764 Append_To
(Pkg_RPC_Receiver_Statements
,
3765 Make_Implicit_If_Statement
(Pkg_Spec
,
3768 New_Occurrence_Of
(Subp_Id
, Loc
),
3769 Make_Integer_Literal
(Loc
, 0)),
3771 Then_Statements
=> New_List
(
3772 Make_Assignment_Statement
(Loc
,
3774 New_Occurrence_Of
(Subp_Id
, Loc
),
3777 Make_Selected_Component
(Loc
,
3779 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
3780 OK_Convert_To
(RTE
(RE_Address
),
3781 Make_Attribute_Reference
(Loc
,
3783 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3786 Expressions
=> New_List
(
3787 Make_Selected_Component
(Loc
,
3788 Prefix
=> Request_Parameter
,
3789 Selector_Name
=> Name_Params
))))),
3792 Make_Identifier
(Loc
, Name_Subp_Id
))))));
3794 -- Build a subprogram for RAS information lookups
3796 Current_Declaration
:=
3797 Make_Subprogram_Declaration
(Loc
,
3799 Make_Function_Specification
(Loc
,
3800 Defining_Unit_Name
=>
3802 Parameter_Specifications
=> New_List
(
3803 Make_Parameter_Specification
(Loc
,
3804 Defining_Identifier
=>
3805 Make_Defining_Identifier
(Loc
, Name_Subp_Id
),
3809 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))),
3810 Result_Definition
=>
3811 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)));
3813 Append_To
(Decls
, Current_Declaration
);
3814 Analyze
(Current_Declaration
);
3816 Current_Stubs
:= Build_Subprogram_Receiving_Stubs
3817 (Vis_Decl
=> Current_Declaration
,
3818 Asynchronous
=> False);
3819 Append_To
(Decls
, Current_Stubs
);
3820 Analyze
(Current_Stubs
);
3822 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3825 Subprogram_Number
=> 1);
3827 -- For each subprogram, the receiving stub will be built and a
3828 -- case statement will be made on the Subprogram_Id to dispatch
3829 -- to the right subprogram.
3831 All_Calls_Remote_E
:=
3833 (Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
3835 Overload_Counter_Table
.Reset
;
3837 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
3838 while Present
(Current_Declaration
) loop
3839 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
3840 and then Comes_From_Source
(Current_Declaration
)
3843 Loc
: constant Source_Ptr
:= Sloc
(Current_Declaration
);
3844 -- While specifically processing Current_Declaration, use
3845 -- its Sloc as the location of all generated nodes.
3847 Subp_Def
: constant Entity_Id
:=
3849 (Specification
(Current_Declaration
));
3851 Subp_Val
: String_Id
;
3852 pragma Warnings
(Off
, Subp_Val
);
3855 -- Build receiving stub
3858 Build_Subprogram_Receiving_Stubs
3859 (Vis_Decl
=> Current_Declaration
,
3861 Nkind
(Specification
(Current_Declaration
)) =
3862 N_Procedure_Specification
3863 and then Is_Asynchronous
(Subp_Def
));
3865 Append_To
(Decls
, Current_Stubs
);
3866 Analyze
(Current_Stubs
);
3870 Add_RAS_Proxy_And_Analyze
(Decls
,
3871 Vis_Decl
=> Current_Declaration
,
3872 All_Calls_Remote_E
=> All_Calls_Remote_E
,
3873 Proxy_Object_Addr
=> Proxy_Object_Addr
);
3875 -- Compute distribution identifier
3877 Assign_Subprogram_Identifier
3879 Current_Subprogram_Number
,
3883 (Current_Subprogram_Number
= Get_Subprogram_Id
(Subp_Def
));
3885 -- Add subprogram descriptor (RCI_Subp_Info) to the
3886 -- subprograms table for this receiver. The aggregate
3887 -- below must be kept consistent with the declaration
3888 -- of type RCI_Subp_Info in System.Partition_Interface.
3890 Append_To
(Subp_Info_List
,
3891 Make_Component_Association
(Loc
,
3892 Choices
=> New_List
(
3893 Make_Integer_Literal
(Loc
,
3894 Current_Subprogram_Number
)),
3897 Make_Aggregate
(Loc
,
3898 Component_Associations
=> New_List
(
3899 Make_Component_Association
(Loc
,
3900 Choices
=> New_List
(
3901 Make_Identifier
(Loc
, Name_Addr
)),
3904 Proxy_Object_Addr
, Loc
))))));
3906 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3907 Stubs
=> Current_Stubs
,
3908 Subprogram_Number
=> Current_Subprogram_Number
);
3911 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
3914 Next
(Current_Declaration
);
3917 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3918 -- rather than raising an exception since we do not want someone
3919 -- to crash a remote partition by sending invalid subprogram ids.
3920 -- This is consistent with the other parts of the case statement
3921 -- since even in presence of incorrect parameters in the stream,
3922 -- every exception will be caught and (if the subprogram is not an
3923 -- APC) put into the result stream and sent away.
3925 Append_To
(Pkg_RPC_Receiver_Cases
,
3926 Make_Case_Statement_Alternative
(Loc
,
3927 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
3928 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
3930 Append_To
(Pkg_RPC_Receiver_Statements
,
3931 Make_Case_Statement
(Loc
,
3932 Expression
=> New_Occurrence_Of
(Subp_Id
, Loc
),
3933 Alternatives
=> Pkg_RPC_Receiver_Cases
));
3936 Make_Object_Declaration
(Loc
,
3937 Defining_Identifier
=> Subp_Info_Array
,
3938 Constant_Present
=> True,
3939 Aliased_Present
=> True,
3940 Object_Definition
=>
3941 Make_Subtype_Indication
(Loc
,
3943 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
3945 Make_Index_Or_Discriminant_Constraint
(Loc
,
3948 Low_Bound
=> Make_Integer_Literal
(Loc
,
3949 First_RCI_Subprogram_Id
),
3951 Make_Integer_Literal
(Loc
,
3953 First_RCI_Subprogram_Id
3954 + List_Length
(Subp_Info_List
) - 1)))))));
3956 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
3957 -- has zero length, and the declaration is for an empty array, in
3958 -- which case no initialization aggregate must be generated.
3960 if Present
(First
(Subp_Info_List
)) then
3961 Set_Expression
(Last
(Decls
),
3962 Make_Aggregate
(Loc
,
3963 Component_Associations
=> Subp_Info_List
));
3965 -- No initialization provided: remove CONSTANT so that the
3966 -- declaration is not an incomplete deferred constant.
3969 Set_Constant_Present
(Last
(Decls
), False);
3972 Analyze
(Last
(Decls
));
3975 Subp_Info_Addr
: Node_Id
;
3976 -- Return statement for Lookup_RAS_Info: address of the subprogram
3977 -- information record for the requested subprogram id.
3980 if Present
(First
(Subp_Info_List
)) then
3982 Make_Selected_Component
(Loc
,
3984 Make_Indexed_Component
(Loc
,
3985 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
3986 Expressions
=> New_List
(
3987 Convert_To
(Standard_Integer
,
3988 Make_Identifier
(Loc
, Name_Subp_Id
)))),
3989 Selector_Name
=> Make_Identifier
(Loc
, Name_Addr
));
3991 -- Case of no visible subprogram: just raise Constraint_Error, we
3992 -- know for sure we got junk from a remote partition.
3996 Make_Raise_Constraint_Error
(Loc
,
3997 Reason
=> CE_Range_Check_Failed
);
3998 Set_Etype
(Subp_Info_Addr
, RTE
(RE_Unsigned_64
));
4002 Make_Subprogram_Body
(Loc
,
4004 Copy_Specification
(Loc
, Parent
(Lookup_RAS_Info
)),
4005 Declarations
=> No_List
,
4006 Handled_Statement_Sequence
=>
4007 Make_Handled_Sequence_Of_Statements
(Loc
,
4008 Statements
=> New_List
(
4009 Make_Simple_Return_Statement
(Loc
,
4012 (RTE
(RE_Unsigned_64
), Subp_Info_Addr
))))));
4015 Analyze
(Last
(Decls
));
4017 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
4018 Analyze
(Last
(Decls
));
4020 Get_Library_Unit_Name_String
(Pkg_Spec
);
4024 Append_To
(Register_Pkg_Actuals
,
4025 Make_String_Literal
(Loc
,
4026 Strval
=> String_From_Name_Buffer
));
4030 Append_To
(Register_Pkg_Actuals
,
4031 Make_Attribute_Reference
(Loc
,
4032 Prefix
=> New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
4033 Attribute_Name
=> Name_Unrestricted_Access
));
4037 Append_To
(Register_Pkg_Actuals
,
4038 Make_Attribute_Reference
(Loc
,
4040 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
4041 Attribute_Name
=> Name_Version
));
4045 Append_To
(Register_Pkg_Actuals
,
4046 Make_Attribute_Reference
(Loc
,
4047 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
4048 Attribute_Name
=> Name_Address
));
4052 Append_To
(Register_Pkg_Actuals
,
4053 Make_Attribute_Reference
(Loc
,
4054 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
4055 Attribute_Name
=> Name_Length
));
4057 -- Generate the call
4060 Make_Procedure_Call_Statement
(Loc
,
4062 New_Occurrence_Of
(RTE
(RE_Register_Receiving_Stub
), Loc
),
4063 Parameter_Associations
=> Register_Pkg_Actuals
));
4064 Analyze
(Last
(Stmts
));
4065 end Add_Receiving_Stubs_To_Declarations
;
4067 ---------------------------------
4068 -- Build_General_Calling_Stubs --
4069 ---------------------------------
4071 procedure Build_General_Calling_Stubs
4073 Statements
: List_Id
;
4074 Target_Partition
: Entity_Id
;
4075 Target_RPC_Receiver
: Node_Id
;
4076 Subprogram_Id
: Node_Id
;
4077 Asynchronous
: Node_Id
:= Empty
;
4078 Is_Known_Asynchronous
: Boolean := False;
4079 Is_Known_Non_Asynchronous
: Boolean := False;
4080 Is_Function
: Boolean;
4082 Stub_Type
: Entity_Id
:= Empty
;
4083 RACW_Type
: Entity_Id
:= Empty
;
4086 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
4088 Stream_Parameter
: Node_Id
;
4089 -- Name of the stream used to transmit parameters to the remote
4092 Result_Parameter
: Node_Id
;
4093 -- Name of the result parameter (in non-APC cases) which get the
4094 -- result of the remote subprogram.
4096 Exception_Return_Parameter
: Node_Id
;
4097 -- Name of the parameter which will hold the exception sent by the
4098 -- remote subprogram.
4100 Current_Parameter
: Node_Id
;
4101 -- Current parameter being handled
4103 Ordered_Parameters_List
: constant List_Id
:=
4104 Build_Ordered_Parameters_List
(Spec
);
4106 Asynchronous_Statements
: List_Id
:= No_List
;
4107 Non_Asynchronous_Statements
: List_Id
:= No_List
;
4108 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4110 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4111 -- List of statements for extra formal parameters. It will appear
4112 -- after the regular statements for writing out parameters.
4114 pragma Unreferenced
(RACW_Type
);
4115 -- Used only for the PolyORB case
4118 -- The general form of a calling stub for a given subprogram is:
4120 -- procedure X (...) is P : constant Partition_ID :=
4121 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4122 -- System.RPC.Params_Stream_Type (0); begin
4123 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4124 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4125 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4126 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4128 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4130 -- There are some variations: Do_APC is called for an asynchronous
4131 -- procedure and the part after the call is completely ommitted as
4132 -- well as the declaration of Result. For a function call, 'Input is
4133 -- always used to read the result even if it is constrained.
4135 Stream_Parameter
:= Make_Temporary
(Loc
, 'S');
4138 Make_Object_Declaration
(Loc
,
4139 Defining_Identifier
=> Stream_Parameter
,
4140 Aliased_Present
=> True,
4141 Object_Definition
=>
4142 Make_Subtype_Indication
(Loc
,
4144 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
4146 Make_Index_Or_Discriminant_Constraint
(Loc
,
4148 New_List
(Make_Integer_Literal
(Loc
, 0))))));
4150 if not Is_Known_Asynchronous
then
4151 Result_Parameter
:= Make_Temporary
(Loc
, 'R');
4154 Make_Object_Declaration
(Loc
,
4155 Defining_Identifier
=> Result_Parameter
,
4156 Aliased_Present
=> True,
4157 Object_Definition
=>
4158 Make_Subtype_Indication
(Loc
,
4160 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
4162 Make_Index_Or_Discriminant_Constraint
(Loc
,
4164 New_List
(Make_Integer_Literal
(Loc
, 0))))));
4166 Exception_Return_Parameter
:= Make_Temporary
(Loc
, 'E');
4169 Make_Object_Declaration
(Loc
,
4170 Defining_Identifier
=> Exception_Return_Parameter
,
4171 Object_Definition
=>
4172 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
4175 Result_Parameter
:= Empty
;
4176 Exception_Return_Parameter
:= Empty
;
4179 -- Put first the RPC receiver corresponding to the remote package
4181 Append_To
(Statements
,
4182 Make_Attribute_Reference
(Loc
,
4184 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
4185 Attribute_Name
=> Name_Write
,
4186 Expressions
=> New_List
(
4187 Make_Attribute_Reference
(Loc
,
4188 Prefix
=> New_Occurrence_Of
(Stream_Parameter
, Loc
),
4189 Attribute_Name
=> Name_Access
),
4190 Target_RPC_Receiver
)));
4192 -- Then put the Subprogram_Id of the subprogram we want to call in
4195 Append_To
(Statements
,
4196 Make_Attribute_Reference
(Loc
,
4197 Prefix
=> New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4198 Attribute_Name
=> Name_Write
,
4199 Expressions
=> New_List
(
4200 Make_Attribute_Reference
(Loc
,
4201 Prefix
=> New_Occurrence_Of
(Stream_Parameter
, Loc
),
4202 Attribute_Name
=> Name_Access
),
4205 Current_Parameter
:= First
(Ordered_Parameters_List
);
4206 while Present
(Current_Parameter
) loop
4208 Typ
: constant Node_Id
:=
4209 Parameter_Type
(Current_Parameter
);
4211 Constrained
: Boolean;
4213 Extra_Parameter
: Entity_Id
;
4216 if Is_RACW_Controlling_Formal
4217 (Current_Parameter
, Stub_Type
)
4219 -- In the case of a controlling formal argument, we marshall
4220 -- its addr field rather than the local stub.
4222 Append_To
(Statements
,
4223 Pack_Node_Into_Stream
(Loc
,
4224 Stream
=> Stream_Parameter
,
4226 Make_Selected_Component
(Loc
,
4228 Defining_Identifier
(Current_Parameter
),
4229 Selector_Name
=> Name_Addr
),
4230 Etyp
=> RTE
(RE_Unsigned_64
)));
4235 (Defining_Identifier
(Current_Parameter
), Loc
);
4237 -- Access type parameters are transmitted as in out
4238 -- parameters. However, a dereference is needed so that
4239 -- we marshall the designated object.
4241 if Nkind
(Typ
) = N_Access_Definition
then
4242 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4243 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4245 Etyp
:= Etype
(Typ
);
4248 Constrained
:= not Transmit_As_Unconstrained
(Etyp
);
4250 -- Any parameter but unconstrained out parameters are
4251 -- transmitted to the peer.
4253 if In_Present
(Current_Parameter
)
4254 or else not Out_Present
(Current_Parameter
)
4255 or else not Constrained
4257 Append_To
(Statements
,
4258 Make_Attribute_Reference
(Loc
,
4259 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4261 Output_From_Constrained
(Constrained
),
4262 Expressions
=> New_List
(
4263 Make_Attribute_Reference
(Loc
,
4265 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4266 Attribute_Name
=> Name_Access
),
4271 -- If the current parameter has a dynamic constrained status,
4272 -- then this status is transmitted as well.
4273 -- This should be done for accessibility as well ???
4275 if Nkind
(Typ
) /= N_Access_Definition
4276 and then Need_Extra_Constrained
(Current_Parameter
)
4278 -- In this block, we do not use the extra formal that has
4279 -- been created because it does not exist at the time of
4280 -- expansion when building calling stubs for remote access
4281 -- to subprogram types. We create an extra variable of this
4282 -- type and push it in the stream after the regular
4285 Extra_Parameter
:= Make_Temporary
(Loc
, 'P');
4288 Make_Object_Declaration
(Loc
,
4289 Defining_Identifier
=> Extra_Parameter
,
4290 Constant_Present
=> True,
4291 Object_Definition
=>
4292 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4294 Make_Attribute_Reference
(Loc
,
4297 Defining_Identifier
(Current_Parameter
), Loc
),
4298 Attribute_Name
=> Name_Constrained
)));
4300 Append_To
(Extra_Formal_Statements
,
4301 Make_Attribute_Reference
(Loc
,
4303 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4304 Attribute_Name
=> Name_Write
,
4305 Expressions
=> New_List
(
4306 Make_Attribute_Reference
(Loc
,
4309 (Stream_Parameter
, Loc
), Attribute_Name
=>
4311 New_Occurrence_Of
(Extra_Parameter
, Loc
))));
4314 Next
(Current_Parameter
);
4318 -- Append the formal statements list to the statements
4320 Append_List_To
(Statements
, Extra_Formal_Statements
);
4322 if not Is_Known_Non_Asynchronous
then
4324 -- Build the call to System.RPC.Do_APC
4326 Asynchronous_Statements
:= New_List
(
4327 Make_Procedure_Call_Statement
(Loc
,
4329 New_Occurrence_Of
(RTE
(RE_Do_Apc
), Loc
),
4330 Parameter_Associations
=> New_List
(
4331 New_Occurrence_Of
(Target_Partition
, Loc
),
4332 Make_Attribute_Reference
(Loc
,
4334 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4335 Attribute_Name
=> Name_Access
))));
4337 Asynchronous_Statements
:= No_List
;
4340 if not Is_Known_Asynchronous
then
4342 -- Build the call to System.RPC.Do_RPC
4344 Non_Asynchronous_Statements
:= New_List
(
4345 Make_Procedure_Call_Statement
(Loc
,
4347 New_Occurrence_Of
(RTE
(RE_Do_Rpc
), Loc
),
4348 Parameter_Associations
=> New_List
(
4349 New_Occurrence_Of
(Target_Partition
, Loc
),
4351 Make_Attribute_Reference
(Loc
,
4353 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4354 Attribute_Name
=> Name_Access
),
4356 Make_Attribute_Reference
(Loc
,
4358 New_Occurrence_Of
(Result_Parameter
, Loc
),
4359 Attribute_Name
=> Name_Access
))));
4361 -- Read the exception occurrence from the result stream and
4362 -- reraise it. It does no harm if this is a Null_Occurrence since
4363 -- this does nothing.
4365 Append_To
(Non_Asynchronous_Statements
,
4366 Make_Attribute_Reference
(Loc
,
4368 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4370 Attribute_Name
=> Name_Read
,
4372 Expressions
=> New_List
(
4373 Make_Attribute_Reference
(Loc
,
4375 New_Occurrence_Of
(Result_Parameter
, Loc
),
4376 Attribute_Name
=> Name_Access
),
4377 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
4379 Append_To
(Non_Asynchronous_Statements
,
4380 Make_Procedure_Call_Statement
(Loc
,
4382 New_Occurrence_Of
(RTE
(RE_Reraise_Occurrence
), Loc
),
4383 Parameter_Associations
=> New_List
(
4384 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
4388 -- If this is a function call, then read the value and return
4389 -- it. The return value is written/read using 'Output/'Input.
4391 Append_To
(Non_Asynchronous_Statements
,
4392 Make_Tag_Check
(Loc
,
4393 Make_Simple_Return_Statement
(Loc
,
4395 Make_Attribute_Reference
(Loc
,
4398 Etype
(Result_Definition
(Spec
)), Loc
),
4400 Attribute_Name
=> Name_Input
,
4402 Expressions
=> New_List
(
4403 Make_Attribute_Reference
(Loc
,
4405 New_Occurrence_Of
(Result_Parameter
, Loc
),
4406 Attribute_Name
=> Name_Access
))))));
4409 -- Loop around parameters and assign out (or in out)
4410 -- parameters. In the case of RACW, controlling arguments
4411 -- cannot possibly have changed since they are remote, so
4412 -- we do not read them from the stream.
4414 Current_Parameter
:= First
(Ordered_Parameters_List
);
4415 while Present
(Current_Parameter
) loop
4417 Typ
: constant Node_Id
:=
4418 Parameter_Type
(Current_Parameter
);
4425 (Defining_Identifier
(Current_Parameter
), Loc
);
4427 if Nkind
(Typ
) = N_Access_Definition
then
4428 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4429 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4431 Etyp
:= Etype
(Typ
);
4434 if (Out_Present
(Current_Parameter
)
4435 or else Nkind
(Typ
) = N_Access_Definition
)
4436 and then Etyp
/= Stub_Type
4438 Append_To
(Non_Asynchronous_Statements
,
4439 Make_Attribute_Reference
(Loc
,
4441 New_Occurrence_Of
(Etyp
, Loc
),
4443 Attribute_Name
=> Name_Read
,
4445 Expressions
=> New_List
(
4446 Make_Attribute_Reference
(Loc
,
4448 New_Occurrence_Of
(Result_Parameter
, Loc
),
4449 Attribute_Name
=> Name_Access
),
4454 Next
(Current_Parameter
);
4459 if Is_Known_Asynchronous
then
4460 Append_List_To
(Statements
, Asynchronous_Statements
);
4462 elsif Is_Known_Non_Asynchronous
then
4463 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
4466 pragma Assert
(Present
(Asynchronous
));
4467 Prepend_To
(Asynchronous_Statements
,
4468 Make_Attribute_Reference
(Loc
,
4469 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4470 Attribute_Name
=> Name_Write
,
4471 Expressions
=> New_List
(
4472 Make_Attribute_Reference
(Loc
,
4474 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4475 Attribute_Name
=> Name_Access
),
4476 New_Occurrence_Of
(Standard_True
, Loc
))));
4478 Prepend_To
(Non_Asynchronous_Statements
,
4479 Make_Attribute_Reference
(Loc
,
4480 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4481 Attribute_Name
=> Name_Write
,
4482 Expressions
=> New_List
(
4483 Make_Attribute_Reference
(Loc
,
4485 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4486 Attribute_Name
=> Name_Access
),
4487 New_Occurrence_Of
(Standard_False
, Loc
))));
4489 Append_To
(Statements
,
4490 Make_Implicit_If_Statement
(Nod
,
4491 Condition
=> Asynchronous
,
4492 Then_Statements
=> Asynchronous_Statements
,
4493 Else_Statements
=> Non_Asynchronous_Statements
));
4495 end Build_General_Calling_Stubs
;
4497 -----------------------------
4498 -- Build_RPC_Receiver_Body --
4499 -----------------------------
4501 procedure Build_RPC_Receiver_Body
4502 (RPC_Receiver
: Entity_Id
;
4503 Request
: out Entity_Id
;
4504 Subp_Id
: out Entity_Id
;
4505 Subp_Index
: out Entity_Id
;
4506 Stmts
: out List_Id
;
4509 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
4511 RPC_Receiver_Spec
: Node_Id
;
4512 RPC_Receiver_Decls
: List_Id
;
4515 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
4517 RPC_Receiver_Spec
:=
4518 Build_RPC_Receiver_Specification
4519 (RPC_Receiver
=> RPC_Receiver
,
4520 Request_Parameter
=> Request
);
4522 Subp_Id
:= Make_Temporary
(Loc
, 'P');
4523 Subp_Index
:= Subp_Id
;
4525 -- Subp_Id may not be a constant, because in the case of the RPC
4526 -- receiver for an RCI package, when a call is received from a RAS
4527 -- dereference, it will be assigned during subsequent processing.
4529 RPC_Receiver_Decls
:= New_List
(
4530 Make_Object_Declaration
(Loc
,
4531 Defining_Identifier
=> Subp_Id
,
4532 Object_Definition
=>
4533 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4535 Make_Attribute_Reference
(Loc
,
4537 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4538 Attribute_Name
=> Name_Input
,
4539 Expressions
=> New_List
(
4540 Make_Selected_Component
(Loc
,
4542 Selector_Name
=> Name_Params
)))));
4547 Make_Subprogram_Body
(Loc
,
4548 Specification
=> RPC_Receiver_Spec
,
4549 Declarations
=> RPC_Receiver_Decls
,
4550 Handled_Statement_Sequence
=>
4551 Make_Handled_Sequence_Of_Statements
(Loc
,
4552 Statements
=> Stmts
));
4553 end Build_RPC_Receiver_Body
;
4555 -----------------------
4556 -- Build_Stub_Target --
4557 -----------------------
4559 function Build_Stub_Target
4562 RCI_Locator
: Entity_Id
;
4563 Controlling_Parameter
: Entity_Id
) return RPC_Target
4565 Target_Info
: RPC_Target
(PCS_Kind
=> Name_GARLIC_DSA
);
4568 Target_Info
.Partition
:= Make_Temporary
(Loc
, 'P');
4570 if Present
(Controlling_Parameter
) then
4572 Make_Object_Declaration
(Loc
,
4573 Defining_Identifier
=> Target_Info
.Partition
,
4574 Constant_Present
=> True,
4575 Object_Definition
=>
4576 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4579 Make_Selected_Component
(Loc
,
4580 Prefix
=> Controlling_Parameter
,
4581 Selector_Name
=> Name_Origin
)));
4583 Target_Info
.RPC_Receiver
:=
4584 Make_Selected_Component
(Loc
,
4585 Prefix
=> Controlling_Parameter
,
4586 Selector_Name
=> Name_Receiver
);
4590 Make_Object_Declaration
(Loc
,
4591 Defining_Identifier
=> Target_Info
.Partition
,
4592 Constant_Present
=> True,
4593 Object_Definition
=>
4594 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4597 Make_Function_Call
(Loc
,
4598 Name
=> Make_Selected_Component
(Loc
,
4600 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4602 Make_Identifier
(Loc
,
4603 Name_Get_Active_Partition_ID
)))));
4605 Target_Info
.RPC_Receiver
:=
4606 Make_Selected_Component
(Loc
,
4608 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4610 Make_Identifier
(Loc
, Name_Get_RCI_Package_Receiver
));
4613 end Build_Stub_Target
;
4615 ---------------------
4616 -- Build_Stub_Type --
4617 ---------------------
4619 procedure Build_Stub_Type
4620 (RACW_Type
: Entity_Id
;
4621 Stub_Type_Comps
: out List_Id
;
4622 RPC_Receiver_Decl
: out Node_Id
)
4624 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
4625 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
4628 Stub_Type_Comps
:= New_List
(
4629 Make_Component_Declaration
(Loc
,
4630 Defining_Identifier
=>
4631 Make_Defining_Identifier
(Loc
, Name_Origin
),
4632 Component_Definition
=>
4633 Make_Component_Definition
(Loc
,
4634 Aliased_Present
=> False,
4635 Subtype_Indication
=>
4636 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
))),
4638 Make_Component_Declaration
(Loc
,
4639 Defining_Identifier
=>
4640 Make_Defining_Identifier
(Loc
, Name_Receiver
),
4641 Component_Definition
=>
4642 Make_Component_Definition
(Loc
,
4643 Aliased_Present
=> False,
4644 Subtype_Indication
=>
4645 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4647 Make_Component_Declaration
(Loc
,
4648 Defining_Identifier
=>
4649 Make_Defining_Identifier
(Loc
, Name_Addr
),
4650 Component_Definition
=>
4651 Make_Component_Definition
(Loc
,
4652 Aliased_Present
=> False,
4653 Subtype_Indication
=>
4654 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4656 Make_Component_Declaration
(Loc
,
4657 Defining_Identifier
=>
4658 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
4659 Component_Definition
=>
4660 Make_Component_Definition
(Loc
,
4661 Aliased_Present
=> False,
4662 Subtype_Indication
=>
4663 New_Occurrence_Of
(Standard_Boolean
, Loc
))));
4666 RPC_Receiver_Decl
:= Empty
;
4669 RPC_Receiver_Request
: constant Entity_Id
:=
4670 Make_Defining_Identifier
(Loc
, Name_R
);
4672 RPC_Receiver_Decl
:=
4673 Make_Subprogram_Declaration
(Loc
,
4674 Build_RPC_Receiver_Specification
4675 (RPC_Receiver
=> Make_Temporary
(Loc
, 'R'),
4676 Request_Parameter
=> RPC_Receiver_Request
));
4679 end Build_Stub_Type
;
4681 --------------------------------------
4682 -- Build_Subprogram_Receiving_Stubs --
4683 --------------------------------------
4685 function Build_Subprogram_Receiving_Stubs
4686 (Vis_Decl
: Node_Id
;
4687 Asynchronous
: Boolean;
4688 Dynamically_Asynchronous
: Boolean := False;
4689 Stub_Type
: Entity_Id
:= Empty
;
4690 RACW_Type
: Entity_Id
:= Empty
;
4691 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
4693 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
4695 Request_Parameter
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4696 -- Formal parameter for receiving stubs: a descriptor for an incoming
4699 Decls
: constant List_Id
:= New_List
;
4700 -- All the parameters will get declared before calling the real
4701 -- subprograms. Also the out parameters will be declared.
4703 Statements
: constant List_Id
:= New_List
;
4705 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4706 -- Statements concerning extra formal parameters
4708 After_Statements
: constant List_Id
:= New_List
;
4709 -- Statements to be executed after the subprogram call
4711 Inner_Decls
: List_Id
:= No_List
;
4712 -- In case of a function, the inner declarations are needed since
4713 -- the result may be unconstrained.
4715 Excep_Handlers
: List_Id
:= No_List
;
4716 Excep_Choice
: Entity_Id
;
4717 Excep_Code
: List_Id
;
4719 Parameter_List
: constant List_Id
:= New_List
;
4720 -- List of parameters to be passed to the subprogram
4722 Current_Parameter
: Node_Id
;
4724 Ordered_Parameters_List
: constant List_Id
:=
4725 Build_Ordered_Parameters_List
4726 (Specification
(Vis_Decl
));
4728 Subp_Spec
: Node_Id
;
4729 -- Subprogram specification
4731 Called_Subprogram
: Node_Id
;
4732 -- The subprogram to call
4734 Null_Raise_Statement
: Node_Id
;
4736 Dynamic_Async
: Entity_Id
;
4739 if Present
(RACW_Type
) then
4740 Called_Subprogram
:= New_Occurrence_Of
(Parent_Primitive
, Loc
);
4742 Called_Subprogram
:=
4744 (Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
4747 if Dynamically_Asynchronous
then
4748 Dynamic_Async
:= Make_Temporary
(Loc
, 'S');
4750 Dynamic_Async
:= Empty
;
4753 if not Asynchronous
or Dynamically_Asynchronous
then
4755 -- The first statement after the subprogram call is a statement to
4756 -- write a Null_Occurrence into the result stream.
4758 Null_Raise_Statement
:=
4759 Make_Attribute_Reference
(Loc
,
4761 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4762 Attribute_Name
=> Name_Write
,
4763 Expressions
=> New_List
(
4764 Make_Selected_Component
(Loc
,
4765 Prefix
=> Request_Parameter
,
4766 Selector_Name
=> Name_Result
),
4767 New_Occurrence_Of
(RTE
(RE_Null_Occurrence
), Loc
)));
4769 if Dynamically_Asynchronous
then
4770 Null_Raise_Statement
:=
4771 Make_Implicit_If_Statement
(Vis_Decl
,
4773 Make_Op_Not
(Loc
, New_Occurrence_Of
(Dynamic_Async
, Loc
)),
4774 Then_Statements
=> New_List
(Null_Raise_Statement
));
4777 Append_To
(After_Statements
, Null_Raise_Statement
);
4780 -- Loop through every parameter and get its value from the stream. If
4781 -- the parameter is unconstrained, then the parameter is read using
4782 -- 'Input at the point of declaration.
4784 Current_Parameter
:= First
(Ordered_Parameters_List
);
4785 while Present
(Current_Parameter
) loop
4788 Constrained
: Boolean;
4790 Need_Extra_Constrained
: Boolean;
4791 -- True when an Extra_Constrained actual is required
4793 Object
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
4795 Expr
: Node_Id
:= Empty
;
4797 Is_Controlling_Formal
: constant Boolean :=
4798 Is_RACW_Controlling_Formal
4799 (Current_Parameter
, Stub_Type
);
4802 if Is_Controlling_Formal
then
4804 -- We have a controlling formal parameter. Read its address
4805 -- rather than a real object. The address is in Unsigned_64
4808 Etyp
:= RTE
(RE_Unsigned_64
);
4810 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
4813 Constrained
:= not Transmit_As_Unconstrained
(Etyp
);
4815 if In_Present
(Current_Parameter
)
4816 or else not Out_Present
(Current_Parameter
)
4817 or else not Constrained
4818 or else Is_Controlling_Formal
4820 -- If an input parameter is constrained, then the read of
4821 -- the parameter is deferred until the beginning of the
4822 -- subprogram body. If it is unconstrained, then an
4823 -- expression is built for the object declaration and the
4824 -- variable is set using 'Input instead of 'Read. Note that
4825 -- this deferral does not change the order in which the
4826 -- actuals are read because Build_Ordered_Parameter_List
4827 -- puts them unconstrained first.
4830 Append_To
(Statements
,
4831 Make_Attribute_Reference
(Loc
,
4832 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4833 Attribute_Name
=> Name_Read
,
4834 Expressions
=> New_List
(
4835 Make_Selected_Component
(Loc
,
4836 Prefix
=> Request_Parameter
,
4837 Selector_Name
=> Name_Params
),
4838 New_Occurrence_Of
(Object
, Loc
))));
4842 -- Build and append Input_With_Tag_Check function
4845 Input_With_Tag_Check
(Loc
,
4848 Make_Selected_Component
(Loc
,
4849 Prefix
=> Request_Parameter
,
4850 Selector_Name
=> Name_Params
)));
4852 -- Prepare function call expression
4855 Make_Function_Call
(Loc
,
4859 (Specification
(Last
(Decls
))), Loc
));
4863 Need_Extra_Constrained
:=
4864 Nkind
(Parameter_Type
(Current_Parameter
)) /=
4867 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
4869 Present
(Extra_Constrained
4870 (Defining_Identifier
(Current_Parameter
)));
4872 -- We may not associate an extra constrained actual to a
4873 -- constant object, so if one is needed, declare the actual
4874 -- as a variable even if it won't be modified.
4876 Build_Actual_Object_Declaration
4879 Variable
=> Need_Extra_Constrained
4880 or else Out_Present
(Current_Parameter
),
4884 -- An out parameter may be written back using a 'Write
4885 -- attribute instead of a 'Output because it has been
4886 -- constrained by the parameter given to the caller. Note that
4887 -- out controlling arguments in the case of a RACW are not put
4888 -- back in the stream because the pointer on them has not
4891 if Out_Present
(Current_Parameter
)
4893 Etype
(Parameter_Type
(Current_Parameter
)) /= Stub_Type
4895 Append_To
(After_Statements
,
4896 Make_Attribute_Reference
(Loc
,
4897 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4898 Attribute_Name
=> Name_Write
,
4899 Expressions
=> New_List
(
4900 Make_Selected_Component
(Loc
,
4901 Prefix
=> Request_Parameter
,
4902 Selector_Name
=> Name_Result
),
4903 New_Occurrence_Of
(Object
, Loc
))));
4906 -- For RACW controlling formals, the Etyp of Object is always
4907 -- an RACW, even if the parameter is not of an anonymous access
4908 -- type. In such case, we need to dereference it at call time.
4910 if Is_Controlling_Formal
then
4911 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
4914 Append_To
(Parameter_List
,
4915 Make_Parameter_Association
(Loc
,
4918 Defining_Identifier
(Current_Parameter
), Loc
),
4919 Explicit_Actual_Parameter
=>
4920 Make_Explicit_Dereference
(Loc
,
4921 Unchecked_Convert_To
(RACW_Type
,
4922 OK_Convert_To
(RTE
(RE_Address
),
4923 New_Occurrence_Of
(Object
, Loc
))))));
4926 Append_To
(Parameter_List
,
4927 Make_Parameter_Association
(Loc
,
4930 Defining_Identifier
(Current_Parameter
), Loc
),
4931 Explicit_Actual_Parameter
=>
4932 Unchecked_Convert_To
(RACW_Type
,
4933 OK_Convert_To
(RTE
(RE_Address
),
4934 New_Occurrence_Of
(Object
, Loc
)))));
4938 Append_To
(Parameter_List
,
4939 Make_Parameter_Association
(Loc
,
4942 Defining_Identifier
(Current_Parameter
), Loc
),
4943 Explicit_Actual_Parameter
=>
4944 New_Occurrence_Of
(Object
, Loc
)));
4947 -- If the current parameter needs an extra formal, then read it
4948 -- from the stream and set the corresponding semantic field in
4949 -- the variable. If the kind of the parameter identifier is
4950 -- E_Void, then this is a compiler generated parameter that
4951 -- doesn't need an extra constrained status.
4953 -- The case of Extra_Accessibility should also be handled ???
4955 if Need_Extra_Constrained
then
4957 Extra_Parameter
: constant Entity_Id
:=
4959 (Defining_Identifier
4960 (Current_Parameter
));
4962 Formal_Entity
: constant Entity_Id
:=
4963 Make_Defining_Identifier
4964 (Loc
, Chars
(Extra_Parameter
));
4966 Formal_Type
: constant Entity_Id
:=
4967 Etype
(Extra_Parameter
);
4971 Make_Object_Declaration
(Loc
,
4972 Defining_Identifier
=> Formal_Entity
,
4973 Object_Definition
=>
4974 New_Occurrence_Of
(Formal_Type
, Loc
)));
4976 Append_To
(Extra_Formal_Statements
,
4977 Make_Attribute_Reference
(Loc
,
4978 Prefix
=> New_Occurrence_Of
(
4980 Attribute_Name
=> Name_Read
,
4981 Expressions
=> New_List
(
4982 Make_Selected_Component
(Loc
,
4983 Prefix
=> Request_Parameter
,
4984 Selector_Name
=> Name_Params
),
4985 New_Occurrence_Of
(Formal_Entity
, Loc
))));
4987 -- Note: the call to Set_Extra_Constrained below relies
4988 -- on the fact that Object's Ekind has been set by
4989 -- Build_Actual_Object_Declaration.
4991 Set_Extra_Constrained
(Object
, Formal_Entity
);
4996 Next
(Current_Parameter
);
4999 -- Append the formal statements list at the end of regular statements
5001 Append_List_To
(Statements
, Extra_Formal_Statements
);
5003 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
5005 -- The remote subprogram is a function. We build an inner block to
5006 -- be able to hold a potentially unconstrained result in a
5010 Etyp
: constant Entity_Id
:=
5011 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
5012 Result
: constant Node_Id
:= Make_Temporary
(Loc
, 'R');
5015 Inner_Decls
:= New_List
(
5016 Make_Object_Declaration
(Loc
,
5017 Defining_Identifier
=> Result
,
5018 Constant_Present
=> True,
5019 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
5021 Make_Function_Call
(Loc
,
5022 Name
=> Called_Subprogram
,
5023 Parameter_Associations
=> Parameter_List
)));
5025 if Is_Class_Wide_Type
(Etyp
) then
5027 -- For a remote call to a function with a class-wide type,
5028 -- check that the returned value satisfies the requirements
5031 Append_To
(Inner_Decls
,
5032 Make_Transportable_Check
(Loc
,
5033 New_Occurrence_Of
(Result
, Loc
)));
5037 Append_To
(After_Statements
,
5038 Make_Attribute_Reference
(Loc
,
5039 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5040 Attribute_Name
=> Name_Output
,
5041 Expressions
=> New_List
(
5042 Make_Selected_Component
(Loc
,
5043 Prefix
=> Request_Parameter
,
5044 Selector_Name
=> Name_Result
),
5045 New_Occurrence_Of
(Result
, Loc
))));
5048 Append_To
(Statements
,
5049 Make_Block_Statement
(Loc
,
5050 Declarations
=> Inner_Decls
,
5051 Handled_Statement_Sequence
=>
5052 Make_Handled_Sequence_Of_Statements
(Loc
,
5053 Statements
=> After_Statements
)));
5056 -- The remote subprogram is a procedure. We do not need any inner
5057 -- block in this case.
5059 if Dynamically_Asynchronous
then
5061 Make_Object_Declaration
(Loc
,
5062 Defining_Identifier
=> Dynamic_Async
,
5063 Object_Definition
=>
5064 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
5066 Append_To
(Statements
,
5067 Make_Attribute_Reference
(Loc
,
5068 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
5069 Attribute_Name
=> Name_Read
,
5070 Expressions
=> New_List
(
5071 Make_Selected_Component
(Loc
,
5072 Prefix
=> Request_Parameter
,
5073 Selector_Name
=> Name_Params
),
5074 New_Occurrence_Of
(Dynamic_Async
, Loc
))));
5077 Append_To
(Statements
,
5078 Make_Procedure_Call_Statement
(Loc
,
5079 Name
=> Called_Subprogram
,
5080 Parameter_Associations
=> Parameter_List
));
5082 Append_List_To
(Statements
, After_Statements
);
5085 if Asynchronous
and then not Dynamically_Asynchronous
then
5087 -- For an asynchronous procedure, add a null exception handler
5089 Excep_Handlers
:= New_List
(
5090 Make_Implicit_Exception_Handler
(Loc
,
5091 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5092 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
5095 -- In the other cases, if an exception is raised, then the
5096 -- exception occurrence is copied into the output stream and
5097 -- no other output parameter is written.
5099 Excep_Choice
:= Make_Temporary
(Loc
, 'E');
5101 Excep_Code
:= New_List
(
5102 Make_Attribute_Reference
(Loc
,
5104 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
5105 Attribute_Name
=> Name_Write
,
5106 Expressions
=> New_List
(
5107 Make_Selected_Component
(Loc
,
5108 Prefix
=> Request_Parameter
,
5109 Selector_Name
=> Name_Result
),
5110 New_Occurrence_Of
(Excep_Choice
, Loc
))));
5112 if Dynamically_Asynchronous
then
5113 Excep_Code
:= New_List
(
5114 Make_Implicit_If_Statement
(Vis_Decl
,
5115 Condition
=> Make_Op_Not
(Loc
,
5116 New_Occurrence_Of
(Dynamic_Async
, Loc
)),
5117 Then_Statements
=> Excep_Code
));
5120 Excep_Handlers
:= New_List
(
5121 Make_Implicit_Exception_Handler
(Loc
,
5122 Choice_Parameter
=> Excep_Choice
,
5123 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5124 Statements
=> Excep_Code
));
5129 Make_Procedure_Specification
(Loc
,
5130 Defining_Unit_Name
=> Make_Temporary
(Loc
, 'F'),
5132 Parameter_Specifications
=> New_List
(
5133 Make_Parameter_Specification
(Loc
,
5134 Defining_Identifier
=> Request_Parameter
,
5136 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
5139 Make_Subprogram_Body
(Loc
,
5140 Specification
=> Subp_Spec
,
5141 Declarations
=> Decls
,
5142 Handled_Statement_Sequence
=>
5143 Make_Handled_Sequence_Of_Statements
(Loc
,
5144 Statements
=> Statements
,
5145 Exception_Handlers
=> Excep_Handlers
));
5146 end Build_Subprogram_Receiving_Stubs
;
5152 function Result
return Node_Id
is
5154 return Make_Identifier
(Loc
, Name_V
);
5157 ----------------------
5158 -- Stream_Parameter --
5159 ----------------------
5161 function Stream_Parameter
return Node_Id
is
5163 return Make_Identifier
(Loc
, Name_S
);
5164 end Stream_Parameter
;
5168 -------------------------------
5169 -- Get_And_Reset_RACW_Bodies --
5170 -------------------------------
5172 function Get_And_Reset_RACW_Bodies
(RACW_Type
: Entity_Id
) return List_Id
is
5173 Desig
: constant Entity_Id
:=
5174 Etype
(Designated_Type
(RACW_Type
));
5176 Stub_Elements
: Stub_Structure
:= Stubs_Table
.Get
(Desig
);
5178 Body_Decls
: List_Id
;
5179 -- Returned list of declarations
5182 if Stub_Elements
= Empty_Stub_Structure
then
5184 -- Stub elements may be missing as a consequence of a previously
5190 Body_Decls
:= Stub_Elements
.Body_Decls
;
5191 Stub_Elements
.Body_Decls
:= No_List
;
5192 Stubs_Table
.Set
(Desig
, Stub_Elements
);
5194 end Get_And_Reset_RACW_Bodies
;
5196 -----------------------
5197 -- Get_Stub_Elements --
5198 -----------------------
5200 function Get_Stub_Elements
(RACW_Type
: Entity_Id
) return Stub_Structure
is
5201 Desig
: constant Entity_Id
:=
5202 Etype
(Designated_Type
(RACW_Type
));
5203 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
5205 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5206 return Stub_Elements
;
5207 end Get_Stub_Elements
;
5209 -----------------------
5210 -- Get_Subprogram_Id --
5211 -----------------------
5213 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
is
5214 Result
: constant String_Id
:= Get_Subprogram_Ids
(Def
).Str_Identifier
;
5216 pragma Assert
(Result
/= No_String
);
5218 end Get_Subprogram_Id
;
5220 -----------------------
5221 -- Get_Subprogram_Id --
5222 -----------------------
5224 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
is
5226 return Get_Subprogram_Ids
(Def
).Int_Identifier
;
5227 end Get_Subprogram_Id
;
5229 ------------------------
5230 -- Get_Subprogram_Ids --
5231 ------------------------
5233 function Get_Subprogram_Ids
5234 (Def
: Entity_Id
) return Subprogram_Identifiers
5237 return Subprogram_Identifier_Table
.Get
(Def
);
5238 end Get_Subprogram_Ids
;
5244 function Hash
(F
: Entity_Id
) return Hash_Index
is
5246 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
5249 function Hash
(F
: Name_Id
) return Hash_Index
is
5251 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
5254 --------------------------
5255 -- Input_With_Tag_Check --
5256 --------------------------
5258 function Input_With_Tag_Check
5260 Var_Type
: Entity_Id
;
5261 Stream
: Node_Id
) return Node_Id
5265 Make_Subprogram_Body
(Loc
,
5267 Make_Function_Specification
(Loc
,
5268 Defining_Unit_Name
=> Make_Temporary
(Loc
, 'S'),
5269 Result_Definition
=> New_Occurrence_Of
(Var_Type
, Loc
)),
5270 Declarations
=> No_List
,
5271 Handled_Statement_Sequence
=>
5272 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
5273 Make_Tag_Check
(Loc
,
5274 Make_Simple_Return_Statement
(Loc
,
5275 Make_Attribute_Reference
(Loc
,
5276 Prefix
=> New_Occurrence_Of
(Var_Type
, Loc
),
5277 Attribute_Name
=> Name_Input
,
5279 New_List
(Stream
)))))));
5280 end Input_With_Tag_Check
;
5282 --------------------------------
5283 -- Is_RACW_Controlling_Formal --
5284 --------------------------------
5286 function Is_RACW_Controlling_Formal
5287 (Parameter
: Node_Id
;
5288 Stub_Type
: Entity_Id
) return Boolean
5293 -- If the kind of the parameter is E_Void, then it is not a controlling
5294 -- formal (this can happen in the context of RAS).
5296 if Ekind
(Defining_Identifier
(Parameter
)) = E_Void
then
5300 -- If the parameter is not a controlling formal, then it cannot be
5301 -- possibly a RACW_Controlling_Formal.
5303 if not Is_Controlling_Formal
(Defining_Identifier
(Parameter
)) then
5307 Typ
:= Parameter_Type
(Parameter
);
5308 return (Nkind
(Typ
) = N_Access_Definition
5309 and then Etype
(Subtype_Mark
(Typ
)) = Stub_Type
)
5310 or else Etype
(Typ
) = Stub_Type
;
5311 end Is_RACW_Controlling_Formal
;
5313 ------------------------------
5314 -- Make_Transportable_Check --
5315 ------------------------------
5317 function Make_Transportable_Check
5319 Expr
: Node_Id
) return Node_Id
is
5322 Make_Raise_Program_Error
(Loc
,
5325 Build_Get_Transportable
(Loc
,
5326 Make_Selected_Component
(Loc
,
5328 Selector_Name
=> Make_Identifier
(Loc
, Name_uTag
)))),
5329 Reason
=> PE_Non_Transportable_Actual
);
5330 end Make_Transportable_Check
;
5332 -----------------------------
5333 -- Make_Selected_Component --
5334 -----------------------------
5336 function Make_Selected_Component
5339 Selector_Name
: Name_Id
) return Node_Id
5342 return Make_Selected_Component
(Loc
,
5343 Prefix
=> New_Occurrence_Of
(Prefix
, Loc
),
5344 Selector_Name
=> Make_Identifier
(Loc
, Selector_Name
));
5345 end Make_Selected_Component
;
5347 --------------------
5348 -- Make_Tag_Check --
5349 --------------------
5351 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
is
5352 Occ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
5355 return Make_Block_Statement
(Loc
,
5356 Handled_Statement_Sequence
=>
5357 Make_Handled_Sequence_Of_Statements
(Loc
,
5358 Statements
=> New_List
(N
),
5360 Exception_Handlers
=> New_List
(
5361 Make_Implicit_Exception_Handler
(Loc
,
5362 Choice_Parameter
=> Occ
,
5364 Exception_Choices
=>
5365 New_List
(New_Occurrence_Of
(RTE
(RE_Tag_Error
), Loc
)),
5368 New_List
(Make_Procedure_Call_Statement
(Loc
,
5370 (RTE
(RE_Raise_Program_Error_Unknown_Tag
), Loc
),
5371 New_List
(New_Occurrence_Of
(Occ
, Loc
))))))));
5374 ----------------------------
5375 -- Need_Extra_Constrained --
5376 ----------------------------
5378 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean is
5379 Etyp
: constant Entity_Id
:= Etype
(Parameter_Type
(Parameter
));
5381 return Out_Present
(Parameter
)
5382 and then Has_Discriminants
(Etyp
)
5383 and then not Is_Constrained
(Etyp
)
5384 and then not Is_Indefinite_Subtype
(Etyp
);
5385 end Need_Extra_Constrained
;
5387 ------------------------------------
5388 -- Pack_Entity_Into_Stream_Access --
5389 ------------------------------------
5391 function Pack_Entity_Into_Stream_Access
5395 Etyp
: Entity_Id
:= Empty
) return Node_Id
5400 if Present
(Etyp
) then
5403 Typ
:= Etype
(Object
);
5407 Pack_Node_Into_Stream_Access
(Loc
,
5409 Object
=> New_Occurrence_Of
(Object
, Loc
),
5411 end Pack_Entity_Into_Stream_Access
;
5413 ---------------------------
5414 -- Pack_Node_Into_Stream --
5415 ---------------------------
5417 function Pack_Node_Into_Stream
5421 Etyp
: Entity_Id
) return Node_Id
5423 Write_Attribute
: Name_Id
:= Name_Write
;
5426 if not Is_Constrained
(Etyp
) then
5427 Write_Attribute
:= Name_Output
;
5431 Make_Attribute_Reference
(Loc
,
5432 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5433 Attribute_Name
=> Write_Attribute
,
5434 Expressions
=> New_List
(
5435 Make_Attribute_Reference
(Loc
,
5436 Prefix
=> New_Occurrence_Of
(Stream
, Loc
),
5437 Attribute_Name
=> Name_Access
),
5439 end Pack_Node_Into_Stream
;
5441 ----------------------------------
5442 -- Pack_Node_Into_Stream_Access --
5443 ----------------------------------
5445 function Pack_Node_Into_Stream_Access
5449 Etyp
: Entity_Id
) return Node_Id
5451 Write_Attribute
: Name_Id
:= Name_Write
;
5454 if not Is_Constrained
(Etyp
) then
5455 Write_Attribute
:= Name_Output
;
5459 Make_Attribute_Reference
(Loc
,
5460 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5461 Attribute_Name
=> Write_Attribute
,
5462 Expressions
=> New_List
(
5465 end Pack_Node_Into_Stream_Access
;
5467 ---------------------
5468 -- PolyORB_Support --
5469 ---------------------
5471 package body PolyORB_Support
is
5473 -- Local subprograms
5475 procedure Add_RACW_Read_Attribute
5476 (RACW_Type
: Entity_Id
;
5477 Stub_Type
: Entity_Id
;
5478 Stub_Type_Access
: Entity_Id
;
5479 Body_Decls
: List_Id
);
5480 -- Add Read attribute for the RACW type. The declaration and attribute
5481 -- definition clauses are inserted right after the declaration of
5482 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5483 -- appended to it (case where the RACW declaration is in the main unit).
5485 procedure Add_RACW_Write_Attribute
5486 (RACW_Type
: Entity_Id
;
5487 Stub_Type
: Entity_Id
;
5488 Stub_Type_Access
: Entity_Id
;
5489 Body_Decls
: List_Id
);
5490 -- Same as above for the Write attribute
5492 procedure Add_RACW_From_Any
5493 (RACW_Type
: Entity_Id
;
5494 Body_Decls
: List_Id
);
5495 -- Add the From_Any TSS for this RACW type
5497 procedure Add_RACW_To_Any
5498 (RACW_Type
: Entity_Id
;
5499 Body_Decls
: List_Id
);
5500 -- Add the To_Any TSS for this RACW type
5502 procedure Add_RACW_TypeCode
5503 (Designated_Type
: Entity_Id
;
5504 RACW_Type
: Entity_Id
;
5505 Body_Decls
: List_Id
);
5506 -- Add the TypeCode TSS for this RACW type
5508 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
);
5509 -- Add the From_Any TSS for this RAS type
5511 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
);
5512 -- Add the To_Any TSS for this RAS type
5514 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
);
5515 -- Add the TypeCode TSS for this RAS type
5517 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
5518 -- Add a subprogram body for RAS Access TSS
5520 -------------------------------------
5521 -- Add_Obj_RPC_Receiver_Completion --
5522 -------------------------------------
5524 procedure Add_Obj_RPC_Receiver_Completion
5527 RPC_Receiver
: Entity_Id
;
5528 Stub_Elements
: Stub_Structure
)
5530 Desig
: constant Entity_Id
:=
5531 Etype
(Designated_Type
(Stub_Elements
.RACW_Type
));
5534 Make_Procedure_Call_Statement
(Loc
,
5537 RTE
(RE_Register_Obj_Receiving_Stub
), Loc
),
5539 Parameter_Associations
=> New_List
(
5543 Make_String_Literal
(Loc
,
5544 Full_Qualified_Name
(Desig
)),
5548 Make_Attribute_Reference
(Loc
,
5551 Defining_Unit_Name
(Parent
(RPC_Receiver
)), Loc
),
5557 Make_Attribute_Reference
(Loc
,
5560 Defining_Identifier
(
5561 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5564 end Add_Obj_RPC_Receiver_Completion
;
5566 -----------------------
5567 -- Add_RACW_Features --
5568 -----------------------
5570 procedure Add_RACW_Features
5571 (RACW_Type
: Entity_Id
;
5573 Stub_Type
: Entity_Id
;
5574 Stub_Type_Access
: Entity_Id
;
5575 RPC_Receiver_Decl
: Node_Id
;
5576 Body_Decls
: List_Id
)
5578 pragma Unreferenced
(RPC_Receiver_Decl
);
5582 (RACW_Type
=> RACW_Type
,
5583 Body_Decls
=> Body_Decls
);
5586 (RACW_Type
=> RACW_Type
,
5587 Body_Decls
=> Body_Decls
);
5589 Add_RACW_Write_Attribute
5590 (RACW_Type
=> RACW_Type
,
5591 Stub_Type
=> Stub_Type
,
5592 Stub_Type_Access
=> Stub_Type_Access
,
5593 Body_Decls
=> Body_Decls
);
5595 Add_RACW_Read_Attribute
5596 (RACW_Type
=> RACW_Type
,
5597 Stub_Type
=> Stub_Type
,
5598 Stub_Type_Access
=> Stub_Type_Access
,
5599 Body_Decls
=> Body_Decls
);
5602 (Designated_Type
=> Desig
,
5603 RACW_Type
=> RACW_Type
,
5604 Body_Decls
=> Body_Decls
);
5605 end Add_RACW_Features
;
5607 -----------------------
5608 -- Add_RACW_From_Any --
5609 -----------------------
5611 procedure Add_RACW_From_Any
5612 (RACW_Type
: Entity_Id
;
5613 Body_Decls
: List_Id
)
5615 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5616 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5617 Fnam
: constant Entity_Id
:=
5618 Make_Defining_Identifier
(Loc
,
5619 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'F'));
5621 Func_Spec
: Node_Id
;
5622 Func_Decl
: Node_Id
;
5623 Func_Body
: Node_Id
;
5625 Statements
: List_Id
;
5626 -- Various parts of the subprogram
5628 Any_Parameter
: constant Entity_Id
:=
5629 Make_Defining_Identifier
(Loc
, Name_A
);
5631 Asynchronous_Flag
: constant Entity_Id
:=
5632 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5633 -- The flag object declared in Add_RACW_Asynchronous_Flag
5637 Make_Function_Specification
(Loc
,
5638 Defining_Unit_Name
=>
5640 Parameter_Specifications
=> New_List
(
5641 Make_Parameter_Specification
(Loc
,
5642 Defining_Identifier
=>
5645 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
5646 Result_Definition
=> New_Occurrence_Of
(RACW_Type
, Loc
));
5648 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5649 -- entity in the declaration spec, not those of the body spec.
5651 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5652 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5653 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_From_Any
);
5655 if No
(Body_Decls
) then
5659 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5660 -- set on the stub type if, and only if, the RACW type has a pragma
5661 -- Asynchronous. This is incorrect for RACWs that implement RAS
5662 -- types, because in that case the /designated subprogram/ (not the
5663 -- type) might be asynchronous, and that causes the stub to need to
5664 -- be asynchronous too. A solution is to transport a RAS as a struct
5665 -- containing a RACW and an asynchronous flag, and to properly alter
5666 -- the Asynchronous component in the stub type in the RAS's _From_Any
5669 Statements
:= New_List
(
5670 Make_Simple_Return_Statement
(Loc
,
5671 Expression
=> Unchecked_Convert_To
(RACW_Type
,
5672 Make_Function_Call
(Loc
,
5673 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RACW
), Loc
),
5674 Parameter_Associations
=> New_List
(
5675 Make_Function_Call
(Loc
,
5676 Name
=> New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
5677 Parameter_Associations
=> New_List
(
5678 New_Occurrence_Of
(Any_Parameter
, Loc
))),
5679 Build_Stub_Tag
(Loc
, RACW_Type
),
5680 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5681 New_Occurrence_Of
(Asynchronous_Flag
, Loc
))))));
5684 Make_Subprogram_Body
(Loc
,
5685 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
5686 Declarations
=> No_List
,
5687 Handled_Statement_Sequence
=>
5688 Make_Handled_Sequence_Of_Statements
(Loc
,
5689 Statements
=> Statements
));
5691 Append_To
(Body_Decls
, Func_Body
);
5692 end Add_RACW_From_Any
;
5694 -----------------------------
5695 -- Add_RACW_Read_Attribute --
5696 -----------------------------
5698 procedure Add_RACW_Read_Attribute
5699 (RACW_Type
: Entity_Id
;
5700 Stub_Type
: Entity_Id
;
5701 Stub_Type_Access
: Entity_Id
;
5702 Body_Decls
: List_Id
)
5704 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
5706 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5708 Proc_Decl
: Node_Id
;
5709 Attr_Decl
: Node_Id
;
5711 Body_Node
: Node_Id
;
5713 Decls
: constant List_Id
:= New_List
;
5714 Statements
: constant List_Id
:= New_List
;
5715 Reference
: constant Entity_Id
:=
5716 Make_Defining_Identifier
(Loc
, Name_R
);
5717 -- Various parts of the procedure
5719 Pnam
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
5721 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5723 Asynchronous_Flag
: constant Entity_Id
:=
5724 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5725 pragma Assert
(Present
(Asynchronous_Flag
));
5727 function Stream_Parameter
return Node_Id
;
5728 function Result
return Node_Id
;
5730 -- Functions to create occurrences of the formal parameter names
5736 function Result
return Node_Id
is
5738 return Make_Identifier
(Loc
, Name_V
);
5741 ----------------------
5742 -- Stream_Parameter --
5743 ----------------------
5745 function Stream_Parameter
return Node_Id
is
5747 return Make_Identifier
(Loc
, Name_S
);
5748 end Stream_Parameter
;
5750 -- Start of processing for Add_RACW_Read_Attribute
5753 Build_Stream_Procedure
5754 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> True);
5756 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
5757 Copy_Specification
(Loc
, Specification
(Body_Node
)));
5760 Make_Attribute_Definition_Clause
(Loc
,
5761 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
5765 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
5767 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
5768 Insert_After
(Proc_Decl
, Attr_Decl
);
5770 if No
(Body_Decls
) then
5775 Make_Object_Declaration
(Loc
,
5776 Defining_Identifier
=>
5778 Object_Definition
=>
5779 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)));
5781 Append_List_To
(Statements
, New_List
(
5782 Make_Attribute_Reference
(Loc
,
5784 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5785 Attribute_Name
=> Name_Read
,
5786 Expressions
=> New_List
(
5788 New_Occurrence_Of
(Reference
, Loc
))),
5790 Make_Assignment_Statement
(Loc
,
5794 Unchecked_Convert_To
(RACW_Type
,
5795 Make_Function_Call
(Loc
,
5797 New_Occurrence_Of
(RTE
(RE_Get_RACW
), Loc
),
5798 Parameter_Associations
=> New_List
(
5799 New_Occurrence_Of
(Reference
, Loc
),
5800 Build_Stub_Tag
(Loc
, RACW_Type
),
5801 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5802 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)))))));
5804 Set_Declarations
(Body_Node
, Decls
);
5805 Append_To
(Body_Decls
, Body_Node
);
5806 end Add_RACW_Read_Attribute
;
5808 ---------------------
5809 -- Add_RACW_To_Any --
5810 ---------------------
5812 procedure Add_RACW_To_Any
5813 (RACW_Type
: Entity_Id
;
5814 Body_Decls
: List_Id
)
5816 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5818 Fnam
: constant Entity_Id
:=
5819 Make_Defining_Identifier
(Loc
,
5820 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'T'));
5822 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5824 Stub_Elements
: constant Stub_Structure
:=
5825 Get_Stub_Elements
(RACW_Type
);
5827 Func_Spec
: Node_Id
;
5828 Func_Decl
: Node_Id
;
5829 Func_Body
: Node_Id
;
5832 Statements
: List_Id
;
5833 -- Various parts of the subprogram
5835 RACW_Parameter
: constant Entity_Id
:=
5836 Make_Defining_Identifier
(Loc
, Name_R
);
5838 Reference
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
5839 Any
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5843 Make_Function_Specification
(Loc
,
5844 Defining_Unit_Name
=>
5846 Parameter_Specifications
=> New_List
(
5847 Make_Parameter_Specification
(Loc
,
5848 Defining_Identifier
=>
5851 New_Occurrence_Of
(RACW_Type
, Loc
))),
5852 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
5854 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5855 -- entity in the declaration spec, not in the body spec.
5857 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5859 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5860 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_To_Any
);
5862 if No
(Body_Decls
) then
5868 -- R : constant Object_Ref :=
5874 -- RPC_Receiver'Access);
5878 Make_Object_Declaration
(Loc
,
5879 Defining_Identifier
=> Reference
,
5880 Constant_Present
=> True,
5881 Object_Definition
=>
5882 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5884 Make_Function_Call
(Loc
,
5885 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
5886 Parameter_Associations
=> New_List
(
5887 Unchecked_Convert_To
(RTE
(RE_Address
),
5888 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5889 Make_String_Literal
(Loc
,
5890 Strval
=> Full_Qualified_Name
5891 (Etype
(Designated_Type
(RACW_Type
)))),
5892 Build_Stub_Tag
(Loc
, RACW_Type
),
5893 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5894 Make_Attribute_Reference
(Loc
,
5897 (Defining_Identifier
5898 (Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5899 Attribute_Name
=> Name_Access
)))),
5901 Make_Object_Declaration
(Loc
,
5902 Defining_Identifier
=> Any
,
5903 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
5907 -- Any := TA_ObjRef (Reference);
5908 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
5911 Statements
:= New_List
(
5912 Make_Assignment_Statement
(Loc
,
5913 Name
=> New_Occurrence_Of
(Any
, Loc
),
5915 Make_Function_Call
(Loc
,
5916 Name
=> New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
5917 Parameter_Associations
=> New_List
(
5918 New_Occurrence_Of
(Reference
, Loc
)))),
5920 Make_Procedure_Call_Statement
(Loc
,
5921 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
5922 Parameter_Associations
=> New_List
(
5923 New_Occurrence_Of
(Any
, Loc
),
5924 Make_Selected_Component
(Loc
,
5926 Defining_Identifier
(
5927 Stub_Elements
.RPC_Receiver_Decl
),
5928 Selector_Name
=> Name_Obj_TypeCode
))),
5930 Make_Simple_Return_Statement
(Loc
,
5931 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
5934 Make_Subprogram_Body
(Loc
,
5935 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
5936 Declarations
=> Decls
,
5937 Handled_Statement_Sequence
=>
5938 Make_Handled_Sequence_Of_Statements
(Loc
,
5939 Statements
=> Statements
));
5940 Append_To
(Body_Decls
, Func_Body
);
5941 end Add_RACW_To_Any
;
5943 -----------------------
5944 -- Add_RACW_TypeCode --
5945 -----------------------
5947 procedure Add_RACW_TypeCode
5948 (Designated_Type
: Entity_Id
;
5949 RACW_Type
: Entity_Id
;
5950 Body_Decls
: List_Id
)
5952 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5954 Fnam
: constant Entity_Id
:=
5955 Make_Defining_Identifier
(Loc
,
5956 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'Y'));
5958 Stub_Elements
: constant Stub_Structure
:=
5959 Stubs_Table
.Get
(Designated_Type
);
5960 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5962 Func_Spec
: Node_Id
;
5963 Func_Decl
: Node_Id
;
5964 Func_Body
: Node_Id
;
5967 -- The spec for this subprogram has a dummy 'access RACW' argument,
5968 -- which serves only for overloading purposes.
5971 Make_Function_Specification
(Loc
,
5972 Defining_Unit_Name
=> Fnam
,
5973 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
5975 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5976 -- entity in the declaration spec, not those of the body spec.
5978 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5979 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5980 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_TypeCode
);
5982 if No
(Body_Decls
) then
5987 Make_Subprogram_Body
(Loc
,
5988 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
5989 Declarations
=> Empty_List
,
5990 Handled_Statement_Sequence
=>
5991 Make_Handled_Sequence_Of_Statements
(Loc
,
5992 Statements
=> New_List
(
5993 Make_Simple_Return_Statement
(Loc
,
5995 Make_Selected_Component
(Loc
,
5998 (Stub_Elements
.RPC_Receiver_Decl
),
5999 Selector_Name
=> Name_Obj_TypeCode
)))));
6001 Append_To
(Body_Decls
, Func_Body
);
6002 end Add_RACW_TypeCode
;
6004 ------------------------------
6005 -- Add_RACW_Write_Attribute --
6006 ------------------------------
6008 procedure Add_RACW_Write_Attribute
6009 (RACW_Type
: Entity_Id
;
6010 Stub_Type
: Entity_Id
;
6011 Stub_Type_Access
: Entity_Id
;
6012 Body_Decls
: List_Id
)
6014 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
6016 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
6018 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
6020 Stub_Elements
: constant Stub_Structure
:=
6021 Get_Stub_Elements
(RACW_Type
);
6023 Body_Node
: Node_Id
;
6024 Proc_Decl
: Node_Id
;
6025 Attr_Decl
: Node_Id
;
6027 Statements
: constant List_Id
:= New_List
;
6028 Pnam
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
6030 function Stream_Parameter
return Node_Id
;
6031 function Object
return Node_Id
;
6032 -- Functions to create occurrences of the formal parameter names
6038 function Object
return Node_Id
is
6040 return Make_Identifier
(Loc
, Name_V
);
6043 ----------------------
6044 -- Stream_Parameter --
6045 ----------------------
6047 function Stream_Parameter
return Node_Id
is
6049 return Make_Identifier
(Loc
, Name_S
);
6050 end Stream_Parameter
;
6052 -- Start of processing for Add_RACW_Write_Attribute
6055 Build_Stream_Procedure
6056 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> False);
6059 Make_Subprogram_Declaration
(Loc
,
6060 Copy_Specification
(Loc
, Specification
(Body_Node
)));
6063 Make_Attribute_Definition_Clause
(Loc
,
6064 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
6065 Chars
=> Name_Write
,
6068 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
6070 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
6071 Insert_After
(Proc_Decl
, Attr_Decl
);
6073 if No
(Body_Decls
) then
6077 Append_To
(Statements
,
6078 Pack_Node_Into_Stream_Access
(Loc
,
6079 Stream
=> Stream_Parameter
,
6081 Make_Function_Call
(Loc
,
6082 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
6083 Parameter_Associations
=> New_List
(
6084 Unchecked_Convert_To
(RTE
(RE_Address
), Object
),
6085 Make_String_Literal
(Loc
,
6086 Strval
=> Full_Qualified_Name
6087 (Etype
(Designated_Type
(RACW_Type
)))),
6088 Build_Stub_Tag
(Loc
, RACW_Type
),
6089 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
6090 Make_Attribute_Reference
(Loc
,
6093 (Defining_Identifier
6094 (Stub_Elements
.RPC_Receiver_Decl
), Loc
),
6095 Attribute_Name
=> Name_Access
))),
6097 Etyp
=> RTE
(RE_Object_Ref
)));
6099 Append_To
(Body_Decls
, Body_Node
);
6100 end Add_RACW_Write_Attribute
;
6102 -----------------------
6103 -- Add_RAST_Features --
6104 -----------------------
6106 procedure Add_RAST_Features
6107 (Vis_Decl
: Node_Id
;
6108 RAS_Type
: Entity_Id
)
6111 Add_RAS_Access_TSS
(Vis_Decl
);
6113 Add_RAS_From_Any
(RAS_Type
);
6114 Add_RAS_TypeCode
(RAS_Type
);
6116 -- To_Any uses TypeCode, and therefore needs to be generated last
6118 Add_RAS_To_Any
(RAS_Type
);
6119 end Add_RAST_Features
;
6121 ------------------------
6122 -- Add_RAS_Access_TSS --
6123 ------------------------
6125 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
6126 Loc
: constant Source_Ptr
:= Sloc
(N
);
6128 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
6129 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
6130 -- Ras_Type is the access to subprogram type; Fat_Type is the
6131 -- corresponding record type.
6133 RACW_Type
: constant Entity_Id
:=
6134 Underlying_RACW_Type
(Ras_Type
);
6136 Stub_Elements
: constant Stub_Structure
:=
6137 Get_Stub_Elements
(RACW_Type
);
6139 Proc
: constant Entity_Id
:=
6140 Make_Defining_Identifier
(Loc
,
6141 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
6143 Proc_Spec
: Node_Id
;
6145 -- Formal parameters
6147 Package_Name
: constant Entity_Id
:=
6148 Make_Defining_Identifier
(Loc
,
6153 Subp_Id
: constant Entity_Id
:=
6154 Make_Defining_Identifier
(Loc
,
6157 -- Target subprogram
6159 Asynch_P
: constant Entity_Id
:=
6160 Make_Defining_Identifier
(Loc
,
6161 Chars
=> Name_Asynchronous
);
6162 -- Is the procedure to which the 'Access applies asynchronous?
6164 All_Calls_Remote
: constant Entity_Id
:=
6165 Make_Defining_Identifier
(Loc
,
6166 Chars
=> Name_All_Calls_Remote
);
6167 -- True if an All_Calls_Remote pragma applies to the RCI unit
6168 -- that contains the subprogram.
6170 -- Common local variables
6172 Proc_Decls
: List_Id
;
6173 Proc_Statements
: List_Id
;
6175 Subp_Ref
: constant Entity_Id
:=
6176 Make_Defining_Identifier
(Loc
, Name_R
);
6177 -- Reference that designates the target subprogram (returned
6178 -- by Get_RAS_Info).
6180 Is_Local
: constant Entity_Id
:=
6181 Make_Defining_Identifier
(Loc
, Name_L
);
6182 Local_Addr
: constant Entity_Id
:=
6183 Make_Defining_Identifier
(Loc
, Name_A
);
6184 -- For the call to Get_Local_Address
6186 Local_Stub
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
6187 Stub_Ptr
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
6188 -- Additional local variables for the remote case
6191 (Field_Name
: Name_Id
;
6192 Value
: Node_Id
) return Node_Id
;
6193 -- Construct an assignment that sets the named component in the
6201 (Field_Name
: Name_Id
;
6202 Value
: Node_Id
) return Node_Id
6206 Make_Assignment_Statement
(Loc
,
6208 Make_Selected_Component
(Loc
,
6210 Selector_Name
=> Field_Name
),
6211 Expression
=> Value
);
6214 -- Start of processing for Add_RAS_Access_TSS
6217 Proc_Decls
:= New_List
(
6219 -- Common declarations
6221 Make_Object_Declaration
(Loc
,
6222 Defining_Identifier
=> Subp_Ref
,
6223 Object_Definition
=>
6224 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
6226 Make_Object_Declaration
(Loc
,
6227 Defining_Identifier
=> Is_Local
,
6228 Object_Definition
=>
6229 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6231 Make_Object_Declaration
(Loc
,
6232 Defining_Identifier
=> Local_Addr
,
6233 Object_Definition
=>
6234 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
6236 Make_Object_Declaration
(Loc
,
6237 Defining_Identifier
=> Local_Stub
,
6238 Aliased_Present
=> True,
6239 Object_Definition
=>
6240 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
6242 Make_Object_Declaration
(Loc
,
6243 Defining_Identifier
=> Stub_Ptr
,
6244 Object_Definition
=>
6245 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
6247 Make_Attribute_Reference
(Loc
,
6248 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
6249 Attribute_Name
=> Name_Unchecked_Access
)));
6251 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
6252 -- Build_Get_Unique_RP_Call needs this information
6254 -- Get_RAS_Info (Pkg, Subp, R);
6255 -- Obtain a reference to the target subprogram
6257 Proc_Statements
:= New_List
(
6258 Make_Procedure_Call_Statement
(Loc
,
6259 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
6260 Parameter_Associations
=> New_List
(
6261 New_Occurrence_Of
(Package_Name
, Loc
),
6262 New_Occurrence_Of
(Subp_Id
, Loc
),
6263 New_Occurrence_Of
(Subp_Ref
, Loc
))),
6265 -- Get_Local_Address (R, L, A);
6266 -- Determine whether the subprogram is local (L), and if so
6267 -- obtain the local address of its proxy (A).
6269 Make_Procedure_Call_Statement
(Loc
,
6270 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6271 Parameter_Associations
=> New_List
(
6272 New_Occurrence_Of
(Subp_Ref
, Loc
),
6273 New_Occurrence_Of
(Is_Local
, Loc
),
6274 New_Occurrence_Of
(Local_Addr
, Loc
))));
6276 -- Note: Here we assume that the Fat_Type is a record containing just
6277 -- an access to a proxy or stub object.
6279 Append_To
(Proc_Statements
,
6283 Make_Implicit_If_Statement
(N
,
6284 Condition
=> New_Occurrence_Of
(Is_Local
, Loc
),
6286 Then_Statements
=> New_List
(
6288 -- if A.Target = null then
6290 Make_Implicit_If_Statement
(N
,
6293 Make_Selected_Component
(Loc
,
6295 Unchecked_Convert_To
6296 (RTE
(RE_RAS_Proxy_Type_Access
),
6297 New_Occurrence_Of
(Local_Addr
, Loc
)),
6298 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)),
6301 Then_Statements
=> New_List
(
6303 -- A.Target := Entity_Of (Ref);
6305 Make_Assignment_Statement
(Loc
,
6307 Make_Selected_Component
(Loc
,
6309 Unchecked_Convert_To
6310 (RTE
(RE_RAS_Proxy_Type_Access
),
6311 New_Occurrence_Of
(Local_Addr
, Loc
)),
6312 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)),
6314 Make_Function_Call
(Loc
,
6315 Name
=> New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6316 Parameter_Associations
=> New_List
(
6317 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6319 -- Inc_Usage (A.Target);
6322 Make_Procedure_Call_Statement
(Loc
,
6323 Name
=> New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6324 Parameter_Associations
=> New_List
(
6325 Make_Selected_Component
(Loc
,
6327 Unchecked_Convert_To
6328 (RTE
(RE_RAS_Proxy_Type_Access
),
6329 New_Occurrence_Of
(Local_Addr
, Loc
)),
6331 Make_Identifier
(Loc
, Name_Target
)))))),
6333 -- if not All_Calls_Remote then
6334 -- return Fat_Type!(A);
6337 Make_Implicit_If_Statement
(N
,
6341 New_Occurrence_Of
(All_Calls_Remote
, Loc
)),
6343 Then_Statements
=> New_List
(
6344 Make_Simple_Return_Statement
(Loc
,
6346 Unchecked_Convert_To
6347 (Fat_Type
, New_Occurrence_Of
(Local_Addr
, Loc
))))))));
6349 Append_List_To
(Proc_Statements
, New_List
(
6351 -- Stub.Target := Entity_Of (Ref);
6353 Set_Field
(Name_Target
,
6354 Make_Function_Call
(Loc
,
6355 Name
=> New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6356 Parameter_Associations
=> New_List
(
6357 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6359 -- Inc_Usage (Stub.Target);
6361 Make_Procedure_Call_Statement
(Loc
,
6362 Name
=> New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6363 Parameter_Associations
=> New_List
(
6364 Make_Selected_Component
(Loc
,
6366 Selector_Name
=> Name_Target
))),
6368 -- E.4.1(9) A remote call is asynchronous if it is a call to
6369 -- a procedure, or a call through a value of an access-to-procedure
6370 -- type, to which a pragma Asynchronous applies.
6372 -- Parameter Asynch_P is true when the procedure is asynchronous;
6373 -- Expression Asynch_T is true when the type is asynchronous.
6375 Set_Field
(Name_Asynchronous
,
6377 Left_Opnd
=> New_Occurrence_Of
(Asynch_P
, Loc
),
6380 (Boolean_Literals
(Is_Asynchronous
(Ras_Type
)), Loc
)))));
6382 Append_List_To
(Proc_Statements
,
6383 Build_Get_Unique_RP_Call
(Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
6385 Append_To
(Proc_Statements
,
6386 Make_Simple_Return_Statement
(Loc
,
6388 Unchecked_Convert_To
(Fat_Type
,
6389 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
6392 Make_Function_Specification
(Loc
,
6393 Defining_Unit_Name
=> Proc
,
6394 Parameter_Specifications
=> New_List
(
6395 Make_Parameter_Specification
(Loc
,
6396 Defining_Identifier
=> Package_Name
,
6398 New_Occurrence_Of
(Standard_String
, Loc
)),
6400 Make_Parameter_Specification
(Loc
,
6401 Defining_Identifier
=> Subp_Id
,
6403 New_Occurrence_Of
(Standard_String
, Loc
)),
6405 Make_Parameter_Specification
(Loc
,
6406 Defining_Identifier
=> Asynch_P
,
6408 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6410 Make_Parameter_Specification
(Loc
,
6411 Defining_Identifier
=> All_Calls_Remote
,
6413 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
6415 Result_Definition
=>
6416 New_Occurrence_Of
(Fat_Type
, Loc
));
6418 -- Set the kind and return type of the function to prevent
6419 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6421 Set_Ekind
(Proc
, E_Function
);
6422 Set_Etype
(Proc
, Fat_Type
);
6425 Make_Subprogram_Body
(Loc
,
6426 Specification
=> Proc_Spec
,
6427 Declarations
=> Proc_Decls
,
6428 Handled_Statement_Sequence
=>
6429 Make_Handled_Sequence_Of_Statements
(Loc
,
6430 Statements
=> Proc_Statements
)));
6432 Set_TSS
(Fat_Type
, Proc
);
6433 end Add_RAS_Access_TSS
;
6435 ----------------------
6436 -- Add_RAS_From_Any --
6437 ----------------------
6439 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
) is
6440 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6442 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6443 Make_TSS_Name
(RAS_Type
, TSS_From_Any
));
6445 Func_Spec
: Node_Id
;
6447 Statements
: List_Id
;
6449 Any_Parameter
: constant Entity_Id
:=
6450 Make_Defining_Identifier
(Loc
, Name_A
);
6453 Statements
:= New_List
(
6454 Make_Simple_Return_Statement
(Loc
,
6456 Make_Aggregate
(Loc
,
6457 Component_Associations
=> New_List
(
6458 Make_Component_Association
(Loc
,
6459 Choices
=> New_List
(
6460 Make_Identifier
(Loc
, Name_Ras
)),
6462 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
6463 Underlying_RACW_Type
(RAS_Type
),
6464 New_Occurrence_Of
(Any_Parameter
, Loc
),
6468 Make_Function_Specification
(Loc
,
6469 Defining_Unit_Name
=> Fnam
,
6470 Parameter_Specifications
=> New_List
(
6471 Make_Parameter_Specification
(Loc
,
6472 Defining_Identifier
=> Any_Parameter
,
6473 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
6474 Result_Definition
=> New_Occurrence_Of
(RAS_Type
, Loc
));
6477 Make_Subprogram_Body
(Loc
,
6478 Specification
=> Func_Spec
,
6479 Declarations
=> No_List
,
6480 Handled_Statement_Sequence
=>
6481 Make_Handled_Sequence_Of_Statements
(Loc
,
6482 Statements
=> Statements
)));
6483 Set_TSS
(RAS_Type
, Fnam
);
6484 end Add_RAS_From_Any
;
6486 --------------------
6487 -- Add_RAS_To_Any --
6488 --------------------
6490 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
) is
6491 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6493 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6494 Make_TSS_Name
(RAS_Type
, TSS_To_Any
));
6497 Statements
: List_Id
;
6499 Func_Spec
: Node_Id
;
6501 Any
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
6502 RAS_Parameter
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
6503 RACW_Parameter
: constant Node_Id
:=
6504 Make_Selected_Component
(Loc
,
6505 Prefix
=> RAS_Parameter
,
6506 Selector_Name
=> Name_Ras
);
6509 -- Object declarations
6511 Set_Etype
(RACW_Parameter
, Underlying_RACW_Type
(RAS_Type
));
6513 Make_Object_Declaration
(Loc
,
6514 Defining_Identifier
=> Any
,
6515 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
6517 PolyORB_Support
.Helpers
.Build_To_Any_Call
6518 (RACW_Parameter
, No_List
)));
6520 Statements
:= New_List
(
6521 Make_Procedure_Call_Statement
(Loc
,
6522 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
6523 Parameter_Associations
=> New_List
(
6524 New_Occurrence_Of
(Any
, Loc
),
6525 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
6528 Make_Simple_Return_Statement
(Loc
,
6529 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
6532 Make_Function_Specification
(Loc
,
6533 Defining_Unit_Name
=> Fnam
,
6534 Parameter_Specifications
=> New_List
(
6535 Make_Parameter_Specification
(Loc
,
6536 Defining_Identifier
=> RAS_Parameter
,
6537 Parameter_Type
=> New_Occurrence_Of
(RAS_Type
, Loc
))),
6538 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
6541 Make_Subprogram_Body
(Loc
,
6542 Specification
=> Func_Spec
,
6543 Declarations
=> Decls
,
6544 Handled_Statement_Sequence
=>
6545 Make_Handled_Sequence_Of_Statements
(Loc
,
6546 Statements
=> Statements
)));
6547 Set_TSS
(RAS_Type
, Fnam
);
6550 ----------------------
6551 -- Add_RAS_TypeCode --
6552 ----------------------
6554 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
) is
6555 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6557 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6558 Make_TSS_Name
(RAS_Type
, TSS_TypeCode
));
6560 Func_Spec
: Node_Id
;
6561 Decls
: constant List_Id
:= New_List
;
6562 Name_String
: String_Id
;
6563 Repo_Id_String
: String_Id
;
6567 Make_Function_Specification
(Loc
,
6568 Defining_Unit_Name
=> Fnam
,
6569 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6571 PolyORB_Support
.Helpers
.Build_Name_And_Repository_Id
6572 (RAS_Type
, Name_Str
=> Name_String
, Repo_Id_Str
=> Repo_Id_String
);
6575 Make_Subprogram_Body
(Loc
,
6576 Specification
=> Func_Spec
,
6577 Declarations
=> Decls
,
6578 Handled_Statement_Sequence
=>
6579 Make_Handled_Sequence_Of_Statements
(Loc
,
6580 Statements
=> New_List
(
6581 Make_Simple_Return_Statement
(Loc
,
6583 Make_Function_Call
(Loc
,
6584 Name
=> New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
6585 Parameter_Associations
=> New_List
(
6586 New_Occurrence_Of
(RTE
(RE_TC_Object
), Loc
),
6587 Make_Aggregate
(Loc
,
6590 Make_Function_Call
(Loc
,
6593 (RTE
(RE_TA_Std_String
), Loc
),
6594 Parameter_Associations
=> New_List
(
6595 Make_String_Literal
(Loc
, Name_String
))),
6596 Make_Function_Call
(Loc
,
6599 (RTE
(RE_TA_Std_String
), Loc
),
6600 Parameter_Associations
=> New_List
(
6601 Make_String_Literal
(Loc
,
6602 Strval
=> Repo_Id_String
))))))))))));
6603 Set_TSS
(RAS_Type
, Fnam
);
6604 end Add_RAS_TypeCode
;
6606 -----------------------------------------
6607 -- Add_Receiving_Stubs_To_Declarations --
6608 -----------------------------------------
6610 procedure Add_Receiving_Stubs_To_Declarations
6611 (Pkg_Spec
: Node_Id
;
6615 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
6617 Pkg_RPC_Receiver
: constant Entity_Id
:=
6618 Make_Temporary
(Loc
, 'H');
6619 Pkg_RPC_Receiver_Object
: Node_Id
;
6620 Pkg_RPC_Receiver_Body
: Node_Id
;
6621 Pkg_RPC_Receiver_Decls
: List_Id
;
6622 Pkg_RPC_Receiver_Statements
: List_Id
;
6624 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
6625 -- A Pkg_RPC_Receiver is built to decode the request
6628 -- Request object received from neutral layer
6630 Subp_Id
: Entity_Id
;
6631 -- Subprogram identifier as received from the neutral distribution
6634 Subp_Index
: Entity_Id
;
6635 -- Internal index as determined by matching either the method name
6636 -- from the request structure, or the local subprogram address (in
6639 Is_Local
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
6641 Local_Address
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
6642 -- Address of a local subprogram designated by a reference
6643 -- corresponding to a RAS.
6645 Dispatch_On_Address
: constant List_Id
:= New_List
;
6646 Dispatch_On_Name
: constant List_Id
:= New_List
;
6648 Current_Declaration
: Node_Id
;
6649 Current_Stubs
: Node_Id
;
6650 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
6652 Subp_Info_Array
: constant Entity_Id
:= Make_Temporary
(Loc
, 'I');
6654 Subp_Info_List
: constant List_Id
:= New_List
;
6656 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
6658 All_Calls_Remote_E
: Entity_Id
;
6660 procedure Append_Stubs_To
6661 (RPC_Receiver_Cases
: List_Id
;
6662 Declaration
: Node_Id
;
6665 Subp_Dist_Name
: Entity_Id
;
6666 Subp_Proxy_Addr
: Entity_Id
);
6667 -- Add one case to the specified RPC receiver case list associating
6668 -- Subprogram_Number with the subprogram declared by Declaration, for
6669 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6670 -- subprogram index. Subp_Dist_Name is the string used to call the
6671 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6672 -- object, used in the context of calls through remote
6673 -- access-to-subprogram types.
6675 ---------------------
6676 -- Append_Stubs_To --
6677 ---------------------
6679 procedure Append_Stubs_To
6680 (RPC_Receiver_Cases
: List_Id
;
6681 Declaration
: Node_Id
;
6684 Subp_Dist_Name
: Entity_Id
;
6685 Subp_Proxy_Addr
: Entity_Id
)
6687 Case_Stmts
: List_Id
;
6689 Case_Stmts
:= New_List
(
6690 Make_Procedure_Call_Statement
(Loc
,
6693 Defining_Entity
(Stubs
), Loc
),
6694 Parameter_Associations
=>
6695 New_List
(New_Occurrence_Of
(Request
, Loc
))));
6697 if Nkind
(Specification
(Declaration
)) = N_Function_Specification
6699 Is_Asynchronous
(Defining_Entity
(Specification
(Declaration
)))
6701 Append_To
(Case_Stmts
, Make_Simple_Return_Statement
(Loc
));
6704 Append_To
(RPC_Receiver_Cases
,
6705 Make_Case_Statement_Alternative
(Loc
,
6707 New_List
(Make_Integer_Literal
(Loc
, Subp_Number
)),
6708 Statements
=> Case_Stmts
));
6710 Append_To
(Dispatch_On_Name
,
6711 Make_Elsif_Part
(Loc
,
6713 Make_Function_Call
(Loc
,
6715 New_Occurrence_Of
(RTE
(RE_Caseless_String_Eq
), Loc
),
6716 Parameter_Associations
=> New_List
(
6717 New_Occurrence_Of
(Subp_Id
, Loc
),
6718 New_Occurrence_Of
(Subp_Dist_Name
, Loc
))),
6720 Then_Statements
=> New_List
(
6721 Make_Assignment_Statement
(Loc
,
6722 New_Occurrence_Of
(Subp_Index
, Loc
),
6723 Make_Integer_Literal
(Loc
, Subp_Number
)))));
6725 Append_To
(Dispatch_On_Address
,
6726 Make_Elsif_Part
(Loc
,
6729 Left_Opnd
=> New_Occurrence_Of
(Local_Address
, Loc
),
6730 Right_Opnd
=> New_Occurrence_Of
(Subp_Proxy_Addr
, Loc
)),
6732 Then_Statements
=> New_List
(
6733 Make_Assignment_Statement
(Loc
,
6734 New_Occurrence_Of
(Subp_Index
, Loc
),
6735 Make_Integer_Literal
(Loc
, Subp_Number
)))));
6736 end Append_Stubs_To
;
6738 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6741 -- Building receiving stubs consist in several operations:
6743 -- - a package RPC receiver must be built. This subprogram will get
6744 -- a Subprogram_Id from the incoming stream and will dispatch the
6745 -- call to the right subprogram;
6747 -- - a receiving stub for each subprogram visible in the package
6748 -- spec. This stub will read all the parameters from the stream,
6749 -- and put the result as well as the exception occurrence in the
6752 Build_RPC_Receiver_Body
(
6753 RPC_Receiver
=> Pkg_RPC_Receiver
,
6756 Subp_Index
=> Subp_Index
,
6757 Stmts
=> Pkg_RPC_Receiver_Statements
,
6758 Decl
=> Pkg_RPC_Receiver_Body
);
6759 Pkg_RPC_Receiver_Decls
:= Declarations
(Pkg_RPC_Receiver_Body
);
6761 -- Extract local address information from the target reference:
6762 -- if non-null, that means that this is a reference that denotes
6763 -- one particular operation, and hence that the operation name
6764 -- must not be taken into account for dispatching.
6766 Append_To
(Pkg_RPC_Receiver_Decls
,
6767 Make_Object_Declaration
(Loc
,
6768 Defining_Identifier
=> Is_Local
,
6769 Object_Definition
=>
6770 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
6772 Append_To
(Pkg_RPC_Receiver_Decls
,
6773 Make_Object_Declaration
(Loc
,
6774 Defining_Identifier
=> Local_Address
,
6775 Object_Definition
=>
6776 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6778 Append_To
(Pkg_RPC_Receiver_Statements
,
6779 Make_Procedure_Call_Statement
(Loc
,
6780 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6781 Parameter_Associations
=> New_List
(
6782 Make_Selected_Component
(Loc
,
6784 Selector_Name
=> Name_Target
),
6785 New_Occurrence_Of
(Is_Local
, Loc
),
6786 New_Occurrence_Of
(Local_Address
, Loc
))));
6788 -- For each subprogram, the receiving stub will be built and a case
6789 -- statement will be made on the Subprogram_Id to dispatch to the
6790 -- right subprogram.
6792 All_Calls_Remote_E
:= Boolean_Literals
(
6793 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
6795 Overload_Counter_Table
.Reset
;
6796 Reserve_NamingContext_Methods
;
6798 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
6799 while Present
(Current_Declaration
) loop
6800 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
6801 and then Comes_From_Source
(Current_Declaration
)
6804 Loc
: constant Source_Ptr
:= Sloc
(Current_Declaration
);
6805 -- While specifically processing Current_Declaration, use
6806 -- its Sloc as the location of all generated nodes.
6808 Subp_Def
: constant Entity_Id
:=
6810 (Specification
(Current_Declaration
));
6812 Subp_Val
: String_Id
;
6814 Subp_Dist_Name
: constant Entity_Id
:=
6815 Make_Defining_Identifier
(Loc
,
6818 (Related_Id
=> Chars
(Subp_Def
),
6820 Suffix_Index
=> -1));
6822 Proxy_Object_Addr
: Entity_Id
;
6825 -- Build receiving stub
6828 Build_Subprogram_Receiving_Stubs
6829 (Vis_Decl
=> Current_Declaration
,
6831 Nkind
(Specification
(Current_Declaration
)) =
6832 N_Procedure_Specification
6833 and then Is_Asynchronous
(Subp_Def
));
6835 Append_To
(Decls
, Current_Stubs
);
6836 Analyze
(Current_Stubs
);
6840 Add_RAS_Proxy_And_Analyze
(Decls
,
6841 Vis_Decl
=> Current_Declaration
,
6842 All_Calls_Remote_E
=> All_Calls_Remote_E
,
6843 Proxy_Object_Addr
=> Proxy_Object_Addr
);
6845 -- Compute distribution identifier
6847 Assign_Subprogram_Identifier
6849 Current_Subprogram_Number
,
6853 (Current_Subprogram_Number
= Get_Subprogram_Id
(Subp_Def
));
6856 Make_Object_Declaration
(Loc
,
6857 Defining_Identifier
=> Subp_Dist_Name
,
6858 Constant_Present
=> True,
6859 Object_Definition
=>
6860 New_Occurrence_Of
(Standard_String
, Loc
),
6862 Make_String_Literal
(Loc
, Subp_Val
)));
6863 Analyze
(Last
(Decls
));
6865 -- Add subprogram descriptor (RCI_Subp_Info) to the
6866 -- subprograms table for this receiver. The aggregate
6867 -- below must be kept consistent with the declaration
6868 -- of type RCI_Subp_Info in System.Partition_Interface.
6870 Append_To
(Subp_Info_List
,
6871 Make_Component_Association
(Loc
,
6872 Choices
=> New_List
(
6873 Make_Integer_Literal
(Loc
, Current_Subprogram_Number
)),
6876 Make_Aggregate
(Loc
,
6877 Expressions
=> New_List
(
6878 Make_Attribute_Reference
(Loc
,
6880 New_Occurrence_Of
(Subp_Dist_Name
, Loc
),
6881 Attribute_Name
=> Name_Address
),
6883 Make_Attribute_Reference
(Loc
,
6885 New_Occurrence_Of
(Subp_Dist_Name
, Loc
),
6886 Attribute_Name
=> Name_Length
),
6888 New_Occurrence_Of
(Proxy_Object_Addr
, Loc
)))));
6890 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
6891 Declaration
=> Current_Declaration
,
6892 Stubs
=> Current_Stubs
,
6893 Subp_Number
=> Current_Subprogram_Number
,
6894 Subp_Dist_Name
=> Subp_Dist_Name
,
6895 Subp_Proxy_Addr
=> Proxy_Object_Addr
);
6898 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
6901 Next
(Current_Declaration
);
6905 Make_Object_Declaration
(Loc
,
6906 Defining_Identifier
=> Subp_Info_Array
,
6907 Constant_Present
=> True,
6908 Aliased_Present
=> True,
6909 Object_Definition
=>
6910 Make_Subtype_Indication
(Loc
,
6912 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
6914 Make_Index_Or_Discriminant_Constraint
(Loc
,
6918 Make_Integer_Literal
(Loc
,
6919 Intval
=> First_RCI_Subprogram_Id
),
6921 Make_Integer_Literal
(Loc
,
6923 First_RCI_Subprogram_Id
6924 + List_Length
(Subp_Info_List
) - 1)))))));
6926 if Present
(First
(Subp_Info_List
)) then
6927 Set_Expression
(Last
(Decls
),
6928 Make_Aggregate
(Loc
,
6929 Component_Associations
=> Subp_Info_List
));
6931 -- Generate the dispatch statement to determine the subprogram id
6932 -- of the called subprogram.
6934 -- We first test whether the reference that was used to make the
6935 -- call was the base RCI reference (in which case Local_Address is
6936 -- zero, and the method identifier from the request must be used
6937 -- to determine which subprogram is called) or a reference
6938 -- identifying one particular subprogram (in which case
6939 -- Local_Address is the address of that subprogram, and the
6940 -- method name from the request is ignored). The latter occurs
6941 -- for the case of a call through a remote access-to-subprogram.
6943 -- In each case, cascaded elsifs are used to determine the proper
6944 -- subprogram index. Using hash tables might be more efficient.
6946 Append_To
(Pkg_RPC_Receiver_Statements
,
6947 Make_Implicit_If_Statement
(Pkg_Spec
,
6950 Left_Opnd
=> New_Occurrence_Of
(Local_Address
, Loc
),
6951 Right_Opnd
=> New_Occurrence_Of
6952 (RTE
(RE_Null_Address
), Loc
)),
6954 Then_Statements
=> New_List
(
6955 Make_Implicit_If_Statement
(Pkg_Spec
,
6956 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
6957 Then_Statements
=> New_List
(
6958 Make_Null_Statement
(Loc
)),
6959 Elsif_Parts
=> Dispatch_On_Address
)),
6961 Else_Statements
=> New_List
(
6962 Make_Implicit_If_Statement
(Pkg_Spec
,
6963 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
6964 Then_Statements
=> New_List
(Make_Null_Statement
(Loc
)),
6965 Elsif_Parts
=> Dispatch_On_Name
))));
6968 -- For a degenerate RCI with no visible subprograms,
6969 -- Subp_Info_List has zero length, and the declaration is for an
6970 -- empty array, in which case no initialization aggregate must be
6971 -- generated. We do not generate a Dispatch_Statement either.
6973 -- No initialization provided: remove CONSTANT so that the
6974 -- declaration is not an incomplete deferred constant.
6976 Set_Constant_Present
(Last
(Decls
), False);
6979 -- Analyze Subp_Info_Array declaration
6981 Analyze
(Last
(Decls
));
6983 -- If we receive an invalid Subprogram_Id, it is best to do nothing
6984 -- rather than raising an exception since we do not want someone
6985 -- to crash a remote partition by sending invalid subprogram ids.
6986 -- This is consistent with the other parts of the case statement
6987 -- since even in presence of incorrect parameters in the stream,
6988 -- every exception will be caught and (if the subprogram is not an
6989 -- APC) put into the result stream and sent away.
6991 Append_To
(Pkg_RPC_Receiver_Cases
,
6992 Make_Case_Statement_Alternative
(Loc
,
6993 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
6994 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
6996 Append_To
(Pkg_RPC_Receiver_Statements
,
6997 Make_Case_Statement
(Loc
,
6998 Expression
=> New_Occurrence_Of
(Subp_Index
, Loc
),
6999 Alternatives
=> Pkg_RPC_Receiver_Cases
));
7001 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7004 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
7005 Analyze
(Last
(Decls
));
7007 Pkg_RPC_Receiver_Object
:=
7008 Make_Object_Declaration
(Loc
,
7009 Defining_Identifier
=> Make_Temporary
(Loc
, 'R'),
7010 Aliased_Present
=> True,
7011 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7012 Append_To
(Decls
, Pkg_RPC_Receiver_Object
);
7013 Analyze
(Last
(Decls
));
7015 Get_Library_Unit_Name_String
(Pkg_Spec
);
7019 Append_To
(Register_Pkg_Actuals
,
7020 Make_String_Literal
(Loc
,
7021 Strval
=> String_From_Name_Buffer
));
7025 Append_To
(Register_Pkg_Actuals
,
7026 Make_Attribute_Reference
(Loc
,
7029 (Defining_Entity
(Pkg_Spec
), Loc
),
7030 Attribute_Name
=> Name_Version
));
7034 Append_To
(Register_Pkg_Actuals
,
7035 Make_Attribute_Reference
(Loc
,
7037 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
7038 Attribute_Name
=> Name_Access
));
7042 Append_To
(Register_Pkg_Actuals
,
7043 Make_Attribute_Reference
(Loc
,
7046 Defining_Identifier
(Pkg_RPC_Receiver_Object
), Loc
),
7047 Attribute_Name
=> Name_Access
));
7051 Append_To
(Register_Pkg_Actuals
,
7052 Make_Attribute_Reference
(Loc
,
7053 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
7054 Attribute_Name
=> Name_Address
));
7058 Append_To
(Register_Pkg_Actuals
,
7059 Make_Attribute_Reference
(Loc
,
7060 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
7061 Attribute_Name
=> Name_Length
));
7063 -- Is_All_Calls_Remote
7065 Append_To
(Register_Pkg_Actuals
,
7066 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
));
7068 -- Finally call Register_Pkg_Receiving_Stub with the above parameters
7071 Make_Procedure_Call_Statement
(Loc
,
7073 New_Occurrence_Of
(RTE
(RE_Register_Pkg_Receiving_Stub
), Loc
),
7074 Parameter_Associations
=> Register_Pkg_Actuals
));
7075 Analyze
(Last
(Stmts
));
7076 end Add_Receiving_Stubs_To_Declarations
;
7078 ---------------------------------
7079 -- Build_General_Calling_Stubs --
7080 ---------------------------------
7082 procedure Build_General_Calling_Stubs
7084 Statements
: List_Id
;
7085 Target_Object
: Node_Id
;
7086 Subprogram_Id
: Node_Id
;
7087 Asynchronous
: Node_Id
:= Empty
;
7088 Is_Known_Asynchronous
: Boolean := False;
7089 Is_Known_Non_Asynchronous
: Boolean := False;
7090 Is_Function
: Boolean;
7092 Stub_Type
: Entity_Id
:= Empty
;
7093 RACW_Type
: Entity_Id
:= Empty
;
7096 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
7098 Request
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
7099 -- The request object constructed by these stubs
7100 -- Could we use Name_R instead??? (see GLADE client stubs)
7102 function Make_Request_RTE_Call
7104 Actuals
: List_Id
:= New_List
) return Node_Id
;
7105 -- Generate a procedure call statement calling RE with the given
7106 -- actuals. Request is appended to the list.
7108 ---------------------------
7109 -- Make_Request_RTE_Call --
7110 ---------------------------
7112 function Make_Request_RTE_Call
7114 Actuals
: List_Id
:= New_List
) return Node_Id
7117 Append_To
(Actuals
, New_Occurrence_Of
(Request
, Loc
));
7118 return Make_Procedure_Call_Statement
(Loc
,
7120 New_Occurrence_Of
(RTE
(RE
), Loc
),
7121 Parameter_Associations
=> Actuals
);
7122 end Make_Request_RTE_Call
;
7124 Arguments
: Node_Id
;
7125 -- Name of the named values list used to transmit parameters
7126 -- to the remote package
7129 -- Name of the result named value (in non-APC cases) which get the
7130 -- result of the remote subprogram.
7132 Result_TC
: Node_Id
;
7133 -- Typecode expression for the result of the request (void
7134 -- typecode for procedures).
7136 Exception_Return_Parameter
: Node_Id
;
7137 -- Name of the parameter which will hold the exception sent by the
7138 -- remote subprogram.
7140 Current_Parameter
: Node_Id
;
7141 -- Current parameter being handled
7143 Ordered_Parameters_List
: constant List_Id
:=
7144 Build_Ordered_Parameters_List
(Spec
);
7146 Asynchronous_P
: Node_Id
;
7147 -- A Boolean expression indicating whether this call is asynchronous
7149 Asynchronous_Statements
: List_Id
:= No_List
;
7150 Non_Asynchronous_Statements
: List_Id
:= No_List
;
7151 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7153 Extra_Formal_Statements
: constant List_Id
:= New_List
;
7154 -- List of statements for extra formal parameters. It will appear
7155 -- after the regular statements for writing out parameters.
7157 After_Statements
: constant List_Id
:= New_List
;
7158 -- Statements to be executed after call returns (to assign IN OUT or
7159 -- OUT parameter values).
7162 -- The type of the formal parameter being processed
7164 Is_Controlling_Formal
: Boolean;
7165 Is_First_Controlling_Formal
: Boolean;
7166 First_Controlling_Formal_Seen
: Boolean := False;
7167 -- Controlling formal parameters of distributed object primitives
7168 -- require special handling, and the first such parameter needs even
7169 -- more special handling.
7172 -- ??? document general form of stub subprograms for the PolyORB case
7175 Make_Object_Declaration
(Loc
,
7176 Defining_Identifier
=> Request
,
7177 Aliased_Present
=> False,
7178 Object_Definition
=>
7179 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
)));
7181 Result
:= Make_Temporary
(Loc
, 'R');
7185 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7186 (Loc
, Etype
(Result_Definition
(Spec
)), Decls
);
7188 Result_TC
:= New_Occurrence_Of
(RTE
(RE_TC_Void
), Loc
);
7192 Make_Object_Declaration
(Loc
,
7193 Defining_Identifier
=> Result
,
7194 Aliased_Present
=> False,
7195 Object_Definition
=>
7196 New_Occurrence_Of
(RTE
(RE_NamedValue
), Loc
),
7198 Make_Aggregate
(Loc
,
7199 Component_Associations
=> New_List
(
7200 Make_Component_Association
(Loc
,
7201 Choices
=> New_List
(Make_Identifier
(Loc
, Name_Name
)),
7203 New_Occurrence_Of
(RTE
(RE_Result_Name
), Loc
)),
7204 Make_Component_Association
(Loc
,
7205 Choices
=> New_List
(
7206 Make_Identifier
(Loc
, Name_Argument
)),
7208 Make_Function_Call
(Loc
,
7209 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7210 Parameter_Associations
=> New_List
(Result_TC
))),
7211 Make_Component_Association
(Loc
,
7212 Choices
=> New_List
(
7213 Make_Identifier
(Loc
, Name_Arg_Modes
)),
7214 Expression
=> Make_Integer_Literal
(Loc
, 0))))));
7216 if not Is_Known_Asynchronous
then
7217 Exception_Return_Parameter
:= Make_Temporary
(Loc
, 'E');
7220 Make_Object_Declaration
(Loc
,
7221 Defining_Identifier
=> Exception_Return_Parameter
,
7222 Object_Definition
=>
7223 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
7226 Exception_Return_Parameter
:= Empty
;
7229 -- Initialize and fill in arguments list
7231 Arguments
:= Make_Temporary
(Loc
, 'A');
7232 Declare_Create_NVList
(Loc
, Arguments
, Decls
, Statements
);
7234 Current_Parameter
:= First
(Ordered_Parameters_List
);
7235 while Present
(Current_Parameter
) loop
7236 if Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
) then
7237 Is_Controlling_Formal
:= True;
7238 Is_First_Controlling_Formal
:=
7239 not First_Controlling_Formal_Seen
;
7240 First_Controlling_Formal_Seen
:= True;
7243 Is_Controlling_Formal
:= False;
7244 Is_First_Controlling_Formal
:= False;
7247 if Is_Controlling_Formal
then
7249 -- For a controlling formal argument, we send its reference
7254 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7257 -- The first controlling formal parameter is treated specially:
7258 -- it is used to set the target object of the call.
7260 if not Is_First_Controlling_Formal
then
7262 Constrained
: constant Boolean :=
7263 Is_Constrained
(Etyp
)
7264 or else Is_Elementary_Type
(Etyp
);
7266 Any
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
7268 Actual_Parameter
: Node_Id
:=
7270 Defining_Identifier
(
7271 Current_Parameter
), Loc
);
7276 if Is_Controlling_Formal
then
7278 -- For a controlling formal parameter (other than the
7279 -- first one), use the corresponding RACW. If the
7280 -- parameter is not an anonymous access parameter, that
7281 -- involves taking its 'Unrestricted_Access.
7283 if Nkind
(Parameter_Type
(Current_Parameter
))
7284 = N_Access_Definition
7286 Actual_Parameter
:= OK_Convert_To
7287 (Etyp
, Actual_Parameter
);
7289 Actual_Parameter
:= OK_Convert_To
(Etyp
,
7290 Make_Attribute_Reference
(Loc
,
7291 Prefix
=> Actual_Parameter
,
7292 Attribute_Name
=> Name_Unrestricted_Access
));
7297 if In_Present
(Current_Parameter
)
7298 or else not Out_Present
(Current_Parameter
)
7299 or else not Constrained
7300 or else Is_Controlling_Formal
7302 -- The parameter has an input value, is constrained at
7303 -- runtime by an input value, or is a controlling formal
7304 -- parameter (always passed as a reference) other than
7307 Expr
:= PolyORB_Support
.Helpers
.Build_To_Any_Call
7308 (Actual_Parameter
, Decls
);
7311 Expr
:= Make_Function_Call
(Loc
,
7312 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7313 Parameter_Associations
=> New_List
(
7314 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7315 (Loc
, Etyp
, Decls
)));
7319 Make_Object_Declaration
(Loc
,
7320 Defining_Identifier
=> Any
,
7321 Aliased_Present
=> False,
7322 Object_Definition
=>
7323 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7324 Expression
=> Expr
));
7326 Append_To
(Statements
,
7327 Add_Parameter_To_NVList
(Loc
,
7328 Parameter
=> Current_Parameter
,
7329 NVList
=> Arguments
,
7330 Constrained
=> Constrained
,
7333 if Out_Present
(Current_Parameter
)
7334 and then not Is_Controlling_Formal
7336 if Is_Limited_Type
(Etyp
) then
7337 Helpers
.Assign_Opaque_From_Any
(Loc
,
7338 Stms
=> After_Statements
,
7340 N
=> New_Occurrence_Of
(Any
, Loc
),
7342 Defining_Identifier
(Current_Parameter
));
7344 Append_To
(After_Statements
,
7345 Make_Assignment_Statement
(Loc
,
7348 Defining_Identifier
(Current_Parameter
), Loc
),
7350 PolyORB_Support
.Helpers
.Build_From_Any_Call
7352 New_Occurrence_Of
(Any
, Loc
),
7359 -- If the current parameter has a dynamic constrained status, then
7360 -- this status is transmitted as well.
7361 -- This should be done for accessibility as well ???
7363 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7365 and then Need_Extra_Constrained
(Current_Parameter
)
7367 -- In this block, we do not use the extra formal that has been
7368 -- created because it does not exist at the time of expansion
7369 -- when building calling stubs for remote access to subprogram
7370 -- types. We create an extra variable of this type and push it
7371 -- in the stream after the regular parameters.
7374 Extra_Any_Parameter
: constant Entity_Id
:=
7375 Make_Temporary
(Loc
, 'P');
7377 Parameter_Exp
: constant Node_Id
:=
7378 Make_Attribute_Reference
(Loc
,
7379 Prefix
=> New_Occurrence_Of
(
7380 Defining_Identifier
(Current_Parameter
), Loc
),
7381 Attribute_Name
=> Name_Constrained
);
7384 Set_Etype
(Parameter_Exp
, Etype
(Standard_Boolean
));
7387 Make_Object_Declaration
(Loc
,
7388 Defining_Identifier
=> Extra_Any_Parameter
,
7389 Aliased_Present
=> False,
7390 Object_Definition
=>
7391 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7393 PolyORB_Support
.Helpers
.Build_To_Any_Call
7394 (Parameter_Exp
, Decls
)));
7396 Append_To
(Extra_Formal_Statements
,
7397 Add_Parameter_To_NVList
(Loc
,
7398 Parameter
=> Extra_Any_Parameter
,
7399 NVList
=> Arguments
,
7400 Constrained
=> True,
7401 Any
=> Extra_Any_Parameter
));
7405 Next
(Current_Parameter
);
7408 -- Append the formal statements list to the statements
7410 Append_List_To
(Statements
, Extra_Formal_Statements
);
7412 Append_To
(Statements
,
7413 Make_Request_RTE_Call
(RE_Request_Create
, New_List
(
7416 New_Occurrence_Of
(Arguments
, Loc
),
7417 New_Occurrence_Of
(Result
, Loc
),
7419 (RTE
(RE_Nil_Exc_List
), Loc
))));
7422 (not (Is_Known_Non_Asynchronous
and Is_Known_Asynchronous
));
7424 if Is_Known_Non_Asynchronous
or Is_Known_Asynchronous
then
7427 (Boolean_Literals
(Is_Known_Asynchronous
), Loc
);
7430 pragma Assert
(Present
(Asynchronous
));
7431 Asynchronous_P
:= New_Copy_Tree
(Asynchronous
);
7433 -- The expression node Asynchronous will be used to build an 'if'
7434 -- statement at the end of Build_General_Calling_Stubs: we need to
7435 -- make a copy here.
7438 Append_To
(Parameter_Associations
(Last
(Statements
)),
7439 Make_Indexed_Component
(Loc
,
7442 RTE
(RE_Asynchronous_P_To_Sync_Scope
), Loc
),
7443 Expressions
=> New_List
(Asynchronous_P
)));
7445 Append_To
(Statements
, Make_Request_RTE_Call
(RE_Request_Invoke
));
7447 -- Asynchronous case
7449 if not Is_Known_Non_Asynchronous
then
7450 Asynchronous_Statements
:=
7451 New_List
(Make_Request_RTE_Call
(RE_Request_Destroy
));
7454 -- Non-asynchronous case
7456 if not Is_Known_Asynchronous
then
7457 -- Reraise an exception occurrence from the completed request.
7458 -- If the exception occurrence is empty, this is a no-op.
7460 Non_Asynchronous_Statements
:= New_List
(
7461 Make_Procedure_Call_Statement
(Loc
,
7463 New_Occurrence_Of
(RTE
(RE_Request_Raise_Occurrence
), Loc
),
7464 Parameter_Associations
=> New_List
(
7465 New_Occurrence_Of
(Request
, Loc
))));
7469 Append_To
(Non_Asynchronous_Statements
,
7470 Make_Request_RTE_Call
(RE_Request_Destroy
));
7472 -- If this is a function call, read the value and return it
7474 Append_To
(Non_Asynchronous_Statements
,
7475 Make_Tag_Check
(Loc
,
7476 Make_Simple_Return_Statement
(Loc
,
7477 PolyORB_Support
.Helpers
.Build_From_Any_Call
7478 (Etype
(Result_Definition
(Spec
)),
7479 Make_Selected_Component
(Loc
,
7481 Selector_Name
=> Name_Argument
),
7486 -- Case of a procedure: deal with IN OUT and OUT formals
7488 Append_List_To
(Non_Asynchronous_Statements
, After_Statements
);
7490 Append_To
(Non_Asynchronous_Statements
,
7491 Make_Request_RTE_Call
(RE_Request_Destroy
));
7495 if Is_Known_Asynchronous
then
7496 Append_List_To
(Statements
, Asynchronous_Statements
);
7498 elsif Is_Known_Non_Asynchronous
then
7499 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
7502 pragma Assert
(Present
(Asynchronous
));
7503 Append_To
(Statements
,
7504 Make_Implicit_If_Statement
(Nod
,
7505 Condition
=> Asynchronous
,
7506 Then_Statements
=> Asynchronous_Statements
,
7507 Else_Statements
=> Non_Asynchronous_Statements
));
7509 end Build_General_Calling_Stubs
;
7511 -----------------------
7512 -- Build_Stub_Target --
7513 -----------------------
7515 function Build_Stub_Target
7518 RCI_Locator
: Entity_Id
;
7519 Controlling_Parameter
: Entity_Id
) return RPC_Target
7521 Target_Info
: RPC_Target
(PCS_Kind
=> Name_PolyORB_DSA
);
7522 Target_Reference
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
7525 if Present
(Controlling_Parameter
) then
7527 Make_Object_Declaration
(Loc
,
7528 Defining_Identifier
=> Target_Reference
,
7530 Object_Definition
=>
7531 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
7534 Make_Function_Call
(Loc
,
7536 New_Occurrence_Of
(RTE
(RE_Make_Ref
), Loc
),
7537 Parameter_Associations
=> New_List
(
7538 Make_Selected_Component
(Loc
,
7539 Prefix
=> Controlling_Parameter
,
7540 Selector_Name
=> Name_Target
)))));
7542 -- Note: Controlling_Parameter has the same components as
7543 -- System.Partition_Interface.RACW_Stub_Type.
7545 Target_Info
.Object
:= New_Occurrence_Of
(Target_Reference
, Loc
);
7548 Target_Info
.Object
:=
7549 Make_Selected_Component
(Loc
,
7550 Prefix
=> Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
7552 Make_Identifier
(Loc
, Name_Get_RCI_Package_Ref
));
7556 end Build_Stub_Target
;
7558 ---------------------
7559 -- Build_Stub_Type --
7560 ---------------------
7562 procedure Build_Stub_Type
7563 (RACW_Type
: Entity_Id
;
7564 Stub_Type_Comps
: out List_Id
;
7565 RPC_Receiver_Decl
: out Node_Id
)
7567 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
7570 Stub_Type_Comps
:= New_List
(
7571 Make_Component_Declaration
(Loc
,
7572 Defining_Identifier
=>
7573 Make_Defining_Identifier
(Loc
, Name_Target
),
7574 Component_Definition
=>
7575 Make_Component_Definition
(Loc
,
7576 Aliased_Present
=> False,
7577 Subtype_Indication
=>
7578 New_Occurrence_Of
(RTE
(RE_Entity_Ptr
), Loc
))),
7580 Make_Component_Declaration
(Loc
,
7581 Defining_Identifier
=>
7582 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
7584 Component_Definition
=>
7585 Make_Component_Definition
(Loc
,
7586 Aliased_Present
=> False,
7587 Subtype_Indication
=>
7588 New_Occurrence_Of
(Standard_Boolean
, Loc
))));
7590 RPC_Receiver_Decl
:=
7591 Make_Object_Declaration
(Loc
,
7592 Defining_Identifier
=> Make_Temporary
(Loc
, 'R'),
7593 Aliased_Present
=> True,
7594 Object_Definition
=>
7595 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7596 end Build_Stub_Type
;
7598 -----------------------------
7599 -- Build_RPC_Receiver_Body --
7600 -----------------------------
7602 procedure Build_RPC_Receiver_Body
7603 (RPC_Receiver
: Entity_Id
;
7604 Request
: out Entity_Id
;
7605 Subp_Id
: out Entity_Id
;
7606 Subp_Index
: out Entity_Id
;
7607 Stmts
: out List_Id
;
7610 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
7612 RPC_Receiver_Spec
: Node_Id
;
7613 RPC_Receiver_Decls
: List_Id
;
7616 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
7618 RPC_Receiver_Spec
:=
7619 Build_RPC_Receiver_Specification
7620 (RPC_Receiver
=> RPC_Receiver
,
7621 Request_Parameter
=> Request
);
7623 Subp_Id
:= Make_Defining_Identifier
(Loc
, Name_P
);
7624 Subp_Index
:= Make_Defining_Identifier
(Loc
, Name_I
);
7626 RPC_Receiver_Decls
:= New_List
(
7627 Make_Object_Renaming_Declaration
(Loc
,
7628 Defining_Identifier
=> Subp_Id
,
7629 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
7631 Make_Explicit_Dereference
(Loc
,
7633 Make_Selected_Component
(Loc
,
7635 Selector_Name
=> Name_Operation
))),
7637 Make_Object_Declaration
(Loc
,
7638 Defining_Identifier
=> Subp_Index
,
7639 Object_Definition
=>
7640 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7642 Make_Attribute_Reference
(Loc
,
7644 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7645 Attribute_Name
=> Name_Last
)));
7650 Make_Subprogram_Body
(Loc
,
7651 Specification
=> RPC_Receiver_Spec
,
7652 Declarations
=> RPC_Receiver_Decls
,
7653 Handled_Statement_Sequence
=>
7654 Make_Handled_Sequence_Of_Statements
(Loc
,
7655 Statements
=> Stmts
));
7656 end Build_RPC_Receiver_Body
;
7658 --------------------------------------
7659 -- Build_Subprogram_Receiving_Stubs --
7660 --------------------------------------
7662 function Build_Subprogram_Receiving_Stubs
7663 (Vis_Decl
: Node_Id
;
7664 Asynchronous
: Boolean;
7665 Dynamically_Asynchronous
: Boolean := False;
7666 Stub_Type
: Entity_Id
:= Empty
;
7667 RACW_Type
: Entity_Id
:= Empty
;
7668 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
7670 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
7672 Request_Parameter
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
7673 -- Formal parameter for receiving stubs: a descriptor for an incoming
7676 Outer_Decls
: constant List_Id
:= New_List
;
7677 -- At the outermost level, an NVList and Any's are declared for all
7678 -- parameters. The Dynamic_Async flag also needs to be declared there
7679 -- to be visible from the exception handling code.
7681 Outer_Statements
: constant List_Id
:= New_List
;
7682 -- Statements that occur prior to the declaration of the actual
7683 -- parameter variables.
7685 Outer_Extra_Formal_Statements
: constant List_Id
:= New_List
;
7686 -- Statements concerning extra formal parameters, prior to the
7687 -- declaration of the actual parameter variables.
7689 Decls
: constant List_Id
:= New_List
;
7690 -- All the parameters will get declared before calling the real
7691 -- subprograms. Also the out parameters will be declared. At this
7692 -- level, parameters may be unconstrained.
7694 Statements
: constant List_Id
:= New_List
;
7696 After_Statements
: constant List_Id
:= New_List
;
7697 -- Statements to be executed after the subprogram call
7699 Inner_Decls
: List_Id
:= No_List
;
7700 -- In case of a function, the inner declarations are needed since
7701 -- the result may be unconstrained.
7703 Excep_Handlers
: List_Id
:= No_List
;
7705 Parameter_List
: constant List_Id
:= New_List
;
7706 -- List of parameters to be passed to the subprogram
7708 First_Controlling_Formal_Seen
: Boolean := False;
7710 Current_Parameter
: Node_Id
;
7712 Ordered_Parameters_List
: constant List_Id
:=
7713 Build_Ordered_Parameters_List
7714 (Specification
(Vis_Decl
));
7716 Arguments
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
7717 -- Name of the named values list used to retrieve parameters
7719 Subp_Spec
: Node_Id
;
7720 -- Subprogram specification
7722 Called_Subprogram
: Node_Id
;
7723 -- The subprogram to call
7726 if Present
(RACW_Type
) then
7727 Called_Subprogram
:=
7728 New_Occurrence_Of
(Parent_Primitive
, Loc
);
7730 Called_Subprogram
:=
7732 (Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
7735 Declare_Create_NVList
(Loc
, Arguments
, Outer_Decls
, Outer_Statements
);
7737 -- Loop through every parameter and get its value from the stream. If
7738 -- the parameter is unconstrained, then the parameter is read using
7739 -- 'Input at the point of declaration.
7741 Current_Parameter
:= First
(Ordered_Parameters_List
);
7742 while Present
(Current_Parameter
) loop
7745 Constrained
: Boolean;
7746 Any
: Entity_Id
:= Empty
;
7747 Object
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
7748 Expr
: Node_Id
:= Empty
;
7750 Is_Controlling_Formal
: constant Boolean :=
7751 Is_RACW_Controlling_Formal
7752 (Current_Parameter
, Stub_Type
);
7754 Is_First_Controlling_Formal
: Boolean := False;
7756 Need_Extra_Constrained
: Boolean;
7757 -- True when an extra constrained actual is required
7760 if Is_Controlling_Formal
then
7762 -- Controlling formals in distributed object primitive
7763 -- operations are handled specially:
7765 -- - the first controlling formal is used as the
7766 -- target of the call;
7768 -- - the remaining controlling formals are transmitted
7772 Is_First_Controlling_Formal
:=
7773 not First_Controlling_Formal_Seen
;
7774 First_Controlling_Formal_Seen
:= True;
7777 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7781 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
7783 if not Is_First_Controlling_Formal
then
7784 Any
:= Make_Temporary
(Loc
, 'A');
7786 Append_To
(Outer_Decls
,
7787 Make_Object_Declaration
(Loc
,
7788 Defining_Identifier
=> Any
,
7789 Object_Definition
=>
7790 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7792 Make_Function_Call
(Loc
,
7793 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7794 Parameter_Associations
=> New_List
(
7795 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7796 (Loc
, Etyp
, Outer_Decls
)))));
7798 Append_To
(Outer_Statements
,
7799 Add_Parameter_To_NVList
(Loc
,
7800 Parameter
=> Current_Parameter
,
7801 NVList
=> Arguments
,
7802 Constrained
=> Constrained
,
7806 if Is_First_Controlling_Formal
then
7808 Addr
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
7810 Is_Local
: constant Entity_Id
:=
7811 Make_Temporary
(Loc
, 'L');
7814 -- Special case: obtain the first controlling formal
7815 -- from the target of the remote call, instead of the
7818 Append_To
(Outer_Decls
,
7819 Make_Object_Declaration
(Loc
,
7820 Defining_Identifier
=> Addr
,
7821 Object_Definition
=>
7822 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
7824 Append_To
(Outer_Decls
,
7825 Make_Object_Declaration
(Loc
,
7826 Defining_Identifier
=> Is_Local
,
7827 Object_Definition
=>
7828 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7830 Append_To
(Outer_Statements
,
7831 Make_Procedure_Call_Statement
(Loc
,
7833 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
7834 Parameter_Associations
=> New_List
(
7835 Make_Selected_Component
(Loc
,
7838 Request_Parameter
, Loc
),
7840 Make_Identifier
(Loc
, Name_Target
)),
7841 New_Occurrence_Of
(Is_Local
, Loc
),
7842 New_Occurrence_Of
(Addr
, Loc
))));
7844 Expr
:= Unchecked_Convert_To
(RACW_Type
,
7845 New_Occurrence_Of
(Addr
, Loc
));
7848 elsif In_Present
(Current_Parameter
)
7849 or else not Out_Present
(Current_Parameter
)
7850 or else not Constrained
7852 -- If an input parameter is constrained, then its reading is
7853 -- deferred until the beginning of the subprogram body. If
7854 -- it is unconstrained, then an expression is built for
7855 -- the object declaration and the variable is set using
7856 -- 'Input instead of 'Read.
7858 if Constrained
and then Is_Limited_Type
(Etyp
) then
7859 Helpers
.Assign_Opaque_From_Any
(Loc
,
7862 N
=> New_Occurrence_Of
(Any
, Loc
),
7866 Expr
:= Helpers
.Build_From_Any_Call
7867 (Etyp
, New_Occurrence_Of
(Any
, Loc
), Decls
);
7870 Append_To
(Statements
,
7871 Make_Assignment_Statement
(Loc
,
7872 Name
=> New_Occurrence_Of
(Object
, Loc
),
7873 Expression
=> Expr
));
7877 -- Expr will be used to initialize (and constrain) the
7878 -- parameter when it is declared.
7886 Need_Extra_Constrained
:=
7887 Nkind
(Parameter_Type
(Current_Parameter
)) /=
7890 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
7892 Present
(Extra_Constrained
7893 (Defining_Identifier
(Current_Parameter
)));
7895 -- We may not associate an extra constrained actual to a
7896 -- constant object, so if one is needed, declare the actual
7897 -- as a variable even if it won't be modified.
7899 Build_Actual_Object_Declaration
7902 Variable
=> Need_Extra_Constrained
7903 or else Out_Present
(Current_Parameter
),
7906 Set_Etype
(Object
, Etyp
);
7908 -- An out parameter may be written back using a 'Write
7909 -- attribute instead of a 'Output because it has been
7910 -- constrained by the parameter given to the caller. Note that
7911 -- out controlling arguments in the case of a RACW are not put
7912 -- back in the stream because the pointer on them has not
7915 if Out_Present
(Current_Parameter
)
7916 and then not Is_Controlling_Formal
7918 Append_To
(After_Statements
,
7919 Make_Procedure_Call_Statement
(Loc
,
7920 Name
=> New_Occurrence_Of
(RTE
(RE_Move_Any_Value
), Loc
),
7921 Parameter_Associations
=> New_List
(
7922 New_Occurrence_Of
(Any
, Loc
),
7923 PolyORB_Support
.Helpers
.Build_To_Any_Call
7924 (New_Occurrence_Of
(Object
, Loc
), Decls
))));
7927 -- For RACW controlling formals, the Etyp of Object is always
7928 -- an RACW, even if the parameter is not of an anonymous access
7929 -- type. In such case, we need to dereference it at call time.
7931 if Is_Controlling_Formal
then
7932 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7935 Append_To
(Parameter_List
,
7936 Make_Parameter_Association
(Loc
,
7939 (Defining_Identifier
(Current_Parameter
), Loc
),
7940 Explicit_Actual_Parameter
=>
7941 Make_Explicit_Dereference
(Loc
,
7942 Prefix
=> New_Occurrence_Of
(Object
, Loc
))));
7945 Append_To
(Parameter_List
,
7946 Make_Parameter_Association
(Loc
,
7949 (Defining_Identifier
(Current_Parameter
), Loc
),
7951 Explicit_Actual_Parameter
=>
7952 New_Occurrence_Of
(Object
, Loc
)));
7956 Append_To
(Parameter_List
,
7957 Make_Parameter_Association
(Loc
,
7960 Defining_Identifier
(Current_Parameter
), Loc
),
7961 Explicit_Actual_Parameter
=>
7962 New_Occurrence_Of
(Object
, Loc
)));
7965 -- If the current parameter needs an extra formal, then read it
7966 -- from the stream and set the corresponding semantic field in
7967 -- the variable. If the kind of the parameter identifier is
7968 -- E_Void, then this is a compiler generated parameter that
7969 -- doesn't need an extra constrained status.
7971 -- The case of Extra_Accessibility should also be handled ???
7973 if Need_Extra_Constrained
then
7975 Extra_Parameter
: constant Entity_Id
:=
7977 (Defining_Identifier
7978 (Current_Parameter
));
7980 Extra_Any
: constant Entity_Id
:=
7981 Make_Temporary
(Loc
, 'A');
7983 Formal_Entity
: constant Entity_Id
:=
7984 Make_Defining_Identifier
(Loc
,
7985 Chars
=> Chars
(Extra_Parameter
));
7987 Formal_Type
: constant Entity_Id
:=
7988 Etype
(Extra_Parameter
);
7991 Append_To
(Outer_Decls
,
7992 Make_Object_Declaration
(Loc
,
7993 Defining_Identifier
=> Extra_Any
,
7994 Object_Definition
=>
7995 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7997 Make_Function_Call
(Loc
,
7999 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
8000 Parameter_Associations
=> New_List
(
8001 PolyORB_Support
.Helpers
.Build_TypeCode_Call
8002 (Loc
, Formal_Type
, Outer_Decls
)))));
8004 Append_To
(Outer_Extra_Formal_Statements
,
8005 Add_Parameter_To_NVList
(Loc
,
8006 Parameter
=> Extra_Parameter
,
8007 NVList
=> Arguments
,
8008 Constrained
=> True,
8012 Make_Object_Declaration
(Loc
,
8013 Defining_Identifier
=> Formal_Entity
,
8014 Object_Definition
=>
8015 New_Occurrence_Of
(Formal_Type
, Loc
)));
8017 Append_To
(Statements
,
8018 Make_Assignment_Statement
(Loc
,
8019 Name
=> New_Occurrence_Of
(Formal_Entity
, Loc
),
8021 PolyORB_Support
.Helpers
.Build_From_Any_Call
8023 New_Occurrence_Of
(Extra_Any
, Loc
),
8025 Set_Extra_Constrained
(Object
, Formal_Entity
);
8030 Next
(Current_Parameter
);
8033 -- Extra Formals should go after all the other parameters
8035 Append_List_To
(Outer_Statements
, Outer_Extra_Formal_Statements
);
8037 Append_To
(Outer_Statements
,
8038 Make_Procedure_Call_Statement
(Loc
,
8039 Name
=> New_Occurrence_Of
(RTE
(RE_Request_Arguments
), Loc
),
8040 Parameter_Associations
=> New_List
(
8041 New_Occurrence_Of
(Request_Parameter
, Loc
),
8042 New_Occurrence_Of
(Arguments
, Loc
))));
8044 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
8046 -- The remote subprogram is a function: Build an inner block to be
8047 -- able to hold a potentially unconstrained result in a variable.
8050 Etyp
: constant Entity_Id
:=
8051 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
8052 Result
: constant Node_Id
:= Make_Temporary
(Loc
, 'R');
8055 Inner_Decls
:= New_List
(
8056 Make_Object_Declaration
(Loc
,
8057 Defining_Identifier
=> Result
,
8058 Constant_Present
=> True,
8059 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
8061 Make_Function_Call
(Loc
,
8062 Name
=> Called_Subprogram
,
8063 Parameter_Associations
=> Parameter_List
)));
8065 if Is_Class_Wide_Type
(Etyp
) then
8067 -- For a remote call to a function with a class-wide type,
8068 -- check that the returned value satisfies the requirements
8071 Append_To
(Inner_Decls
,
8072 Make_Transportable_Check
(Loc
,
8073 New_Occurrence_Of
(Result
, Loc
)));
8077 Set_Etype
(Result
, Etyp
);
8078 Append_To
(After_Statements
,
8079 Make_Procedure_Call_Statement
(Loc
,
8080 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Result
), Loc
),
8081 Parameter_Associations
=> New_List
(
8082 New_Occurrence_Of
(Request_Parameter
, Loc
),
8083 PolyORB_Support
.Helpers
.Build_To_Any_Call
8084 (New_Occurrence_Of
(Result
, Loc
), Decls
))));
8086 -- A DSA function does not have out or inout arguments
8089 Append_To
(Statements
,
8090 Make_Block_Statement
(Loc
,
8091 Declarations
=> Inner_Decls
,
8092 Handled_Statement_Sequence
=>
8093 Make_Handled_Sequence_Of_Statements
(Loc
,
8094 Statements
=> After_Statements
)));
8097 -- The remote subprogram is a procedure. We do not need any inner
8098 -- block in this case. No specific processing is required here for
8099 -- the dynamically asynchronous case: the indication of whether
8100 -- call is asynchronous or not is managed by the Sync_Scope
8101 -- attibute of the request, and is handled entirely in the
8104 Append_To
(After_Statements
,
8105 Make_Procedure_Call_Statement
(Loc
,
8106 Name
=> New_Occurrence_Of
(RTE
(RE_Request_Set_Out
), Loc
),
8107 Parameter_Associations
=> New_List
(
8108 New_Occurrence_Of
(Request_Parameter
, Loc
))));
8110 Append_To
(Statements
,
8111 Make_Procedure_Call_Statement
(Loc
,
8112 Name
=> Called_Subprogram
,
8113 Parameter_Associations
=> Parameter_List
));
8115 Append_List_To
(Statements
, After_Statements
);
8119 Make_Procedure_Specification
(Loc
,
8120 Defining_Unit_Name
=> Make_Temporary
(Loc
, 'F'),
8122 Parameter_Specifications
=> New_List
(
8123 Make_Parameter_Specification
(Loc
,
8124 Defining_Identifier
=> Request_Parameter
,
8126 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
8128 -- An exception raised during the execution of an incoming remote
8129 -- subprogram call and that needs to be sent back to the caller is
8130 -- propagated by the receiving stubs, and will be handled by the
8131 -- caller (the distribution runtime).
8133 if Asynchronous
and then not Dynamically_Asynchronous
then
8135 -- For an asynchronous procedure, add a null exception handler
8137 Excep_Handlers
:= New_List
(
8138 Make_Implicit_Exception_Handler
(Loc
,
8139 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8140 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
8143 -- In the other cases, if an exception is raised, then the
8144 -- exception occurrence is propagated.
8149 Append_To
(Outer_Statements
,
8150 Make_Block_Statement
(Loc
,
8151 Declarations
=> Decls
,
8152 Handled_Statement_Sequence
=>
8153 Make_Handled_Sequence_Of_Statements
(Loc
,
8154 Statements
=> Statements
)));
8157 Make_Subprogram_Body
(Loc
,
8158 Specification
=> Subp_Spec
,
8159 Declarations
=> Outer_Decls
,
8160 Handled_Statement_Sequence
=>
8161 Make_Handled_Sequence_Of_Statements
(Loc
,
8162 Statements
=> Outer_Statements
,
8163 Exception_Handlers
=> Excep_Handlers
));
8164 end Build_Subprogram_Receiving_Stubs
;
8170 package body Helpers
is
8172 -----------------------
8173 -- Local Subprograms --
8174 -----------------------
8176 function Find_Numeric_Representation
8177 (Typ
: Entity_Id
) return Entity_Id
;
8178 -- Given a numeric type Typ, return the smallest integer or floating
8179 -- point type from Standard, or the smallest unsigned (modular) type
8180 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8182 function Make_Helper_Function_Name
8185 Nam
: Name_Id
) return Entity_Id
;
8186 -- Return the name to be assigned for helper subprogram Nam of Typ
8188 ------------------------------------------------------------
8189 -- Common subprograms for building various tree fragments --
8190 ------------------------------------------------------------
8192 function Build_Get_Aggregate_Element
8196 Idx
: Node_Id
) return Node_Id
;
8197 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8198 -- returning the Idx'th element.
8201 Subprogram
: Entity_Id
;
8202 -- Reference location for constructed nodes
8205 -- For 'Range and Etype
8208 -- For the construction of the innermost element expression
8210 with procedure Add_Process_Element
8213 Counter
: Entity_Id
;
8216 procedure Append_Array_Traversal
8219 Counter
: Entity_Id
:= Empty
;
8221 -- Build nested loop statements that iterate over the elements of an
8222 -- array Arry. The statement(s) built by Add_Process_Element are
8223 -- executed for each element; Indices is the list of indices to be
8224 -- used in the construction of the indexed component that denotes the
8225 -- current element. Subprogram is the entity for the subprogram for
8226 -- which this iterator is generated. The generated statements are
8227 -- appended to Stmts.
8231 -- The record entity being dealt with
8233 with procedure Add_Process_Element
8235 Container
: Node_Or_Entity_Id
;
8236 Counter
: in out Int
;
8239 -- Rec is the instance of the record type, or Empty.
8240 -- Field is either the N_Defining_Identifier for a component,
8241 -- or an N_Variant_Part.
8243 procedure Append_Record_Traversal
8246 Container
: Node_Or_Entity_Id
;
8247 Counter
: in out Int
);
8248 -- Process component list Clist. Individual fields are passed
8249 -- to Field_Processing. Each variant part is also processed.
8250 -- Container is the outer Any (for From_Any/To_Any),
8251 -- the outer typecode (for TC) to which the operation applies.
8253 -----------------------------
8254 -- Append_Record_Traversal --
8255 -----------------------------
8257 procedure Append_Record_Traversal
8260 Container
: Node_Or_Entity_Id
;
8261 Counter
: in out Int
)
8265 -- Clist's Component_Items and Variant_Part
8275 CI
:= Component_Items
(Clist
);
8276 VP
:= Variant_Part
(Clist
);
8279 while Present
(Item
) loop
8280 Def
:= Defining_Identifier
(Item
);
8282 if not Is_Internal_Name
(Chars
(Def
)) then
8284 (Stmts
, Container
, Counter
, Rec
, Def
);
8290 if Present
(VP
) then
8291 Add_Process_Element
(Stmts
, Container
, Counter
, Rec
, VP
);
8293 end Append_Record_Traversal
;
8295 -----------------------------
8296 -- Assign_Opaque_From_Any --
8297 -----------------------------
8299 procedure Assign_Opaque_From_Any
8306 Strm
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
8309 Read_Call_List
: List_Id
;
8310 -- List on which to place the 'Read attribute reference
8313 -- Strm : Buffer_Stream_Type;
8316 Make_Object_Declaration
(Loc
,
8317 Defining_Identifier
=> Strm
,
8318 Aliased_Present
=> True,
8319 Object_Definition
=>
8320 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
8322 -- Any_To_BS (Strm, A);
8325 Make_Procedure_Call_Statement
(Loc
,
8326 Name
=> New_Occurrence_Of
(RTE
(RE_Any_To_BS
), Loc
),
8327 Parameter_Associations
=> New_List
(
8329 New_Occurrence_Of
(Strm
, Loc
))));
8331 if Transmit_As_Unconstrained
(Typ
) then
8333 Make_Attribute_Reference
(Loc
,
8334 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
8335 Attribute_Name
=> Name_Input
,
8336 Expressions
=> New_List
(
8337 Make_Attribute_Reference
(Loc
,
8338 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
8339 Attribute_Name
=> Name_Access
)));
8341 -- Target := Typ'Input (Strm'Access)
8343 if Present
(Target
) then
8345 Make_Assignment_Statement
(Loc
,
8346 Name
=> New_Occurrence_Of
(Target
, Loc
),
8347 Expression
=> Expr
));
8349 -- return Typ'Input (Strm'Access);
8353 Make_Simple_Return_Statement
(Loc
,
8354 Expression
=> Expr
));
8358 if Present
(Target
) then
8359 Read_Call_List
:= Stms
;
8360 Expr
:= New_Occurrence_Of
(Target
, Loc
);
8364 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
8367 Read_Call_List
:= New_List
;
8368 Expr
:= New_Occurrence_Of
(Temp
, Loc
);
8370 Append_To
(Stms
, Make_Block_Statement
(Loc
,
8371 Declarations
=> New_List
(
8372 Make_Object_Declaration
(Loc
,
8373 Defining_Identifier
=>
8375 Object_Definition
=>
8376 New_Occurrence_Of
(Typ
, Loc
))),
8378 Handled_Statement_Sequence
=>
8379 Make_Handled_Sequence_Of_Statements
(Loc
,
8380 Statements
=> Read_Call_List
)));
8384 -- Typ'Read (Strm'Access, [Target|Temp])
8386 Append_To
(Read_Call_List
,
8387 Make_Attribute_Reference
(Loc
,
8388 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
8389 Attribute_Name
=> Name_Read
,
8390 Expressions
=> New_List
(
8391 Make_Attribute_Reference
(Loc
,
8392 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
8393 Attribute_Name
=> Name_Access
),
8400 Append_To
(Read_Call_List
,
8401 Make_Simple_Return_Statement
(Loc
,
8402 Expression
=> New_Copy
(Expr
)));
8405 end Assign_Opaque_From_Any
;
8407 -------------------------
8408 -- Build_From_Any_Call --
8409 -------------------------
8411 function Build_From_Any_Call
8414 Decls
: List_Id
) return Node_Id
8416 Loc
: constant Source_Ptr
:= Sloc
(N
);
8418 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
8420 Fnam
: Entity_Id
:= Empty
;
8421 Lib_RE
: RE_Id
:= RE_Null
;
8425 -- First simple case where the From_Any function is present
8426 -- in the type's TSS.
8428 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_From_Any
);
8430 -- For the subtype representing a generic actual type, go to the
8433 if Is_Generic_Actual_Type
(U_Type
) then
8434 U_Type
:= Underlying_Type
(Base_Type
(U_Type
));
8437 -- For a standard subtype, go to the base type
8439 if Sloc
(U_Type
) <= Standard_Location
then
8440 U_Type
:= Base_Type
(U_Type
);
8443 -- Check first for Boolean and Character. These are enumeration
8444 -- types, but we treat them specially, since they may require
8445 -- special handling in the transfer protocol. However, this
8446 -- special handling only applies if they have standard
8447 -- representation, otherwise they are treated like any other
8448 -- enumeration type.
8450 if Present
(Fnam
) then
8453 elsif U_Type
= Standard_Boolean
then
8456 elsif U_Type
= Standard_Character
then
8459 elsif U_Type
= Standard_Wide_Character
then
8462 elsif U_Type
= Standard_Wide_Wide_Character
then
8463 Lib_RE
:= RE_FA_WWC
;
8465 -- Floating point types
8467 elsif U_Type
= Standard_Short_Float
then
8470 elsif U_Type
= Standard_Float
then
8473 elsif U_Type
= Standard_Long_Float
then
8476 elsif U_Type
= Standard_Long_Long_Float
then
8477 Lib_RE
:= RE_FA_LLF
;
8481 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
8482 Lib_RE
:= RE_FA_SSI
;
8484 elsif U_Type
= Etype
(Standard_Short_Integer
) then
8487 elsif U_Type
= Etype
(Standard_Integer
) then
8490 elsif U_Type
= Etype
(Standard_Long_Integer
) then
8493 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
8494 Lib_RE
:= RE_FA_LLI
;
8496 -- Unsigned integer types
8498 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
8499 Lib_RE
:= RE_FA_SSU
;
8501 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
8504 elsif U_Type
= RTE
(RE_Unsigned
) then
8507 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
8510 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
8511 Lib_RE
:= RE_FA_LLU
;
8513 elsif Is_RTE
(U_Type
, RE_Unbounded_String
) then
8514 Lib_RE
:= RE_FA_String
;
8516 -- Special DSA types
8518 elsif Is_RTE
(U_Type
, RE_Any_Container_Ptr
) then
8521 -- Other (non-primitive) types
8528 Build_From_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
8529 Append_To
(Decls
, Decl
);
8533 -- Call the function
8535 if Lib_RE
/= RE_Null
then
8536 pragma Assert
(No
(Fnam
));
8537 Fnam
:= RTE
(Lib_RE
);
8541 Make_Function_Call
(Loc
,
8542 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
8543 Parameter_Associations
=> New_List
(N
));
8545 -- We must set the type of Result, so the unchecked conversion
8546 -- from the underlying type to the base type is properly done.
8548 Set_Etype
(Result
, U_Type
);
8550 return Unchecked_Convert_To
(Typ
, Result
);
8551 end Build_From_Any_Call
;
8553 -----------------------------
8554 -- Build_From_Any_Function --
8555 -----------------------------
8557 procedure Build_From_Any_Function
8561 Fnam
: out Entity_Id
)
8564 Decls
: constant List_Id
:= New_List
;
8565 Stms
: constant List_Id
:= New_List
;
8567 Any_Parameter
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
8569 Use_Opaque_Representation
: Boolean;
8572 -- For a derived type, we can't go past the base type (to the
8573 -- parent type) here, because that would cause the attribute's
8574 -- formal parameter to have the wrong type; hence the Base_Type
8577 if Is_Itype
(Typ
) and then Typ
/= Base_Type
(Typ
) then
8578 Build_From_Any_Function
8586 Fnam
:= Make_Helper_Function_Name
(Loc
, Typ
, Name_From_Any
);
8589 Make_Function_Specification
(Loc
,
8590 Defining_Unit_Name
=> Fnam
,
8591 Parameter_Specifications
=> New_List
(
8592 Make_Parameter_Specification
(Loc
,
8593 Defining_Identifier
=> Any_Parameter
,
8594 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
8595 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
8597 -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any
8600 (not (Is_Remote_Access_To_Class_Wide_Type
(Typ
)));
8602 Use_Opaque_Representation
:= False;
8604 if Has_Stream_Attribute_Definition
8605 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
8607 Has_Stream_Attribute_Definition
8608 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
8610 -- If user-defined stream attributes are specified for this
8611 -- type, use them and transmit data as an opaque sequence of
8614 Use_Opaque_Representation
:= True;
8616 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
8618 Make_Simple_Return_Statement
(Loc
,
8623 New_Occurrence_Of
(Any_Parameter
, Loc
),
8626 elsif Is_Record_Type
(Typ
)
8627 and then not Is_Derived_Type
(Typ
)
8628 and then not Is_Tagged_Type
(Typ
)
8630 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
8632 Make_Simple_Return_Statement
(Loc
,
8636 New_Occurrence_Of
(Any_Parameter
, Loc
),
8641 Disc
: Entity_Id
:= Empty
;
8642 Discriminant_Associations
: List_Id
;
8643 Rdef
: constant Node_Id
:=
8645 (Declaration_Node
(Typ
));
8646 Component_Counter
: Int
:= 0;
8648 -- The returned object
8650 Res
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
8652 Res_Definition
: Node_Id
:= New_Occurrence_Of
(Typ
, Loc
);
8654 procedure FA_Rec_Add_Process_Element
8657 Counter
: in out Int
;
8661 procedure FA_Append_Record_Traversal
is
8662 new Append_Record_Traversal
8664 Add_Process_Element
=> FA_Rec_Add_Process_Element
);
8666 --------------------------------
8667 -- FA_Rec_Add_Process_Element --
8668 --------------------------------
8670 procedure FA_Rec_Add_Process_Element
8673 Counter
: in out Int
;
8679 if Nkind
(Field
) = N_Defining_Identifier
then
8680 -- A regular component
8682 Ctyp
:= Etype
(Field
);
8685 Make_Assignment_Statement
(Loc
,
8686 Name
=> Make_Selected_Component
(Loc
,
8688 New_Occurrence_Of
(Rec
, Loc
),
8690 New_Occurrence_Of
(Field
, Loc
)),
8693 Build_From_Any_Call
(Ctyp
,
8694 Build_Get_Aggregate_Element
(Loc
,
8697 Build_TypeCode_Call
(Loc
, Ctyp
, Decls
),
8699 Make_Integer_Literal
(Loc
, Counter
)),
8707 Struct_Counter
: Int
:= 0;
8709 Block_Decls
: constant List_Id
:= New_List
;
8710 Block_Stmts
: constant List_Id
:= New_List
;
8713 Alt_List
: constant List_Id
:= New_List
;
8714 Choice_List
: List_Id
;
8716 Struct_Any
: constant Entity_Id
:=
8717 Make_Temporary
(Loc
, 'S');
8721 Make_Object_Declaration
(Loc
,
8722 Defining_Identifier
=> Struct_Any
,
8723 Constant_Present
=> True,
8724 Object_Definition
=>
8725 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8727 Make_Function_Call
(Loc
,
8730 (RTE
(RE_Extract_Union_Value
), Loc
),
8732 Parameter_Associations
=> New_List
(
8733 Build_Get_Aggregate_Element
(Loc
,
8736 Make_Function_Call
(Loc
,
8737 Name
=> New_Occurrence_Of
(
8738 RTE
(RE_Any_Member_Type
), Loc
),
8739 Parameter_Associations
=>
8741 New_Occurrence_Of
(Any
, Loc
),
8742 Make_Integer_Literal
(Loc
,
8743 Intval
=> Counter
))),
8745 Make_Integer_Literal
(Loc
,
8746 Intval
=> Counter
))))));
8749 Make_Block_Statement
(Loc
,
8750 Declarations
=> Block_Decls
,
8751 Handled_Statement_Sequence
=>
8752 Make_Handled_Sequence_Of_Statements
(Loc
,
8753 Statements
=> Block_Stmts
)));
8755 Append_To
(Block_Stmts
,
8756 Make_Case_Statement
(Loc
,
8758 Make_Selected_Component
(Loc
,
8760 Selector_Name
=> Chars
(Name
(Field
))),
8761 Alternatives
=> Alt_List
));
8763 Variant
:= First_Non_Pragma
(Variants
(Field
));
8764 while Present
(Variant
) loop
8767 (Discrete_Choices
(Variant
));
8769 VP_Stmts
:= New_List
;
8771 -- Struct_Counter should be reset before
8772 -- handling a variant part. Indeed only one
8773 -- of the case statement alternatives will be
8774 -- executed at run time, so the counter must
8775 -- start at 0 for every case statement.
8777 Struct_Counter
:= 0;
8779 FA_Append_Record_Traversal
(
8781 Clist
=> Component_List
(Variant
),
8782 Container
=> Struct_Any
,
8783 Counter
=> Struct_Counter
);
8785 Append_To
(Alt_List
,
8786 Make_Case_Statement_Alternative
(Loc
,
8787 Discrete_Choices
=> Choice_List
,
8788 Statements
=> VP_Stmts
));
8789 Next_Non_Pragma
(Variant
);
8794 Counter
:= Counter
+ 1;
8795 end FA_Rec_Add_Process_Element
;
8798 -- First all discriminants
8800 if Has_Discriminants
(Typ
) then
8801 Discriminant_Associations
:= New_List
;
8803 Disc
:= First_Discriminant
(Typ
);
8804 while Present
(Disc
) loop
8806 Disc_Var_Name
: constant Entity_Id
:=
8807 Make_Defining_Identifier
(Loc
,
8808 Chars
=> Chars
(Disc
));
8809 Disc_Type
: constant Entity_Id
:=
8814 Make_Object_Declaration
(Loc
,
8815 Defining_Identifier
=> Disc_Var_Name
,
8816 Constant_Present
=> True,
8817 Object_Definition
=>
8818 New_Occurrence_Of
(Disc_Type
, Loc
),
8821 Build_From_Any_Call
(Disc_Type
,
8822 Build_Get_Aggregate_Element
(Loc
,
8823 Any
=> Any_Parameter
,
8824 TC
=> Build_TypeCode_Call
8825 (Loc
, Disc_Type
, Decls
),
8826 Idx
=> Make_Integer_Literal
(Loc
,
8827 Intval
=> Component_Counter
)),
8830 Component_Counter
:= Component_Counter
+ 1;
8832 Append_To
(Discriminant_Associations
,
8833 Make_Discriminant_Association
(Loc
,
8834 Selector_Names
=> New_List
(
8835 New_Occurrence_Of
(Disc
, Loc
)),
8837 New_Occurrence_Of
(Disc_Var_Name
, Loc
)));
8839 Next_Discriminant
(Disc
);
8843 Make_Subtype_Indication
(Loc
,
8844 Subtype_Mark
=> Res_Definition
,
8846 Make_Index_Or_Discriminant_Constraint
(Loc
,
8847 Discriminant_Associations
));
8850 -- Now we have all the discriminants in variables, we can
8851 -- declared a constrained object. Note that we are not
8852 -- initializing (non-discriminant) components directly in
8853 -- the object declarations, because which fields to
8854 -- initialize depends (at run time) on the discriminant
8858 Make_Object_Declaration
(Loc
,
8859 Defining_Identifier
=> Res
,
8860 Object_Definition
=> Res_Definition
));
8862 -- ... then all components
8864 FA_Append_Record_Traversal
(Stms
,
8865 Clist
=> Component_List
(Rdef
),
8866 Container
=> Any_Parameter
,
8867 Counter
=> Component_Counter
);
8870 Make_Simple_Return_Statement
(Loc
,
8871 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
8875 elsif Is_Array_Type
(Typ
) then
8877 Constrained
: constant Boolean := Is_Constrained
(Typ
);
8879 procedure FA_Ary_Add_Process_Element
8882 Counter
: Entity_Id
;
8884 -- Assign the current element (as identified by Counter) of
8885 -- Any to the variable denoted by name Datum, and advance
8886 -- Counter by 1. If Datum is not an Any, a call to From_Any
8887 -- for its type is inserted.
8889 --------------------------------
8890 -- FA_Ary_Add_Process_Element --
8891 --------------------------------
8893 procedure FA_Ary_Add_Process_Element
8896 Counter
: Entity_Id
;
8899 Assignment
: constant Node_Id
:=
8900 Make_Assignment_Statement
(Loc
,
8902 Expression
=> Empty
);
8904 Element_Any
: Node_Id
;
8908 Element_TC
: Node_Id
;
8911 if Etype
(Datum
) = RTE
(RE_Any
) then
8913 -- When Datum is an Any the Etype field is not
8914 -- sufficient to determine the typecode of Datum
8915 -- (which can be a TC_SEQUENCE or TC_ARRAY
8916 -- depending on the value of Constrained).
8918 -- Therefore we retrieve the typecode which has
8919 -- been constructed in Append_Array_Traversal with
8920 -- a call to Get_Any_Type.
8923 Make_Function_Call
(Loc
,
8924 Name
=> New_Occurrence_Of
(
8925 RTE
(RE_Get_Any_Type
), Loc
),
8926 Parameter_Associations
=> New_List
(
8927 New_Occurrence_Of
(Entity
(Datum
), Loc
)));
8929 -- For non Any Datum we simply construct a typecode
8930 -- matching the Etype of the Datum.
8932 Element_TC
:= Build_TypeCode_Call
8933 (Loc
, Etype
(Datum
), Decls
);
8937 Build_Get_Aggregate_Element
(Loc
,
8940 Idx
=> New_Occurrence_Of
(Counter
, Loc
));
8943 -- Note: here we *prepend* statements to Stmts, so
8944 -- we must do it in reverse order.
8947 Make_Assignment_Statement
(Loc
,
8949 New_Occurrence_Of
(Counter
, Loc
),
8952 Left_Opnd
=> New_Occurrence_Of
(Counter
, Loc
),
8953 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
8955 if Nkind
(Datum
) /= N_Attribute_Reference
then
8957 -- We ignore the value of the length of each
8958 -- dimension, since the target array has already
8959 -- been constrained anyway.
8961 if Etype
(Datum
) /= RTE
(RE_Any
) then
8962 Set_Expression
(Assignment
,
8964 (Component_Type
(Typ
), Element_Any
, Decls
));
8966 Set_Expression
(Assignment
, Element_Any
);
8969 Prepend_To
(Stmts
, Assignment
);
8971 end FA_Ary_Add_Process_Element
;
8973 ------------------------
8974 -- Local Declarations --
8975 ------------------------
8977 Counter
: constant Entity_Id
:=
8978 Make_Defining_Identifier
(Loc
, Name_J
);
8980 Initial_Counter_Value
: Int
:= 0;
8982 Component_TC
: constant Entity_Id
:=
8983 Make_Defining_Identifier
(Loc
, Name_T
);
8985 Res
: constant Entity_Id
:=
8986 Make_Defining_Identifier
(Loc
, Name_R
);
8988 procedure Append_From_Any_Array_Iterator
is
8989 new Append_Array_Traversal
(
8992 Indices
=> New_List
,
8993 Add_Process_Element
=> FA_Ary_Add_Process_Element
);
8995 Res_Subtype_Indication
: Node_Id
:=
8996 New_Occurrence_Of
(Typ
, Loc
);
8999 if not Constrained
then
9001 Ndim
: constant Int
:= Number_Dimensions
(Typ
);
9004 Indx
: Node_Id
:= First_Index
(Typ
);
9007 Ranges
: constant List_Id
:= New_List
;
9010 for J
in 1 .. Ndim
loop
9011 Lnam
:= New_External_Name
('L', J
);
9012 Hnam
:= New_External_Name
('H', J
);
9014 -- Note, for empty arrays bounds may be out of
9015 -- the range of Etype (Indx).
9017 Indt
:= Base_Type
(Etype
(Indx
));
9020 Make_Object_Declaration
(Loc
,
9021 Defining_Identifier
=>
9022 Make_Defining_Identifier
(Loc
, Lnam
),
9023 Constant_Present
=> True,
9024 Object_Definition
=>
9025 New_Occurrence_Of
(Indt
, Loc
),
9029 Build_Get_Aggregate_Element
(Loc
,
9030 Any
=> Any_Parameter
,
9031 TC
=> Build_TypeCode_Call
9034 Make_Integer_Literal
(Loc
, J
- 1)),
9038 Make_Object_Declaration
(Loc
,
9039 Defining_Identifier
=>
9040 Make_Defining_Identifier
(Loc
, Hnam
),
9042 Constant_Present
=> True,
9044 Object_Definition
=>
9045 New_Occurrence_Of
(Indt
, Loc
),
9047 Expression
=> Make_Attribute_Reference
(Loc
,
9049 New_Occurrence_Of
(Indt
, Loc
),
9051 Attribute_Name
=> Name_Val
,
9053 Expressions
=> New_List
(
9054 Make_Op_Subtract
(Loc
,
9059 Standard_Long_Integer
,
9060 Make_Identifier
(Loc
, Lnam
)),
9064 Standard_Long_Integer
,
9065 Make_Function_Call
(Loc
,
9067 New_Occurrence_Of
(RTE
(
9068 RE_Get_Nested_Sequence_Length
9070 Parameter_Associations
=>
9073 Any_Parameter
, Loc
),
9074 Make_Integer_Literal
(Loc
,
9078 Make_Integer_Literal
(Loc
, 1))))));
9082 Low_Bound
=> Make_Identifier
(Loc
, Lnam
),
9083 High_Bound
=> Make_Identifier
(Loc
, Hnam
)));
9088 -- Now we have all the necessary bound information:
9089 -- apply the set of range constraints to the
9090 -- (unconstrained) nominal subtype of Res.
9092 Initial_Counter_Value
:= Ndim
;
9093 Res_Subtype_Indication
:= Make_Subtype_Indication
(Loc
,
9094 Subtype_Mark
=> Res_Subtype_Indication
,
9096 Make_Index_Or_Discriminant_Constraint
(Loc
,
9097 Constraints
=> Ranges
));
9102 Make_Object_Declaration
(Loc
,
9103 Defining_Identifier
=> Res
,
9104 Object_Definition
=> Res_Subtype_Indication
));
9105 Set_Etype
(Res
, Typ
);
9108 Make_Object_Declaration
(Loc
,
9109 Defining_Identifier
=> Counter
,
9110 Object_Definition
=>
9111 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
9113 Make_Integer_Literal
(Loc
, Initial_Counter_Value
)));
9116 Make_Object_Declaration
(Loc
,
9117 Defining_Identifier
=> Component_TC
,
9118 Constant_Present
=> True,
9119 Object_Definition
=>
9120 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
),
9122 Build_TypeCode_Call
(Loc
,
9123 Component_Type
(Typ
), Decls
)));
9125 Append_From_Any_Array_Iterator
9126 (Stms
, Any_Parameter
, Counter
);
9129 Make_Simple_Return_Statement
(Loc
,
9130 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
9133 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9135 Make_Simple_Return_Statement
(Loc
,
9137 Unchecked_Convert_To
(Typ
,
9139 (Find_Numeric_Representation
(Typ
),
9140 New_Occurrence_Of
(Any_Parameter
, Loc
),
9144 Use_Opaque_Representation
:= True;
9147 if Use_Opaque_Representation
then
9148 Assign_Opaque_From_Any
(Loc
,
9151 N
=> New_Occurrence_Of
(Any_Parameter
, Loc
),
9156 Make_Subprogram_Body
(Loc
,
9157 Specification
=> Spec
,
9158 Declarations
=> Decls
,
9159 Handled_Statement_Sequence
=>
9160 Make_Handled_Sequence_Of_Statements
(Loc
,
9161 Statements
=> Stms
));
9162 end Build_From_Any_Function
;
9164 ---------------------------------
9165 -- Build_Get_Aggregate_Element --
9166 ---------------------------------
9168 function Build_Get_Aggregate_Element
9172 Idx
: Node_Id
) return Node_Id
9175 return Make_Function_Call
(Loc
,
9177 New_Occurrence_Of
(RTE
(RE_Get_Aggregate_Element
), Loc
),
9178 Parameter_Associations
=> New_List
(
9179 New_Occurrence_Of
(Any
, Loc
),
9182 end Build_Get_Aggregate_Element
;
9184 -------------------------
9185 -- Build_Reposiroty_Id --
9186 -------------------------
9188 procedure Build_Name_And_Repository_Id
9190 Name_Str
: out String_Id
;
9191 Repo_Id_Str
: out String_Id
)
9195 Store_String_Chars
("DSA:");
9196 Get_Library_Unit_Name_String
(Scope
(E
));
9198 (Name_Buffer
(Name_Buffer
'First ..
9199 Name_Buffer
'First + Name_Len
- 1));
9200 Store_String_Char
('.');
9201 Get_Name_String
(Chars
(E
));
9203 (Name_Buffer
(Name_Buffer
'First ..
9204 Name_Buffer
'First + Name_Len
- 1));
9205 Store_String_Chars
(":1.0");
9206 Repo_Id_Str
:= End_String
;
9207 Name_Str
:= String_From_Name_Buffer
;
9208 end Build_Name_And_Repository_Id
;
9210 -----------------------
9211 -- Build_To_Any_Call --
9212 -----------------------
9214 function Build_To_Any_Call
9216 Decls
: List_Id
) return Node_Id
9218 Loc
: constant Source_Ptr
:= Sloc
(N
);
9220 Typ
: Entity_Id
:= Etype
(N
);
9223 Fnam
: Entity_Id
:= Empty
;
9224 Lib_RE
: RE_Id
:= RE_Null
;
9227 -- If N is a selected component, then maybe its Etype has not been
9228 -- set yet: try to use Etype of the selector_name in that case.
9230 if No
(Typ
) and then Nkind
(N
) = N_Selected_Component
then
9231 Typ
:= Etype
(Selector_Name
(N
));
9234 pragma Assert
(Present
(Typ
));
9236 -- Get full view for private type, completion for incomplete type
9238 U_Type
:= Underlying_Type
(Typ
);
9240 -- First simple case where the To_Any function is present in the
9243 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_To_Any
);
9245 -- For the subtype representing a generic actual type, go to the
9248 if Is_Generic_Actual_Type
(U_Type
) then
9249 U_Type
:= Underlying_Type
(Base_Type
(U_Type
));
9252 -- For a standard subtype, go to the base type
9254 if Sloc
(U_Type
) <= Standard_Location
then
9255 U_Type
:= Base_Type
(U_Type
);
9258 if Present
(Fnam
) then
9261 -- Check first for Boolean and Character. These are enumeration
9262 -- types, but we treat them specially, since they may require
9263 -- special handling in the transfer protocol. However, this
9264 -- special handling only applies if they have standard
9265 -- representation, otherwise they are treated like any other
9266 -- enumeration type.
9268 elsif U_Type
= Standard_Boolean
then
9271 elsif U_Type
= Standard_Character
then
9274 elsif U_Type
= Standard_Wide_Character
then
9277 elsif U_Type
= Standard_Wide_Wide_Character
then
9278 Lib_RE
:= RE_TA_WWC
;
9280 -- Floating point types
9282 elsif U_Type
= Standard_Short_Float
then
9285 elsif U_Type
= Standard_Float
then
9288 elsif U_Type
= Standard_Long_Float
then
9291 elsif U_Type
= Standard_Long_Long_Float
then
9292 Lib_RE
:= RE_TA_LLF
;
9296 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
9297 Lib_RE
:= RE_TA_SSI
;
9299 elsif U_Type
= Etype
(Standard_Short_Integer
) then
9302 elsif U_Type
= Etype
(Standard_Integer
) then
9305 elsif U_Type
= Etype
(Standard_Long_Integer
) then
9308 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
9309 Lib_RE
:= RE_TA_LLI
;
9311 -- Unsigned integer types
9313 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
9314 Lib_RE
:= RE_TA_SSU
;
9316 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
9319 elsif U_Type
= RTE
(RE_Unsigned
) then
9322 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
9325 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
9326 Lib_RE
:= RE_TA_LLU
;
9328 elsif Is_RTE
(U_Type
, RE_Unbounded_String
) then
9329 Lib_RE
:= RE_TA_String
;
9331 -- Special DSA types
9333 elsif Is_RTE
(U_Type
, RE_Any_Container_Ptr
) then
9337 elsif U_Type
= Underlying_Type
(RTE
(RE_TypeCode
)) then
9339 -- No corresponding FA_TC ???
9343 -- Other (non-primitive) types
9349 Build_To_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
9350 Append_To
(Decls
, Decl
);
9354 -- Call the function
9356 if Lib_RE
/= RE_Null
then
9357 pragma Assert
(No
(Fnam
));
9358 Fnam
:= RTE
(Lib_RE
);
9361 -- If Fnam is already analyzed, find the proper expected type,
9362 -- else we have a newly constructed To_Any function and we know
9363 -- that the expected type of its parameter is U_Type.
9365 if Ekind
(Fnam
) = E_Function
9366 and then Present
(First_Formal
(Fnam
))
9368 C_Type
:= Etype
(First_Formal
(Fnam
));
9374 Make_Function_Call
(Loc
,
9375 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
9376 Parameter_Associations
=>
9377 New_List
(OK_Convert_To
(C_Type
, N
)));
9378 end Build_To_Any_Call
;
9380 ---------------------------
9381 -- Build_To_Any_Function --
9382 ---------------------------
9384 procedure Build_To_Any_Function
9388 Fnam
: out Entity_Id
)
9391 Decls
: constant List_Id
:= New_List
;
9392 Stms
: constant List_Id
:= New_List
;
9394 Expr_Parameter
: Entity_Id
;
9396 Result_TC
: Node_Id
;
9400 Use_Opaque_Representation
: Boolean;
9401 -- When True, use stream attributes and represent type as an
9402 -- opaque sequence of bytes.
9405 -- For a derived type, we can't go past the base type (to the
9406 -- parent type) here, because that would cause the attribute's
9407 -- formal parameter to have the wrong type; hence the Base_Type
9410 if Is_Itype
(Typ
) and then Typ
/= Base_Type
(Typ
) then
9411 Build_To_Any_Function
9419 Expr_Parameter
:= Make_Defining_Identifier
(Loc
, Name_E
);
9420 Any
:= Make_Defining_Identifier
(Loc
, Name_A
);
9421 Result_TC
:= Build_TypeCode_Call
(Loc
, Typ
, Decls
);
9423 Fnam
:= Make_Helper_Function_Name
(Loc
, Typ
, Name_To_Any
);
9426 Make_Function_Specification
(Loc
,
9427 Defining_Unit_Name
=> Fnam
,
9428 Parameter_Specifications
=> New_List
(
9429 Make_Parameter_Specification
(Loc
,
9430 Defining_Identifier
=> Expr_Parameter
,
9431 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
9432 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9433 Set_Etype
(Expr_Parameter
, Typ
);
9436 Make_Object_Declaration
(Loc
,
9437 Defining_Identifier
=> Any
,
9438 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9440 Use_Opaque_Representation
:= False;
9442 if Has_Stream_Attribute_Definition
9443 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
9445 Has_Stream_Attribute_Definition
9446 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
9448 -- If user-defined stream attributes are specified for this
9449 -- type, use them and transmit data as an opaque sequence of
9452 Use_Opaque_Representation
:= True;
9454 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9456 -- Non-tagged derived type: convert to root type
9459 Rt_Type
: constant Entity_Id
:= Root_Type
(Typ
);
9460 Expr
: constant Node_Id
:=
9463 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9465 Set_Expression
(Any_Decl
, Build_To_Any_Call
(Expr
, Decls
));
9468 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9470 -- Non-tagged record type
9472 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
9474 Rt_Type
: constant Entity_Id
:= Etype
(Typ
);
9475 Expr
: constant Node_Id
:=
9476 OK_Convert_To
(Rt_Type
,
9477 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9481 (Any_Decl
, Build_To_Any_Call
(Expr
, Decls
));
9484 -- Comment needed here (and label on declare block ???)
9488 Disc
: Entity_Id
:= Empty
;
9489 Rdef
: constant Node_Id
:=
9490 Type_Definition
(Declaration_Node
(Typ
));
9492 Elements
: constant List_Id
:= New_List
;
9494 procedure TA_Rec_Add_Process_Element
9496 Container
: Node_Or_Entity_Id
;
9497 Counter
: in out Int
;
9500 -- Processing routine for traversal below
9502 procedure TA_Append_Record_Traversal
is
9503 new Append_Record_Traversal
9504 (Rec
=> Expr_Parameter
,
9505 Add_Process_Element
=> TA_Rec_Add_Process_Element
);
9507 --------------------------------
9508 -- TA_Rec_Add_Process_Element --
9509 --------------------------------
9511 procedure TA_Rec_Add_Process_Element
9513 Container
: Node_Or_Entity_Id
;
9514 Counter
: in out Int
;
9518 Field_Ref
: Node_Id
;
9521 if Nkind
(Field
) = N_Defining_Identifier
then
9523 -- A regular component
9525 Field_Ref
:= Make_Selected_Component
(Loc
,
9526 Prefix
=> New_Occurrence_Of
(Rec
, Loc
),
9527 Selector_Name
=> New_Occurrence_Of
(Field
, Loc
));
9528 Set_Etype
(Field_Ref
, Etype
(Field
));
9531 Make_Procedure_Call_Statement
(Loc
,
9534 RTE
(RE_Add_Aggregate_Element
), Loc
),
9535 Parameter_Associations
=> New_List
(
9536 New_Occurrence_Of
(Container
, Loc
),
9537 Build_To_Any_Call
(Field_Ref
, Decls
))));
9542 Variant_Part
: declare
9544 Struct_Counter
: Int
:= 0;
9546 Block_Decls
: constant List_Id
:= New_List
;
9547 Block_Stmts
: constant List_Id
:= New_List
;
9550 Alt_List
: constant List_Id
:= New_List
;
9551 Choice_List
: List_Id
;
9553 Union_Any
: constant Entity_Id
:=
9554 Make_Temporary
(Loc
, 'V');
9556 Struct_Any
: constant Entity_Id
:=
9557 Make_Temporary
(Loc
, 'S');
9559 function Make_Discriminant_Reference
9561 -- Build reference to the discriminant for this
9564 ---------------------------------
9565 -- Make_Discriminant_Reference --
9566 ---------------------------------
9568 function Make_Discriminant_Reference
9571 Nod
: constant Node_Id
:=
9572 Make_Selected_Component
(Loc
,
9575 Chars
(Name
(Field
)));
9577 Set_Etype
(Nod
, Etype
(Name
(Field
)));
9579 end Make_Discriminant_Reference
;
9581 -- Start of processing for Variant_Part
9585 Make_Block_Statement
(Loc
,
9588 Handled_Statement_Sequence
=>
9589 Make_Handled_Sequence_Of_Statements
(Loc
,
9590 Statements
=> Block_Stmts
)));
9592 -- Declare variant part aggregate (Union_Any).
9593 -- Knowing the position of this VP in the
9594 -- variant record, we can fetch the VP typecode
9597 Append_To
(Block_Decls
,
9598 Make_Object_Declaration
(Loc
,
9599 Defining_Identifier
=> Union_Any
,
9600 Object_Definition
=>
9601 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9603 Make_Function_Call
(Loc
,
9604 Name
=> New_Occurrence_Of
(
9605 RTE
(RE_Create_Any
), Loc
),
9606 Parameter_Associations
=> New_List
(
9607 Make_Function_Call
(Loc
,
9610 RTE
(RE_Any_Member_Type
), Loc
),
9611 Parameter_Associations
=> New_List
(
9612 New_Occurrence_Of
(Container
, Loc
),
9613 Make_Integer_Literal
(Loc
,
9616 -- Declare inner struct aggregate (which
9617 -- contains the components of this VP).
9619 Append_To
(Block_Decls
,
9620 Make_Object_Declaration
(Loc
,
9621 Defining_Identifier
=> Struct_Any
,
9622 Object_Definition
=>
9623 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9625 Make_Function_Call
(Loc
,
9626 Name
=> New_Occurrence_Of
(
9627 RTE
(RE_Create_Any
), Loc
),
9628 Parameter_Associations
=> New_List
(
9629 Make_Function_Call
(Loc
,
9632 RTE
(RE_Any_Member_Type
), Loc
),
9633 Parameter_Associations
=> New_List
(
9634 New_Occurrence_Of
(Union_Any
, Loc
),
9635 Make_Integer_Literal
(Loc
,
9638 -- Build case statement
9640 Append_To
(Block_Stmts
,
9641 Make_Case_Statement
(Loc
,
9642 Expression
=> Make_Discriminant_Reference
,
9643 Alternatives
=> Alt_List
));
9645 Variant
:= First_Non_Pragma
(Variants
(Field
));
9646 while Present
(Variant
) loop
9647 Choice_List
:= New_Copy_List_Tree
9648 (Discrete_Choices
(Variant
));
9650 VP_Stmts
:= New_List
;
9652 -- Append discriminant val to union aggregate
9654 Append_To
(VP_Stmts
,
9655 Make_Procedure_Call_Statement
(Loc
,
9658 RTE
(RE_Add_Aggregate_Element
), Loc
),
9659 Parameter_Associations
=> New_List
(
9660 New_Occurrence_Of
(Union_Any
, Loc
),
9662 (Make_Discriminant_Reference
,
9665 -- Populate inner struct aggregate
9667 -- Struct_Counter should be reset before
9668 -- handling a variant part. Indeed only one
9669 -- of the case statement alternatives will be
9670 -- executed at run time, so the counter must
9671 -- start at 0 for every case statement.
9673 Struct_Counter
:= 0;
9675 TA_Append_Record_Traversal
9677 Clist
=> Component_List
(Variant
),
9678 Container
=> Struct_Any
,
9679 Counter
=> Struct_Counter
);
9681 -- Append inner struct to union aggregate
9683 Append_To
(VP_Stmts
,
9684 Make_Procedure_Call_Statement
(Loc
,
9687 (RTE
(RE_Add_Aggregate_Element
), Loc
),
9688 Parameter_Associations
=> New_List
(
9689 New_Occurrence_Of
(Union_Any
, Loc
),
9690 New_Occurrence_Of
(Struct_Any
, Loc
))));
9692 -- Append union to outer aggregate
9694 Append_To
(VP_Stmts
,
9695 Make_Procedure_Call_Statement
(Loc
,
9698 (RTE
(RE_Add_Aggregate_Element
), Loc
),
9699 Parameter_Associations
=> New_List
(
9700 New_Occurrence_Of
(Container
, Loc
),
9702 (Union_Any
, Loc
))));
9704 Append_To
(Alt_List
,
9705 Make_Case_Statement_Alternative
(Loc
,
9706 Discrete_Choices
=> Choice_List
,
9707 Statements
=> VP_Stmts
));
9709 Next_Non_Pragma
(Variant
);
9714 Counter
:= Counter
+ 1;
9715 end TA_Rec_Add_Process_Element
;
9718 -- Records are encoded in a TC_STRUCT aggregate:
9720 -- -- Outer aggregate (TC_STRUCT)
9721 -- | [discriminant1]
9722 -- | [discriminant2]
9729 -- A component can be a common component or variant part
9731 -- A variant part is encoded as a TC_UNION aggregate:
9733 -- -- Variant Part Aggregate (TC_UNION)
9734 -- | [discriminant choice for this Variant Part]
9736 -- | -- Inner struct (TC_STRUCT)
9741 -- Let's start by building the outer aggregate. First we
9742 -- construct Elements array containing all discriminants.
9744 if Has_Discriminants
(Typ
) then
9745 Disc
:= First_Discriminant
(Typ
);
9746 while Present
(Disc
) loop
9748 Discriminant
: constant Entity_Id
:=
9749 Make_Selected_Component
(Loc
,
9756 Set_Etype
(Discriminant
, Etype
(Disc
));
9758 Append_To
(Elements
,
9759 Make_Component_Association
(Loc
,
9760 Choices
=> New_List
(
9761 Make_Integer_Literal
(Loc
, Counter
)),
9763 Build_To_Any_Call
(Discriminant
, Decls
)));
9766 Counter
:= Counter
+ 1;
9767 Next_Discriminant
(Disc
);
9771 -- If there are no discriminants, we declare an empty
9775 Dummy_Any
: constant Entity_Id
:=
9776 Make_Temporary
(Loc
, 'A');
9780 Make_Object_Declaration
(Loc
,
9781 Defining_Identifier
=> Dummy_Any
,
9782 Object_Definition
=>
9783 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
9785 Append_To
(Elements
,
9786 Make_Component_Association
(Loc
,
9787 Choices
=> New_List
(
9790 Make_Integer_Literal
(Loc
, 1),
9792 Make_Integer_Literal
(Loc
, 0))),
9794 New_Occurrence_Of
(Dummy_Any
, Loc
)));
9798 -- We build the result aggregate with discriminants
9799 -- as the first elements.
9801 Set_Expression
(Any_Decl
,
9802 Make_Function_Call
(Loc
,
9803 Name
=> New_Occurrence_Of
9804 (RTE
(RE_Any_Aggregate_Build
), Loc
),
9805 Parameter_Associations
=> New_List
(
9807 Make_Aggregate
(Loc
,
9808 Component_Associations
=> Elements
))));
9811 -- Then we append all the components to the result
9814 TA_Append_Record_Traversal
(Stms
,
9815 Clist
=> Component_List
(Rdef
),
9817 Counter
=> Counter
);
9821 elsif Is_Array_Type
(Typ
) then
9823 -- Constrained and unconstrained array types
9826 Constrained
: constant Boolean := Is_Constrained
(Typ
);
9828 procedure TA_Ary_Add_Process_Element
9831 Counter
: Entity_Id
;
9834 --------------------------------
9835 -- TA_Ary_Add_Process_Element --
9836 --------------------------------
9838 procedure TA_Ary_Add_Process_Element
9841 Counter
: Entity_Id
;
9844 pragma Unreferenced
(Counter
);
9846 Element_Any
: Node_Id
;
9849 if Etype
(Datum
) = RTE
(RE_Any
) then
9850 Element_Any
:= Datum
;
9852 Element_Any
:= Build_To_Any_Call
(Datum
, Decls
);
9856 Make_Procedure_Call_Statement
(Loc
,
9857 Name
=> New_Occurrence_Of
(
9858 RTE
(RE_Add_Aggregate_Element
), Loc
),
9859 Parameter_Associations
=> New_List
(
9860 New_Occurrence_Of
(Any
, Loc
),
9862 end TA_Ary_Add_Process_Element
;
9864 procedure Append_To_Any_Array_Iterator
is
9865 new Append_Array_Traversal
(
9867 Arry
=> Expr_Parameter
,
9868 Indices
=> New_List
,
9869 Add_Process_Element
=> TA_Ary_Add_Process_Element
);
9874 Set_Expression
(Any_Decl
,
9875 Make_Function_Call
(Loc
,
9877 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
9878 Parameter_Associations
=> New_List
(Result_TC
)));
9881 if not Constrained
then
9882 Index
:= First_Index
(Typ
);
9883 for J
in 1 .. Number_Dimensions
(Typ
) loop
9885 Make_Procedure_Call_Statement
(Loc
,
9888 RTE
(RE_Add_Aggregate_Element
), Loc
),
9889 Parameter_Associations
=> New_List
(
9890 New_Occurrence_Of
(Any
, Loc
),
9892 OK_Convert_To
(Etype
(Index
),
9893 Make_Attribute_Reference
(Loc
,
9895 New_Occurrence_Of
(Expr_Parameter
, Loc
),
9896 Attribute_Name
=> Name_First
,
9897 Expressions
=> New_List
(
9898 Make_Integer_Literal
(Loc
, J
)))),
9904 Append_To_Any_Array_Iterator
(Stms
, Any
);
9907 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9911 Set_Expression
(Any_Decl
,
9914 Find_Numeric_Representation
(Typ
),
9915 New_Occurrence_Of
(Expr_Parameter
, Loc
)),
9919 -- Default case, including tagged types: opaque representation
9921 Use_Opaque_Representation
:= True;
9924 if Use_Opaque_Representation
then
9926 Strm
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
9927 -- Stream used to store data representation produced by
9928 -- stream attribute.
9932 -- Strm : aliased Buffer_Stream_Type;
9935 Make_Object_Declaration
(Loc
,
9936 Defining_Identifier
=>
9940 Object_Definition
=>
9941 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
9944 -- T'Output (Strm'Access, E);
9947 Make_Attribute_Reference
(Loc
,
9948 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
9949 Attribute_Name
=> Name_Output
,
9950 Expressions
=> New_List
(
9951 Make_Attribute_Reference
(Loc
,
9952 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
9953 Attribute_Name
=> Name_Access
),
9954 New_Occurrence_Of
(Expr_Parameter
, Loc
))));
9957 -- BS_To_Any (Strm, A);
9960 Make_Procedure_Call_Statement
(Loc
,
9961 Name
=> New_Occurrence_Of
(RTE
(RE_BS_To_Any
), Loc
),
9962 Parameter_Associations
=> New_List
(
9963 New_Occurrence_Of
(Strm
, Loc
),
9964 New_Occurrence_Of
(Any
, Loc
))));
9967 -- Release_Buffer (Strm);
9970 Make_Procedure_Call_Statement
(Loc
,
9971 Name
=> New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
9972 Parameter_Associations
=> New_List
(
9973 New_Occurrence_Of
(Strm
, Loc
))));
9977 Append_To
(Decls
, Any_Decl
);
9979 if Present
(Result_TC
) then
9981 Make_Procedure_Call_Statement
(Loc
,
9982 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
9983 Parameter_Associations
=> New_List
(
9984 New_Occurrence_Of
(Any
, Loc
),
9989 Make_Simple_Return_Statement
(Loc
,
9990 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
9993 Make_Subprogram_Body
(Loc
,
9994 Specification
=> Spec
,
9995 Declarations
=> Decls
,
9996 Handled_Statement_Sequence
=>
9997 Make_Handled_Sequence_Of_Statements
(Loc
,
9998 Statements
=> Stms
));
9999 end Build_To_Any_Function
;
10001 -------------------------
10002 -- Build_TypeCode_Call --
10003 -------------------------
10005 function Build_TypeCode_Call
10008 Decls
: List_Id
) return Node_Id
10010 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
10011 -- The full view, if Typ is private; the completion,
10012 -- if Typ is incomplete.
10014 Fnam
: Entity_Id
:= Empty
;
10015 Lib_RE
: RE_Id
:= RE_Null
;
10019 -- Special case System.PolyORB.Interface.Any: its primitives have
10020 -- not been set yet, so can't call Find_Inherited_TSS.
10022 if Typ
= RTE
(RE_Any
) then
10023 Fnam
:= RTE
(RE_TC_A
);
10026 -- First simple case where the TypeCode is present
10027 -- in the type's TSS.
10029 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_TypeCode
);
10032 -- For the subtype representing a generic actual type, go to the
10035 if Is_Generic_Actual_Type
(U_Type
) then
10036 U_Type
:= Underlying_Type
(Base_Type
(U_Type
));
10039 -- For a standard subtype, go to the base type
10041 if Sloc
(U_Type
) <= Standard_Location
then
10042 U_Type
:= Base_Type
(U_Type
);
10046 if U_Type
= Standard_Boolean
then
10049 elsif U_Type
= Standard_Character
then
10052 elsif U_Type
= Standard_Wide_Character
then
10053 Lib_RE
:= RE_TC_WC
;
10055 elsif U_Type
= Standard_Wide_Wide_Character
then
10056 Lib_RE
:= RE_TC_WWC
;
10058 -- Floating point types
10060 elsif U_Type
= Standard_Short_Float
then
10061 Lib_RE
:= RE_TC_SF
;
10063 elsif U_Type
= Standard_Float
then
10066 elsif U_Type
= Standard_Long_Float
then
10067 Lib_RE
:= RE_TC_LF
;
10069 elsif U_Type
= Standard_Long_Long_Float
then
10070 Lib_RE
:= RE_TC_LLF
;
10072 -- Integer types (walk back to the base type)
10074 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
10075 Lib_RE
:= RE_TC_SSI
;
10077 elsif U_Type
= Etype
(Standard_Short_Integer
) then
10078 Lib_RE
:= RE_TC_SI
;
10080 elsif U_Type
= Etype
(Standard_Integer
) then
10083 elsif U_Type
= Etype
(Standard_Long_Integer
) then
10084 Lib_RE
:= RE_TC_LI
;
10086 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
10087 Lib_RE
:= RE_TC_LLI
;
10089 -- Unsigned integer types
10091 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
10092 Lib_RE
:= RE_TC_SSU
;
10094 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
10095 Lib_RE
:= RE_TC_SU
;
10097 elsif U_Type
= RTE
(RE_Unsigned
) then
10100 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
10101 Lib_RE
:= RE_TC_LU
;
10103 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
10104 Lib_RE
:= RE_TC_LLU
;
10106 elsif Is_RTE
(U_Type
, RE_Unbounded_String
) then
10107 Lib_RE
:= RE_TC_String
;
10109 -- Special DSA types
10111 elsif Is_RTE
(U_Type
, RE_Any_Container_Ptr
) then
10114 -- Other (non-primitive) types
10120 Build_TypeCode_Function
(Loc
, U_Type
, Decl
, Fnam
);
10121 Append_To
(Decls
, Decl
);
10125 if Lib_RE
/= RE_Null
then
10126 Fnam
:= RTE
(Lib_RE
);
10130 -- Call the function
10133 Make_Function_Call
(Loc
, Name
=> New_Occurrence_Of
(Fnam
, Loc
));
10135 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10137 Set_Etype
(Expr
, RTE
(RE_TypeCode
));
10140 end Build_TypeCode_Call
;
10142 -----------------------------
10143 -- Build_TypeCode_Function --
10144 -----------------------------
10146 procedure Build_TypeCode_Function
10149 Decl
: out Node_Id
;
10150 Fnam
: out Entity_Id
)
10153 Decls
: constant List_Id
:= New_List
;
10154 Stms
: constant List_Id
:= New_List
;
10156 TCNam
: constant Entity_Id
:=
10157 Make_Helper_Function_Name
(Loc
, Typ
, Name_TypeCode
);
10159 Parameters
: List_Id
;
10161 procedure Add_String_Parameter
10163 Parameter_List
: List_Id
);
10164 -- Add a literal for S to Parameters
10166 procedure Add_TypeCode_Parameter
10167 (TC_Node
: Node_Id
;
10168 Parameter_List
: List_Id
);
10169 -- Add the typecode for Typ to Parameters
10171 procedure Add_Long_Parameter
10172 (Expr_Node
: Node_Id
;
10173 Parameter_List
: List_Id
);
10174 -- Add a signed long integer expression to Parameters
10176 procedure Initialize_Parameter_List
10177 (Name_String
: String_Id
;
10178 Repo_Id_String
: String_Id
;
10179 Parameter_List
: out List_Id
);
10180 -- Return a list that contains the first two parameters
10181 -- for a parameterized typecode: name and repository id.
10183 function Make_Constructed_TypeCode
10185 Parameters
: List_Id
) return Node_Id
;
10186 -- Call TC_Build with the given kind and parameters
10188 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
);
10189 -- Make a return statement that calls TC_Build with the given
10190 -- typecode kind, and the constructed parameters list.
10192 procedure Return_Alias_TypeCode
(Base_TypeCode
: Node_Id
);
10193 -- Return a typecode that is a TC_Alias for the given typecode
10195 --------------------------
10196 -- Add_String_Parameter --
10197 --------------------------
10199 procedure Add_String_Parameter
10201 Parameter_List
: List_Id
)
10204 Append_To
(Parameter_List
,
10205 Make_Function_Call
(Loc
,
10206 Name
=> New_Occurrence_Of
(RTE
(RE_TA_Std_String
), Loc
),
10207 Parameter_Associations
=> New_List
(
10208 Make_String_Literal
(Loc
, S
))));
10209 end Add_String_Parameter
;
10211 ----------------------------
10212 -- Add_TypeCode_Parameter --
10213 ----------------------------
10215 procedure Add_TypeCode_Parameter
10216 (TC_Node
: Node_Id
;
10217 Parameter_List
: List_Id
)
10220 Append_To
(Parameter_List
,
10221 Make_Function_Call
(Loc
,
10222 Name
=> New_Occurrence_Of
(RTE
(RE_TA_TC
), Loc
),
10223 Parameter_Associations
=> New_List
(TC_Node
)));
10224 end Add_TypeCode_Parameter
;
10226 ------------------------
10227 -- Add_Long_Parameter --
10228 ------------------------
10230 procedure Add_Long_Parameter
10231 (Expr_Node
: Node_Id
;
10232 Parameter_List
: List_Id
)
10235 Append_To
(Parameter_List
,
10236 Make_Function_Call
(Loc
,
10237 Name
=> New_Occurrence_Of
(RTE
(RE_TA_LI
), Loc
),
10238 Parameter_Associations
=> New_List
(Expr_Node
)));
10239 end Add_Long_Parameter
;
10241 -------------------------------
10242 -- Initialize_Parameter_List --
10243 -------------------------------
10245 procedure Initialize_Parameter_List
10246 (Name_String
: String_Id
;
10247 Repo_Id_String
: String_Id
;
10248 Parameter_List
: out List_Id
)
10251 Parameter_List
:= New_List
;
10252 Add_String_Parameter
(Name_String
, Parameter_List
);
10253 Add_String_Parameter
(Repo_Id_String
, Parameter_List
);
10254 end Initialize_Parameter_List
;
10256 ---------------------------
10257 -- Return_Alias_TypeCode --
10258 ---------------------------
10260 procedure Return_Alias_TypeCode
10261 (Base_TypeCode
: Node_Id
)
10264 Add_TypeCode_Parameter
(Base_TypeCode
, Parameters
);
10265 Return_Constructed_TypeCode
(RTE
(RE_TC_Alias
));
10266 end Return_Alias_TypeCode
;
10268 -------------------------------
10269 -- Make_Constructed_TypeCode --
10270 -------------------------------
10272 function Make_Constructed_TypeCode
10274 Parameters
: List_Id
) return Node_Id
10276 Constructed_TC
: constant Node_Id
:=
10277 Make_Function_Call
(Loc
,
10279 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
10280 Parameter_Associations
=> New_List
(
10281 New_Occurrence_Of
(Kind
, Loc
),
10282 Make_Aggregate
(Loc
,
10283 Expressions
=> Parameters
)));
10285 Set_Etype
(Constructed_TC
, RTE
(RE_TypeCode
));
10286 return Constructed_TC
;
10287 end Make_Constructed_TypeCode
;
10289 ---------------------------------
10290 -- Return_Constructed_TypeCode --
10291 ---------------------------------
10293 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
) is
10296 Make_Simple_Return_Statement
(Loc
,
10298 Make_Constructed_TypeCode
(Kind
, Parameters
)));
10299 end Return_Constructed_TypeCode
;
10305 procedure TC_Rec_Add_Process_Element
10308 Counter
: in out Int
;
10312 procedure TC_Append_Record_Traversal
is
10313 new Append_Record_Traversal
(
10315 Add_Process_Element
=> TC_Rec_Add_Process_Element
);
10317 --------------------------------
10318 -- TC_Rec_Add_Process_Element --
10319 --------------------------------
10321 procedure TC_Rec_Add_Process_Element
10324 Counter
: in out Int
;
10328 pragma Unreferenced
(Any
, Counter
, Rec
);
10331 if Nkind
(Field
) = N_Defining_Identifier
then
10333 -- A regular component
10335 Add_TypeCode_Parameter
10336 (Build_TypeCode_Call
(Loc
, Etype
(Field
), Decls
), Params
);
10337 Get_Name_String
(Chars
(Field
));
10338 Add_String_Parameter
(String_From_Name_Buffer
, Params
);
10345 Discriminant_Type
: constant Entity_Id
:=
10346 Etype
(Name
(Field
));
10348 Is_Enum
: constant Boolean :=
10349 Is_Enumeration_Type
(Discriminant_Type
);
10351 Union_TC_Params
: List_Id
;
10353 U_Name
: constant Name_Id
:=
10354 New_External_Name
(Chars
(Typ
), 'V', -1);
10356 Name_Str
: String_Id
;
10357 Struct_TC_Params
: List_Id
;
10361 Default
: constant Node_Id
:=
10362 Make_Integer_Literal
(Loc
, -1);
10364 Dummy_Counter
: Int
:= 0;
10366 Choice_Index
: Int
:= 0;
10368 procedure Add_Params_For_Variant_Components
;
10369 -- Add a struct TypeCode and a corresponding member name
10370 -- to the union parameter list.
10372 -- Ordering of declarations is a complete mess in this
10373 -- area, it is supposed to be types/variables, then
10374 -- subprogram specs, then subprogram bodies ???
10376 ---------------------------------------
10377 -- Add_Params_For_Variant_Components --
10378 ---------------------------------------
10380 procedure Add_Params_For_Variant_Components
10382 S_Name
: constant Name_Id
:=
10383 New_External_Name
(U_Name
, 'S', -1);
10386 Get_Name_String
(S_Name
);
10387 Name_Str
:= String_From_Name_Buffer
;
10388 Initialize_Parameter_List
10389 (Name_Str
, Name_Str
, Struct_TC_Params
);
10391 -- Build struct parameters
10393 TC_Append_Record_Traversal
(Struct_TC_Params
,
10394 Component_List
(Variant
),
10398 Add_TypeCode_Parameter
10399 (Make_Constructed_TypeCode
10400 (RTE
(RE_TC_Struct
), Struct_TC_Params
),
10403 Add_String_Parameter
(Name_Str
, Union_TC_Params
);
10404 end Add_Params_For_Variant_Components
;
10407 Get_Name_String
(U_Name
);
10408 Name_Str
:= String_From_Name_Buffer
;
10410 Initialize_Parameter_List
10411 (Name_Str
, Name_Str
, Union_TC_Params
);
10413 -- Add union in enclosing parameter list
10415 Add_TypeCode_Parameter
10416 (Make_Constructed_TypeCode
10417 (RTE
(RE_TC_Union
), Union_TC_Params
),
10420 Add_String_Parameter
(Name_Str
, Params
);
10422 -- Build union parameters
10424 Add_TypeCode_Parameter
10425 (Build_TypeCode_Call
10426 (Loc
, Discriminant_Type
, Decls
),
10429 Add_Long_Parameter
(Default
, Union_TC_Params
);
10431 Variant
:= First_Non_Pragma
(Variants
(Field
));
10432 while Present
(Variant
) loop
10433 Choice
:= First
(Discrete_Choices
(Variant
));
10434 while Present
(Choice
) loop
10435 case Nkind
(Choice
) is
10438 L
: constant Uint
:=
10439 Expr_Value
(Low_Bound
(Choice
));
10440 H
: constant Uint
:=
10441 Expr_Value
(High_Bound
(Choice
));
10443 -- 3.8.1(8) guarantees that the bounds of
10444 -- this range are static.
10451 Expr
:= New_Occurrence_Of
(
10452 Get_Enum_Lit_From_Pos
(
10453 Discriminant_Type
, J
, Loc
), Loc
);
10456 Make_Integer_Literal
(Loc
, J
);
10458 Append_To
(Union_TC_Params
,
10459 Build_To_Any_Call
(Expr
, Decls
));
10461 Add_Params_For_Variant_Components
;
10466 when N_Others_Choice
=>
10468 -- This variant possess a default choice.
10469 -- We must therefore set the default
10470 -- parameter to the current choice index. The
10471 -- default parameter is by construction the
10472 -- fourth in the Union_TC_Params list.
10475 Default_Node
: constant Node_Id
:=
10476 Pick
(Union_TC_Params
, 4);
10478 New_Default_Node
: constant Node_Id
:=
10479 Make_Function_Call
(Loc
,
10482 (RTE
(RE_TA_LI
), Loc
),
10483 Parameter_Associations
=>
10485 Make_Integer_Literal
10486 (Loc
, Choice_Index
)));
10492 Remove
(Default_Node
);
10495 -- Add a placeholder member label
10496 -- for the default case.
10497 -- It must be of the discriminant type.
10500 Exp
: constant Node_Id
:=
10501 Make_Attribute_Reference
(Loc
,
10502 Prefix
=> New_Occurrence_Of
10503 (Discriminant_Type
, Loc
),
10504 Attribute_Name
=> Name_First
);
10506 Set_Etype
(Exp
, Discriminant_Type
);
10507 Append_To
(Union_TC_Params
,
10508 Build_To_Any_Call
(Exp
, Decls
));
10511 Add_Params_For_Variant_Components
;
10515 -- Case of an explicit choice
10518 Exp
: constant Node_Id
:=
10519 New_Copy_Tree
(Choice
);
10521 Append_To
(Union_TC_Params
,
10522 Build_To_Any_Call
(Exp
, Decls
));
10525 Add_Params_For_Variant_Components
;
10529 Choice_Index
:= Choice_Index
+ 1;
10532 Next_Non_Pragma
(Variant
);
10536 end TC_Rec_Add_Process_Element
;
10538 Type_Name_Str
: String_Id
;
10539 Type_Repo_Id_Str
: String_Id
;
10541 -- Start of processing for Build_TypeCode_Function
10544 -- For a derived type, we can't go past the base type (to the
10545 -- parent type) here, because that would cause the attribute's
10546 -- formal parameter to have the wrong type; hence the Base_Type
10549 if Is_Itype
(Typ
) and then Typ
/= Base_Type
(Typ
) then
10550 Build_TypeCode_Function
10552 Typ
=> Etype
(Typ
),
10561 Make_Function_Specification
(Loc
,
10562 Defining_Unit_Name
=> Fnam
,
10563 Parameter_Specifications
=> Empty_List
,
10564 Result_Definition
=>
10565 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
10567 Build_Name_And_Repository_Id
(Typ
,
10568 Name_Str
=> Type_Name_Str
, Repo_Id_Str
=> Type_Repo_Id_Str
);
10570 Initialize_Parameter_List
10571 (Type_Name_Str
, Type_Repo_Id_Str
, Parameters
);
10573 if Has_Stream_Attribute_Definition
10574 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
10576 Has_Stream_Attribute_Definition
10577 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
10579 -- If user-defined stream attributes are specified for this
10580 -- type, use them and transmit data as an opaque sequence of
10581 -- stream elements.
10583 Return_Alias_TypeCode
10584 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10586 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
10587 Return_Alias_TypeCode
(
10588 Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10590 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
10591 Return_Alias_TypeCode
(
10592 Build_TypeCode_Call
(Loc
,
10593 Find_Numeric_Representation
(Typ
), Decls
));
10595 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
10597 -- Record typecodes are encoded as follows:
10601 -- | [Repository Id]
10603 -- Then for each discriminant:
10605 -- | [Discriminant Type Code]
10606 -- | [Discriminant Name]
10609 -- Then for each component:
10611 -- | [Component Type Code]
10612 -- | [Component Name]
10615 -- Variants components type codes are encoded as follows:
10619 -- | [Repository Id]
10620 -- | [Discriminant Type Code]
10621 -- | [Index of Default Variant Part or -1 for no default]
10623 -- Then for each Variant Part :
10628 -- | | [Variant Part Name]
10629 -- | | [Variant Part Repository Id]
10631 -- | Then for each VP component:
10632 -- | | [VP component Typecode]
10633 -- | | [VP component Name]
10639 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
10640 Return_Alias_TypeCode
10641 (Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10645 Disc
: Entity_Id
:= Empty
;
10646 Rdef
: constant Node_Id
:=
10647 Type_Definition
(Declaration_Node
(Typ
));
10648 Dummy_Counter
: Int
:= 0;
10651 -- Construct the discriminants typecodes
10653 if Has_Discriminants
(Typ
) then
10654 Disc
:= First_Discriminant
(Typ
);
10657 while Present
(Disc
) loop
10658 Add_TypeCode_Parameter
(
10659 Build_TypeCode_Call
(Loc
, Etype
(Disc
), Decls
),
10661 Get_Name_String
(Chars
(Disc
));
10662 Add_String_Parameter
(
10663 String_From_Name_Buffer
,
10665 Next_Discriminant
(Disc
);
10668 -- then the components typecodes
10670 TC_Append_Record_Traversal
10671 (Parameters
, Component_List
(Rdef
),
10672 Empty
, Dummy_Counter
);
10673 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10677 elsif Is_Array_Type
(Typ
) then
10679 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10680 Inner_TypeCode
: Node_Id
;
10681 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10682 Indx
: Node_Id
:= First_Index
(Typ
);
10686 Build_TypeCode_Call
(Loc
, Component_Type
(Typ
), Decls
);
10688 for J
in 1 .. Ndim
loop
10689 if Constrained
then
10690 Inner_TypeCode
:= Make_Constructed_TypeCode
10691 (RTE
(RE_TC_Array
), New_List
(
10692 Build_To_Any_Call
(
10693 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10694 Make_Attribute_Reference
(Loc
,
10695 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
10696 Attribute_Name
=> Name_Length
,
10697 Expressions
=> New_List
(
10698 Make_Integer_Literal
(Loc
,
10699 Intval
=> Ndim
- J
+ 1)))),
10701 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10704 -- Unconstrained case: add low bound for each
10707 Add_TypeCode_Parameter
10708 (Build_TypeCode_Call
(Loc
, Etype
(Indx
), Decls
),
10710 Get_Name_String
(New_External_Name
('L', J
));
10711 Add_String_Parameter
(
10712 String_From_Name_Buffer
,
10716 Inner_TypeCode
:= Make_Constructed_TypeCode
10717 (RTE
(RE_TC_Sequence
), New_List
(
10718 Build_To_Any_Call
(
10719 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10720 Make_Integer_Literal
(Loc
, 0)),
10722 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10726 if Constrained
then
10727 Return_Alias_TypeCode
(Inner_TypeCode
);
10729 Add_TypeCode_Parameter
(Inner_TypeCode
, Parameters
);
10731 Store_String_Char
('V');
10732 Add_String_Parameter
(End_String
, Parameters
);
10733 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10738 -- Default: type is represented as an opaque sequence of bytes
10740 Return_Alias_TypeCode
10741 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10745 Make_Subprogram_Body
(Loc
,
10746 Specification
=> Spec
,
10747 Declarations
=> Decls
,
10748 Handled_Statement_Sequence
=>
10749 Make_Handled_Sequence_Of_Statements
(Loc
,
10750 Statements
=> Stms
));
10751 end Build_TypeCode_Function
;
10753 ---------------------------------
10754 -- Find_Numeric_Representation --
10755 ---------------------------------
10757 function Find_Numeric_Representation
10758 (Typ
: Entity_Id
) return Entity_Id
10760 FST
: constant Entity_Id
:= First_Subtype
(Typ
);
10761 P_Size
: constant Uint
:= Esize
(FST
);
10764 if Is_Unsigned_Type
(Typ
) then
10765 if P_Size
<= Standard_Short_Short_Integer_Size
then
10766 return RTE
(RE_Short_Short_Unsigned
);
10768 elsif P_Size
<= Standard_Short_Integer_Size
then
10769 return RTE
(RE_Short_Unsigned
);
10771 elsif P_Size
<= Standard_Integer_Size
then
10772 return RTE
(RE_Unsigned
);
10774 elsif P_Size
<= Standard_Long_Integer_Size
then
10775 return RTE
(RE_Long_Unsigned
);
10778 return RTE
(RE_Long_Long_Unsigned
);
10781 elsif Is_Integer_Type
(Typ
) then
10782 if P_Size
<= Standard_Short_Short_Integer_Size
then
10783 return Standard_Short_Short_Integer
;
10785 elsif P_Size
<= Standard_Short_Integer_Size
then
10786 return Standard_Short_Integer
;
10788 elsif P_Size
<= Standard_Integer_Size
then
10789 return Standard_Integer
;
10791 elsif P_Size
<= Standard_Long_Integer_Size
then
10792 return Standard_Long_Integer
;
10795 return Standard_Long_Long_Integer
;
10798 elsif Is_Floating_Point_Type
(Typ
) then
10799 if P_Size
<= Standard_Short_Float_Size
then
10800 return Standard_Short_Float
;
10802 elsif P_Size
<= Standard_Float_Size
then
10803 return Standard_Float
;
10805 elsif P_Size
<= Standard_Long_Float_Size
then
10806 return Standard_Long_Float
;
10809 return Standard_Long_Long_Float
;
10813 raise Program_Error
;
10816 -- TBD: fixed point types???
10817 -- TBverified numeric types with a biased representation???
10819 end Find_Numeric_Representation
;
10821 ---------------------------
10822 -- Append_Array_Traversal --
10823 ---------------------------
10825 procedure Append_Array_Traversal
10828 Counter
: Entity_Id
:= Empty
;
10831 Loc
: constant Source_Ptr
:= Sloc
(Subprogram
);
10832 Typ
: constant Entity_Id
:= Etype
(Arry
);
10833 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10834 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10836 Inner_Any
, Inner_Counter
: Entity_Id
;
10838 Loop_Stm
: Node_Id
;
10839 Inner_Stmts
: constant List_Id
:= New_List
;
10842 if Depth
> Ndim
then
10844 -- Processing for one element of an array
10847 Element_Expr
: constant Node_Id
:=
10848 Make_Indexed_Component
(Loc
,
10849 New_Occurrence_Of
(Arry
, Loc
),
10852 Set_Etype
(Element_Expr
, Component_Type
(Typ
));
10853 Add_Process_Element
(Stmts
,
10855 Counter
=> Counter
,
10856 Datum
=> Element_Expr
);
10862 Append_To
(Indices
,
10863 Make_Identifier
(Loc
, New_External_Name
('L', Depth
)));
10865 if not Constrained
or else Depth
> 1 then
10866 Inner_Any
:= Make_Defining_Identifier
(Loc
,
10867 New_External_Name
('A', Depth
));
10868 Set_Etype
(Inner_Any
, RTE
(RE_Any
));
10870 Inner_Any
:= Empty
;
10873 if Present
(Counter
) then
10874 Inner_Counter
:= Make_Defining_Identifier
(Loc
,
10875 New_External_Name
('J', Depth
));
10877 Inner_Counter
:= Empty
;
10881 Loop_Any
: Node_Id
:= Inner_Any
;
10884 -- For the first dimension of a constrained array, we add
10885 -- elements directly in the corresponding Any; there is no
10886 -- intervening inner Any.
10888 if No
(Loop_Any
) then
10892 Append_Array_Traversal
(Inner_Stmts
,
10894 Counter
=> Inner_Counter
,
10895 Depth
=> Depth
+ 1);
10899 Make_Implicit_Loop_Statement
(Subprogram
,
10900 Iteration_Scheme
=>
10901 Make_Iteration_Scheme
(Loc
,
10902 Loop_Parameter_Specification
=>
10903 Make_Loop_Parameter_Specification
(Loc
,
10904 Defining_Identifier
=>
10905 Make_Defining_Identifier
(Loc
,
10906 Chars
=> New_External_Name
('L', Depth
)),
10908 Discrete_Subtype_Definition
=>
10909 Make_Attribute_Reference
(Loc
,
10910 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10911 Attribute_Name
=> Name_Range
,
10913 Expressions
=> New_List
(
10914 Make_Integer_Literal
(Loc
, Depth
))))),
10915 Statements
=> Inner_Stmts
);
10918 Decls
: constant List_Id
:= New_List
;
10919 Dimen_Stmts
: constant List_Id
:= New_List
;
10920 Length_Node
: Node_Id
;
10922 Inner_Any_TypeCode
: constant Entity_Id
:=
10923 Make_Defining_Identifier
(Loc
,
10924 New_External_Name
('T', Depth
));
10926 Inner_Any_TypeCode_Expr
: Node_Id
;
10930 if Constrained
then
10931 Inner_Any_TypeCode_Expr
:=
10932 Make_Function_Call
(Loc
,
10933 Name
=> New_Occurrence_Of
(RTE
(RE_Get_TC
), Loc
),
10934 Parameter_Associations
=> New_List
(
10935 New_Occurrence_Of
(Any
, Loc
)));
10938 Inner_Any_TypeCode_Expr
:=
10939 Make_Function_Call
(Loc
,
10941 New_Occurrence_Of
(RTE
(RE_Any_Member_Type
), Loc
),
10942 Parameter_Associations
=> New_List
(
10943 New_Occurrence_Of
(Any
, Loc
),
10944 Make_Integer_Literal
(Loc
, Ndim
)));
10948 Inner_Any_TypeCode_Expr
:=
10949 Make_Function_Call
(Loc
,
10950 Name
=> New_Occurrence_Of
(RTE
(RE_Content_Type
), Loc
),
10951 Parameter_Associations
=> New_List
(
10952 Make_Identifier
(Loc
,
10953 Chars
=> New_External_Name
('T', Depth
- 1))));
10957 Make_Object_Declaration
(Loc
,
10958 Defining_Identifier
=> Inner_Any_TypeCode
,
10959 Constant_Present
=> True,
10960 Object_Definition
=> New_Occurrence_Of
(
10961 RTE
(RE_TypeCode
), Loc
),
10962 Expression
=> Inner_Any_TypeCode_Expr
));
10964 if Present
(Inner_Any
) then
10966 Make_Object_Declaration
(Loc
,
10967 Defining_Identifier
=> Inner_Any
,
10968 Object_Definition
=>
10969 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
10971 Make_Function_Call
(Loc
,
10973 New_Occurrence_Of
(
10974 RTE
(RE_Create_Any
), Loc
),
10975 Parameter_Associations
=> New_List
(
10976 New_Occurrence_Of
(Inner_Any_TypeCode
, Loc
)))));
10979 if Present
(Inner_Counter
) then
10981 Make_Object_Declaration
(Loc
,
10982 Defining_Identifier
=> Inner_Counter
,
10983 Object_Definition
=>
10984 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
10986 Make_Integer_Literal
(Loc
, 0)));
10989 if not Constrained
then
10990 Length_Node
:= Make_Attribute_Reference
(Loc
,
10991 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10992 Attribute_Name
=> Name_Length
,
10994 New_List
(Make_Integer_Literal
(Loc
, Depth
)));
10995 Set_Etype
(Length_Node
, RTE
(RE_Long_Unsigned
));
10997 Add_Process_Element
(Dimen_Stmts
,
10998 Datum
=> Length_Node
,
11000 Counter
=> Inner_Counter
);
11003 -- Loop_Stm does appropriate processing for each element
11006 Append_To
(Dimen_Stmts
, Loop_Stm
);
11008 -- Link outer and inner any
11010 if Present
(Inner_Any
) then
11011 Add_Process_Element
(Dimen_Stmts
,
11013 Counter
=> Counter
,
11014 Datum
=> New_Occurrence_Of
(Inner_Any
, Loc
));
11018 Make_Block_Statement
(Loc
,
11021 Handled_Statement_Sequence
=>
11022 Make_Handled_Sequence_Of_Statements
(Loc
,
11023 Statements
=> Dimen_Stmts
)));
11025 end Append_Array_Traversal
;
11027 -------------------------------
11028 -- Make_Helper_Function_Name --
11029 -------------------------------
11031 function Make_Helper_Function_Name
11034 Nam
: Name_Id
) return Entity_Id
11039 -- For tagged types, we use a canonical name so that it matches
11040 -- the primitive spec. For all other cases, we use a serialized
11041 -- name so that multiple generations of the same procedure do
11045 if not Is_Tagged_Type
(Typ
) then
11046 Serial
:= Increment_Serial_Number
;
11049 -- Use prefixed underscore to avoid potential clash with used
11050 -- identifier (we use attribute names for Nam).
11053 Make_Defining_Identifier
(Loc
,
11056 (Related_Id
=> Nam
,
11057 Suffix
=> ' ', Suffix_Index
=> Serial
,
11060 end Make_Helper_Function_Name
;
11063 -----------------------------------
11064 -- Reserve_NamingContext_Methods --
11065 -----------------------------------
11067 procedure Reserve_NamingContext_Methods
is
11068 Str_Resolve
: constant String := "resolve";
11070 Name_Buffer
(1 .. Str_Resolve
'Length) := Str_Resolve
;
11071 Name_Len
:= Str_Resolve
'Length;
11072 Overload_Counter_Table
.Set
(Name_Find
, 1);
11073 end Reserve_NamingContext_Methods
;
11075 end PolyORB_Support
;
11077 -------------------------------
11078 -- RACW_Type_Is_Asynchronous --
11079 -------------------------------
11081 procedure RACW_Type_Is_Asynchronous
(RACW_Type
: Entity_Id
) is
11082 Asynchronous_Flag
: constant Entity_Id
:=
11083 Asynchronous_Flags_Table
.Get
(RACW_Type
);
11085 Replace
(Expression
(Parent
(Asynchronous_Flag
)),
11086 New_Occurrence_Of
(Standard_True
, Sloc
(Asynchronous_Flag
)));
11087 end RACW_Type_Is_Asynchronous
;
11089 -------------------------
11090 -- RCI_Package_Locator --
11091 -------------------------
11093 function RCI_Package_Locator
11095 Package_Spec
: Node_Id
) return Node_Id
11098 Pkg_Name
: String_Id
;
11101 Get_Library_Unit_Name_String
(Package_Spec
);
11102 Pkg_Name
:= String_From_Name_Buffer
;
11104 Make_Package_Instantiation
(Loc
,
11105 Defining_Unit_Name
=> Make_Temporary
(Loc
, 'R'),
11108 New_Occurrence_Of
(RTE
(RE_RCI_Locator
), Loc
),
11110 Generic_Associations
=> New_List
(
11111 Make_Generic_Association
(Loc
,
11113 Make_Identifier
(Loc
, Name_RCI_Name
),
11114 Explicit_Generic_Actual_Parameter
=>
11115 Make_String_Literal
(Loc
,
11116 Strval
=> Pkg_Name
)),
11118 Make_Generic_Association
(Loc
,
11120 Make_Identifier
(Loc
, Name_Version
),
11121 Explicit_Generic_Actual_Parameter
=>
11122 Make_Attribute_Reference
(Loc
,
11124 New_Occurrence_Of
(Defining_Entity
(Package_Spec
), Loc
),
11128 RCI_Locator_Table
.Set
11129 (Defining_Unit_Name
(Package_Spec
),
11130 Defining_Unit_Name
(Inst
));
11132 end RCI_Package_Locator
;
11134 -----------------------------------------------
11135 -- Remote_Types_Tagged_Full_View_Encountered --
11136 -----------------------------------------------
11138 procedure Remote_Types_Tagged_Full_View_Encountered
11139 (Full_View
: Entity_Id
)
11141 Stub_Elements
: constant Stub_Structure
:=
11142 Stubs_Table
.Get
(Full_View
);
11145 -- For an RACW encountered before the freeze point of its designated
11146 -- type, the stub type is generated at the point of the RACW declaration
11147 -- but the primitives are generated only once the designated type is
11148 -- frozen. That freeze can occur in another scope, for example when the
11149 -- RACW is declared in a nested package. In that case we need to
11150 -- reestablish the stub type's scope prior to generating its primitive
11153 if Stub_Elements
/= Empty_Stub_Structure
then
11155 Saved_Scope
: constant Entity_Id
:= Current_Scope
;
11156 Stubs_Scope
: constant Entity_Id
:=
11157 Scope
(Stub_Elements
.Stub_Type
);
11160 if Current_Scope
/= Stubs_Scope
then
11161 Push_Scope
(Stubs_Scope
);
11164 Add_RACW_Primitive_Declarations_And_Bodies
11166 Stub_Elements
.RPC_Receiver_Decl
,
11167 Stub_Elements
.Body_Decls
);
11169 if Current_Scope
/= Saved_Scope
then
11174 end Remote_Types_Tagged_Full_View_Encountered
;
11176 -------------------
11177 -- Scope_Of_Spec --
11178 -------------------
11180 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
is
11181 Unit_Name
: Node_Id
;
11184 Unit_Name
:= Defining_Unit_Name
(Spec
);
11185 while Nkind
(Unit_Name
) /= N_Defining_Identifier
loop
11186 Unit_Name
:= Defining_Identifier
(Unit_Name
);
11192 ----------------------
11193 -- Set_Renaming_TSS --
11194 ----------------------
11196 procedure Set_Renaming_TSS
11199 TSS_Nam
: TSS_Name_Type
)
11201 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
11202 Spec
: constant Node_Id
:= Parent
(Nam
);
11204 TSS_Node
: constant Node_Id
:=
11205 Make_Subprogram_Renaming_Declaration
(Loc
,
11207 Copy_Specification
(Loc
,
11209 New_Name
=> Make_TSS_Name
(Typ
, TSS_Nam
)),
11210 Name
=> New_Occurrence_Of
(Nam
, Loc
));
11212 Snam
: constant Entity_Id
:=
11213 Defining_Unit_Name
(Specification
(TSS_Node
));
11216 if Nkind
(Spec
) = N_Function_Specification
then
11217 Set_Ekind
(Snam
, E_Function
);
11218 Set_Etype
(Snam
, Entity
(Result_Definition
(Spec
)));
11220 Set_Ekind
(Snam
, E_Procedure
);
11221 Set_Etype
(Snam
, Standard_Void_Type
);
11224 Set_TSS
(Typ
, Snam
);
11225 end Set_Renaming_TSS
;
11227 ----------------------------------------------
11228 -- Specific_Add_Obj_RPC_Receiver_Completion --
11229 ----------------------------------------------
11231 procedure Specific_Add_Obj_RPC_Receiver_Completion
11234 RPC_Receiver
: Entity_Id
;
11235 Stub_Elements
: Stub_Structure
)
11238 case Get_PCS_Name
is
11239 when Name_PolyORB_DSA
=>
11240 PolyORB_Support
.Add_Obj_RPC_Receiver_Completion
11241 (Loc
, Decls
, RPC_Receiver
, Stub_Elements
);
11243 GARLIC_Support
.Add_Obj_RPC_Receiver_Completion
11244 (Loc
, Decls
, RPC_Receiver
, Stub_Elements
);
11246 end Specific_Add_Obj_RPC_Receiver_Completion
;
11248 --------------------------------
11249 -- Specific_Add_RACW_Features --
11250 --------------------------------
11252 procedure Specific_Add_RACW_Features
11253 (RACW_Type
: Entity_Id
;
11255 Stub_Type
: Entity_Id
;
11256 Stub_Type_Access
: Entity_Id
;
11257 RPC_Receiver_Decl
: Node_Id
;
11258 Body_Decls
: List_Id
)
11261 case Get_PCS_Name
is
11262 when Name_PolyORB_DSA
=>
11263 PolyORB_Support
.Add_RACW_Features
11272 GARLIC_Support
.Add_RACW_Features
11279 end Specific_Add_RACW_Features
;
11281 --------------------------------
11282 -- Specific_Add_RAST_Features --
11283 --------------------------------
11285 procedure Specific_Add_RAST_Features
11286 (Vis_Decl
: Node_Id
;
11287 RAS_Type
: Entity_Id
)
11290 case Get_PCS_Name
is
11291 when Name_PolyORB_DSA
=>
11292 PolyORB_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
11294 GARLIC_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
11296 end Specific_Add_RAST_Features
;
11298 --------------------------------------------------
11299 -- Specific_Add_Receiving_Stubs_To_Declarations --
11300 --------------------------------------------------
11302 procedure Specific_Add_Receiving_Stubs_To_Declarations
11303 (Pkg_Spec
: Node_Id
;
11308 case Get_PCS_Name
is
11309 when Name_PolyORB_DSA
=>
11310 PolyORB_Support
.Add_Receiving_Stubs_To_Declarations
11311 (Pkg_Spec
, Decls
, Stmts
);
11313 GARLIC_Support
.Add_Receiving_Stubs_To_Declarations
11314 (Pkg_Spec
, Decls
, Stmts
);
11316 end Specific_Add_Receiving_Stubs_To_Declarations
;
11318 ------------------------------------------
11319 -- Specific_Build_General_Calling_Stubs --
11320 ------------------------------------------
11322 procedure Specific_Build_General_Calling_Stubs
11324 Statements
: List_Id
;
11325 Target
: RPC_Target
;
11326 Subprogram_Id
: Node_Id
;
11327 Asynchronous
: Node_Id
:= Empty
;
11328 Is_Known_Asynchronous
: Boolean := False;
11329 Is_Known_Non_Asynchronous
: Boolean := False;
11330 Is_Function
: Boolean;
11332 Stub_Type
: Entity_Id
:= Empty
;
11333 RACW_Type
: Entity_Id
:= Empty
;
11337 case Get_PCS_Name
is
11338 when Name_PolyORB_DSA
=>
11339 PolyORB_Support
.Build_General_Calling_Stubs
11345 Is_Known_Asynchronous
,
11346 Is_Known_Non_Asynchronous
,
11354 GARLIC_Support
.Build_General_Calling_Stubs
11358 Target
.RPC_Receiver
,
11361 Is_Known_Asynchronous
,
11362 Is_Known_Non_Asynchronous
,
11369 end Specific_Build_General_Calling_Stubs
;
11371 --------------------------------------
11372 -- Specific_Build_RPC_Receiver_Body --
11373 --------------------------------------
11375 procedure Specific_Build_RPC_Receiver_Body
11376 (RPC_Receiver
: Entity_Id
;
11377 Request
: out Entity_Id
;
11378 Subp_Id
: out Entity_Id
;
11379 Subp_Index
: out Entity_Id
;
11380 Stmts
: out List_Id
;
11381 Decl
: out Node_Id
)
11384 case Get_PCS_Name
is
11385 when Name_PolyORB_DSA
=>
11386 PolyORB_Support
.Build_RPC_Receiver_Body
11395 GARLIC_Support
.Build_RPC_Receiver_Body
11403 end Specific_Build_RPC_Receiver_Body
;
11405 --------------------------------
11406 -- Specific_Build_Stub_Target --
11407 --------------------------------
11409 function Specific_Build_Stub_Target
11412 RCI_Locator
: Entity_Id
;
11413 Controlling_Parameter
: Entity_Id
) return RPC_Target
11416 case Get_PCS_Name
is
11417 when Name_PolyORB_DSA
=>
11419 PolyORB_Support
.Build_Stub_Target
11420 (Loc
, Decls
, RCI_Locator
, Controlling_Parameter
);
11424 GARLIC_Support
.Build_Stub_Target
11425 (Loc
, Decls
, RCI_Locator
, Controlling_Parameter
);
11427 end Specific_Build_Stub_Target
;
11429 ------------------------------
11430 -- Specific_Build_Stub_Type --
11431 ------------------------------
11433 procedure Specific_Build_Stub_Type
11434 (RACW_Type
: Entity_Id
;
11435 Stub_Type_Comps
: out List_Id
;
11436 RPC_Receiver_Decl
: out Node_Id
)
11439 case Get_PCS_Name
is
11440 when Name_PolyORB_DSA
=>
11441 PolyORB_Support
.Build_Stub_Type
11442 (RACW_Type
, Stub_Type_Comps
, RPC_Receiver_Decl
);
11445 GARLIC_Support
.Build_Stub_Type
11446 (RACW_Type
, Stub_Type_Comps
, RPC_Receiver_Decl
);
11448 end Specific_Build_Stub_Type
;
11450 -----------------------------------------------
11451 -- Specific_Build_Subprogram_Receiving_Stubs --
11452 -----------------------------------------------
11454 function Specific_Build_Subprogram_Receiving_Stubs
11455 (Vis_Decl
: Node_Id
;
11456 Asynchronous
: Boolean;
11457 Dynamically_Asynchronous
: Boolean := False;
11458 Stub_Type
: Entity_Id
:= Empty
;
11459 RACW_Type
: Entity_Id
:= Empty
;
11460 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
11463 case Get_PCS_Name
is
11464 when Name_PolyORB_DSA
=>
11466 PolyORB_Support
.Build_Subprogram_Receiving_Stubs
11469 Dynamically_Asynchronous
,
11476 GARLIC_Support
.Build_Subprogram_Receiving_Stubs
11479 Dynamically_Asynchronous
,
11484 end Specific_Build_Subprogram_Receiving_Stubs
;
11486 -------------------------------
11487 -- Transmit_As_Unconstrained --
11488 -------------------------------
11490 function Transmit_As_Unconstrained
(Typ
: Entity_Id
) return Boolean is
11493 not (Is_Elementary_Type
(Typ
) or else Is_Constrained
(Typ
))
11494 or else (Is_Access_Type
(Typ
) and then Can_Never_Be_Null
(Typ
));
11495 end Transmit_As_Unconstrained
;
11497 --------------------------
11498 -- Underlying_RACW_Type --
11499 --------------------------
11501 function Underlying_RACW_Type
(RAS_Typ
: Entity_Id
) return Entity_Id
is
11502 Record_Type
: Entity_Id
;
11505 if Ekind
(RAS_Typ
) = E_Record_Type
then
11506 Record_Type
:= RAS_Typ
;
11508 pragma Assert
(Present
(Equivalent_Type
(RAS_Typ
)));
11509 Record_Type
:= Equivalent_Type
(RAS_Typ
);
11513 Etype
(Subtype_Indication
11514 (Component_Definition
11515 (First
(Component_Items
11518 (Declaration_Node
(Record_Type
))))))));
11519 end Underlying_RACW_Type
;