]>
Commit | Line | Data |
---|---|---|
70482933 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- E X P_ D I S T -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
8d0d46f4 | 9 | -- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- |
70482933 RK |
10 | -- -- |
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- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
70482933 RK |
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 -- | |
b5c84c3c RD |
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. -- | |
70482933 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
92869a7b | 26 | with Atree; use Atree; |
76f9c7f4 BD |
27 | with Einfo; use Einfo; |
28 | with Einfo.Entities; use Einfo.Entities; | |
29 | with Einfo.Utils; use Einfo.Utils; | |
92869a7b | 30 | with Elists; use Elists; |
c3d593c9 | 31 | with Exp_Atag; use Exp_Atag; |
92869a7b TQ |
32 | with Exp_Strm; use Exp_Strm; |
33 | with Exp_Tss; use Exp_Tss; | |
34 | with Exp_Util; use Exp_Util; | |
35 | with Lib; use Lib; | |
92869a7b TQ |
36 | with Nlists; use Nlists; |
37 | with Nmake; use Nmake; | |
38 | with Opt; use Opt; | |
39 | with Rtsfind; use Rtsfind; | |
40 | with Sem; use Sem; | |
a4100e55 | 41 | with Sem_Aux; use Sem_Aux; |
92869a7b TQ |
42 | with Sem_Cat; use Sem_Cat; |
43 | with Sem_Ch3; use Sem_Ch3; | |
44 | with Sem_Ch8; use Sem_Ch8; | |
ff2efe85 | 45 | with Sem_Ch12; use Sem_Ch12; |
92869a7b TQ |
46 | with Sem_Dist; use Sem_Dist; |
47 | with Sem_Eval; use Sem_Eval; | |
48 | with Sem_Util; use Sem_Util; | |
76f9c7f4 BD |
49 | with Sinfo; use Sinfo; |
50 | with Sinfo.Nodes; use Sinfo.Nodes; | |
51 | with Sinfo.Utils; use Sinfo.Utils; | |
92869a7b TQ |
52 | with Stand; use Stand; |
53 | with Stringt; use Stringt; | |
54 | with Tbuild; use Tbuild; | |
55 | with Ttypes; use Ttypes; | |
56 | with Uintp; use Uintp; | |
57 | ||
70482933 | 58 | with GNAT.HTable; use GNAT.HTable; |
70482933 RK |
59 | |
60 | package body Exp_Dist is | |
61 | ||
62 | -- The following model has been used to implement distributed objects: | |
c6f39437 | 63 | -- given a designated type D and a RACW type R, then a record of the form: |
9bc43c53 | 64 | |
70482933 RK |
65 | -- type Stub is tagged record |
66 | -- [...declaration similar to s-parint.ads RACW_Stub_Type...] | |
07fc65c4 | 67 | -- end record; |
9bc43c53 | 68 | |
70482933 | 69 | -- is built. This type has two properties: |
9bc43c53 | 70 | |
1d1bd8ad | 71 | -- 1) Since it has the same structure as RACW_Stub_Type, it can |
c6f39437 | 72 | -- be converted to and from this type to make it suitable for |
70482933 | 73 | -- System.Partition_Interface.Get_Unique_Remote_Pointer in order |
1d1bd8ad | 74 | -- to avoid memory leaks when the same remote object arrives on the |
0da2c8ac | 75 | -- same partition through several paths; |
9bc43c53 | 76 | |
70482933 RK |
77 | -- 2) It also has the same dispatching table as the designated type D, |
78 | -- and thus can be used as an object designated by a value of type | |
79 | -- R on any partition other than the one on which the object has | |
80 | -- been created, since only dispatching calls will be performed and | |
81 | -- the fields themselves will not be used. We call Derive_Subprograms | |
82 | -- to fake half a derivation to ensure that the subprograms do have | |
83 | -- the same dispatching table. | |
84 | ||
c885d7a1 AC |
85 | First_RCI_Subprogram_Id : constant := 2; |
86 | -- RCI subprograms are numbered starting at 2. The RCI receiver for | |
87 | -- an RCI package can thus identify calls received through remote | |
88 | -- access-to-subprogram dereferences by the fact that they have a | |
c6f39437 AC |
89 | -- (primitive) subprogram id of 0, and 1 is used for the internal RAS |
90 | -- information lookup operation. (This is for the Garlic code generation, | |
91 | -- where subprograms are identified by numbers; in the PolyORB version, | |
92 | -- they are identified by name, with a numeric suffix for homonyms.) | |
1735e55d AC |
93 | |
94 | type Hash_Index is range 0 .. 50; | |
c885d7a1 | 95 | |
70482933 RK |
96 | ----------------------- |
97 | -- Local subprograms -- | |
98 | ----------------------- | |
99 | ||
1735e55d | 100 | function Hash (F : Entity_Id) return Hash_Index; |
c6f39437 AC |
101 | -- DSA expansion associates stubs to distributed object types using a hash |
102 | -- table on entity ids. | |
1735e55d | 103 | |
6ce0c3f5 | 104 | function Hash (F : Name_Id) return Hash_Index; |
1735e55d | 105 | -- The generation of subprogram identifiers requires an overload counter |
1d1bd8ad | 106 | -- to be associated with each remote subprogram name. These counters are |
c6f39437 | 107 | -- maintained in a hash table on name ids. |
1735e55d AC |
108 | |
109 | type Subprogram_Identifiers is record | |
110 | Str_Identifier : String_Id; | |
111 | Int_Identifier : Int; | |
112 | end record; | |
113 | ||
114 | package Subprogram_Identifier_Table is | |
115 | new Simple_HTable (Header_Num => Hash_Index, | |
116 | Element => Subprogram_Identifiers, | |
117 | No_Element => (No_String, 0), | |
118 | Key => Entity_Id, | |
119 | Hash => Hash, | |
120 | Equal => "="); | |
c6f39437 AC |
121 | -- Mapping between a remote subprogram and the corresponding subprogram |
122 | -- identifiers. | |
1735e55d AC |
123 | |
124 | package Overload_Counter_Table is | |
125 | new Simple_HTable (Header_Num => Hash_Index, | |
126 | Element => Int, | |
127 | No_Element => 0, | |
128 | Key => Name_Id, | |
129 | Hash => Hash, | |
130 | Equal => "="); | |
c6f39437 AC |
131 | -- Mapping between a subprogram name and an integer that counts the number |
132 | -- of defining subprogram names with that Name_Id encountered so far in a | |
133 | -- given context (an interface). | |
1735e55d AC |
134 | |
135 | function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers; | |
136 | function Get_Subprogram_Id (Def : Entity_Id) return String_Id; | |
137 | function Get_Subprogram_Id (Def : Entity_Id) return Int; | |
138 | -- Given a subprogram defined in a RCI package, get its distribution | |
139 | -- subprogram identifiers (the distribution identifiers are a unique | |
140 | -- subprogram number, and the non-qualified subprogram name, in the | |
141 | -- casing used for the subprogram declaration; if the name is overloaded, | |
142 | -- a double underscore and a serial number are appended. | |
143 | -- | |
144 | -- The integer identifier is used to perform remote calls with GARLIC; | |
145 | -- the string identifier is used in the case of PolyORB. | |
146 | -- | |
147 | -- Although the PolyORB DSA receiving stubs will make a caseless comparison | |
148 | -- when receiving a call, the calling stubs will create requests with the | |
149 | -- exact casing of the defining unit name of the called subprogram, so as | |
150 | -- to allow calls to subprograms on distributed nodes that do distinguish | |
151 | -- between casings. | |
152 | -- | |
153 | -- NOTE: Another design would be to allow a representation clause on | |
154 | -- subprogram specs: for Subp'Distribution_Identifier use "fooBar"; | |
155 | ||
156 | pragma Warnings (Off, Get_Subprogram_Id); | |
157 | -- One homonym only is unreferenced (specific to the GARLIC version) | |
158 | ||
1735e55d AC |
159 | procedure Add_RAS_Dereference_TSS (N : Node_Id); |
160 | -- Add a subprogram body for RAS Dereference TSS | |
161 | ||
c885d7a1 | 162 | procedure Add_RAS_Proxy_And_Analyze |
1735e55d AC |
163 | (Decls : List_Id; |
164 | Vis_Decl : Node_Id; | |
165 | All_Calls_Remote_E : Entity_Id; | |
c885d7a1 | 166 | Proxy_Object_Addr : out Entity_Id); |
c3d593c9 TQ |
167 | -- Add the proxy type required, on the receiving (server) side, to handle |
168 | -- calls to the subprogram declared by Vis_Decl through a remote access | |
169 | -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma | |
170 | -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type | |
171 | -- is appended to Decls. Proxy_Object_Addr is a constant of type | |
172 | -- System.Address that designates an instance of the proxy object. | |
c885d7a1 AC |
173 | |
174 | function Build_Remote_Subprogram_Proxy_Type | |
175 | (Loc : Source_Ptr; | |
176 | ACR_Expression : Node_Id) return Node_Id; | |
1d1bd8ad AC |
177 | -- Build and return a tagged record type definition for an RCI subprogram |
178 | -- proxy type. ACR_Expression is used as the initialization value for the | |
179 | -- All_Calls_Remote component. | |
c885d7a1 | 180 | |
c885d7a1 AC |
181 | function Build_Get_Unique_RP_Call |
182 | (Loc : Source_Ptr; | |
183 | Pointer : Entity_Id; | |
184 | Stub_Type : Entity_Id) return List_Id; | |
1735e55d AC |
185 | -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a |
186 | -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to | |
187 | -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type). | |
c885d7a1 | 188 | |
d693e39d TQ |
189 | function Build_Stub_Tag |
190 | (Loc : Source_Ptr; | |
191 | RACW_Type : Entity_Id) return Node_Id; | |
192 | -- Return an expression denoting the tag of the stub type associated with | |
193 | -- RACW_Type. | |
194 | ||
70482933 RK |
195 | function Build_Subprogram_Calling_Stubs |
196 | (Vis_Decl : Node_Id; | |
1735e55d | 197 | Subp_Id : Node_Id; |
70482933 RK |
198 | Asynchronous : Boolean; |
199 | Dynamically_Asynchronous : Boolean := False; | |
200 | Stub_Type : Entity_Id := Empty; | |
48ab1182 | 201 | RACW_Type : Entity_Id := Empty; |
70482933 | 202 | Locator : Entity_Id := Empty; |
c885d7a1 | 203 | New_Name : Name_Id := No_Name) return Node_Id; |
70482933 RK |
204 | -- Build the calling stub for a given subprogram with the subprogram ID |
205 | -- being Subp_Id. If Stub_Type is given, then the "addr" field of | |
1d1bd8ad AC |
206 | -- parameters of this type will be marshalled instead of the object itself. |
207 | -- It will then be converted into Stub_Type before performing the real | |
208 | -- call. If Dynamically_Asynchronous is True, then it will be computed at | |
209 | -- run time whether the call is asynchronous or not. Otherwise, the value | |
210 | -- of the formal Asynchronous will be used. If Locator is not Empty, it | |
211 | -- will be used instead of RCI_Cache. If New_Name is given, then it will | |
212 | -- be used instead of the original name. | |
70482933 | 213 | |
16db96c5 AC |
214 | function Build_RPC_Receiver_Specification |
215 | (RPC_Receiver : Entity_Id; | |
216 | Request_Parameter : Entity_Id) return Node_Id; | |
217 | -- Make a subprogram specification for an RPC receiver, with the given | |
218 | -- defining unit name and formal parameter. | |
1735e55d | 219 | |
70482933 RK |
220 | function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id; |
221 | -- Return an ordered parameter list: unconstrained parameters are put | |
222 | -- at the beginning of the list and constrained ones are put after. If | |
c885d7a1 AC |
223 | -- there are no parameters, an empty list is returned. Special case: |
224 | -- the controlling formal of the equivalent RACW operation for a RAS | |
225 | -- type is always left in first position. | |
70482933 | 226 | |
7f0b5314 TQ |
227 | function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean; |
228 | -- True when Typ is an unconstrained type, or a null-excluding access type. | |
229 | -- In either case, this means stubs cannot contain a default-initialized | |
230 | -- object declaration of such type. | |
231 | ||
ff2efe85 | 232 | procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id); |
70482933 RK |
233 | -- Add calling stubs to the declarative part |
234 | ||
70482933 RK |
235 | function Could_Be_Asynchronous (Spec : Node_Id) return Boolean; |
236 | -- Return True if nothing prevents the program whose specification is | |
1d1bd8ad | 237 | -- given to be asynchronous (i.e. no [IN] OUT parameters). |
70482933 | 238 | |
70482933 RK |
239 | function Pack_Entity_Into_Stream_Access |
240 | (Loc : Source_Ptr; | |
fbf5a39b | 241 | Stream : Node_Id; |
70482933 | 242 | Object : Entity_Id; |
c885d7a1 | 243 | Etyp : Entity_Id := Empty) return Node_Id; |
70482933 RK |
244 | -- Pack Object (of type Etyp) into Stream. If Etyp is not given, |
245 | -- then Etype (Object) will be used if present. If the type is | |
246 | -- constrained, then 'Write will be used to output the object, | |
247 | -- If the type is unconstrained, 'Output will be used. | |
248 | ||
249 | function Pack_Node_Into_Stream | |
250 | (Loc : Source_Ptr; | |
251 | Stream : Entity_Id; | |
252 | Object : Node_Id; | |
c885d7a1 | 253 | Etyp : Entity_Id) return Node_Id; |
70482933 RK |
254 | -- Similar to above, with an arbitrary node instead of an entity |
255 | ||
256 | function Pack_Node_Into_Stream_Access | |
257 | (Loc : Source_Ptr; | |
fbf5a39b | 258 | Stream : Node_Id; |
70482933 | 259 | Object : Node_Id; |
c885d7a1 | 260 | Etyp : Entity_Id) return Node_Id; |
70482933 RK |
261 | -- Similar to above, with Stream instead of Stream'Access |
262 | ||
16db96c5 AC |
263 | function Make_Selected_Component |
264 | (Loc : Source_Ptr; | |
265 | Prefix : Entity_Id; | |
266 | Selector_Name : Name_Id) return Node_Id; | |
c6f39437 AC |
267 | -- Return a selected_component whose prefix denotes the given entity, and |
268 | -- with the given Selector_Name. | |
16db96c5 | 269 | |
70482933 RK |
270 | function Scope_Of_Spec (Spec : Node_Id) return Entity_Id; |
271 | -- Return the scope represented by a given spec | |
272 | ||
1735e55d AC |
273 | procedure Set_Renaming_TSS |
274 | (Typ : Entity_Id; | |
275 | Nam : Entity_Id; | |
a9d8907c | 276 | TSS_Nam : TSS_Name_Type); |
c6f39437 AC |
277 | -- Create a renaming declaration of subprogram Nam, and register it as a |
278 | -- TSS for Typ with name TSS_Nam. | |
1735e55d | 279 | |
70482933 RK |
280 | function Need_Extra_Constrained (Parameter : Node_Id) return Boolean; |
281 | -- Return True if the current parameter needs an extra formal to reflect | |
282 | -- its constrained status. | |
283 | ||
284 | function Is_RACW_Controlling_Formal | |
6ce0c3f5 TQ |
285 | (Parameter : Node_Id; |
286 | Stub_Type : Entity_Id) return Boolean; | |
70482933 RK |
287 | -- Return True if the current parameter is a controlling formal argument |
288 | -- of type Stub_Type or access to Stub_Type. | |
289 | ||
bd7f7a65 AC |
290 | procedure Declare_Create_NVList |
291 | (Loc : Source_Ptr; | |
292 | NVList : Entity_Id; | |
293 | Decls : List_Id; | |
294 | Stmts : List_Id); | |
295 | -- Append the declaration of NVList to Decls, and its | |
296 | -- initialization to Stmts. | |
297 | ||
298 | function Add_Parameter_To_NVList | |
299 | (Loc : Source_Ptr; | |
300 | NVList : Entity_Id; | |
301 | Parameter : Entity_Id; | |
302 | Constrained : Boolean; | |
303 | RACW_Ctrl : Boolean := False; | |
304 | Any : Entity_Id) return Node_Id; | |
8aa23fe3 TQ |
305 | -- Return a call to Add_Item to add the Any corresponding to the designated |
306 | -- formal Parameter (with the indicated Constrained status) to NVList. | |
307 | -- RACW_Ctrl must be set to True for controlling formals of distributed | |
308 | -- object primitive operations. | |
309 | ||
310 | -------------------- | |
311 | -- Stub_Structure -- | |
312 | -------------------- | |
313 | ||
314 | -- This record describes various tree fragments associated with the | |
315 | -- generation of RACW calling stubs. One such record exists for every | |
316 | -- distributed object type, i.e. each tagged type that is the designated | |
317 | -- type of one or more RACW type. | |
bd7f7a65 | 318 | |
70482933 | 319 | type Stub_Structure is record |
bd7f7a65 | 320 | Stub_Type : Entity_Id; |
8aa23fe3 TQ |
321 | -- Stub type: this type has the same primitive operations as the |
322 | -- designated types, but the provided bodies for these operations | |
323 | -- a remote call to an actual target object potentially located on | |
324 | -- another partition; each value of the stub type encapsulates a | |
325 | -- reference to a remote object. | |
326 | ||
bd7f7a65 | 327 | Stub_Type_Access : Entity_Id; |
8aa23fe3 TQ |
328 | -- A local access type designating the stub type (this is not an RACW |
329 | -- type). | |
330 | ||
bd7f7a65 | 331 | RPC_Receiver_Decl : Node_Id; |
8aa23fe3 | 332 | -- Declaration for the RPC receiver entity associated with the |
a3068ca6 AC |
333 | -- designated type. As an exception, in the case of GARLIC, for an RACW |
334 | -- that implements a RAS, no object RPC receiver is generated. Instead, | |
8aa23fe3 TQ |
335 | -- RPC_Receiver_Decl is the declaration after which the RPC receiver |
336 | -- would have been inserted. | |
337 | ||
338 | Body_Decls : List_Id; | |
339 | -- List of subprogram bodies to be included in generated code: bodies | |
340 | -- for the RACW's stream attributes, and for the primitive operations | |
341 | -- of the stub type. | |
342 | ||
bd7f7a65 | 343 | RACW_Type : Entity_Id; |
8aa23fe3 TQ |
344 | -- One of the RACW types designating this distributed object type |
345 | -- (they are all interchangeable; we use any one of them in order to | |
346 | -- avoid having to create various anonymous access types). | |
347 | ||
70482933 | 348 | end record; |
70482933 RK |
349 | |
350 | Empty_Stub_Structure : constant Stub_Structure := | |
8aa23fe3 | 351 | (Empty, Empty, Empty, No_List, Empty); |
70482933 RK |
352 | |
353 | package Stubs_Table is | |
354 | new Simple_HTable (Header_Num => Hash_Index, | |
355 | Element => Stub_Structure, | |
356 | No_Element => Empty_Stub_Structure, | |
357 | Key => Entity_Id, | |
358 | Hash => Hash, | |
359 | Equal => "="); | |
360 | -- Mapping between a RACW designated type and its stub type | |
361 | ||
362 | package Asynchronous_Flags_Table is | |
363 | new Simple_HTable (Header_Num => Hash_Index, | |
5885facb | 364 | Element => Entity_Id, |
70482933 RK |
365 | No_Element => Empty, |
366 | Key => Entity_Id, | |
367 | Hash => Hash, | |
368 | Equal => "="); | |
5885facb TQ |
369 | -- Mapping between a RACW type and a constant having the value True |
370 | -- if the RACW is asynchronous and False otherwise. | |
70482933 RK |
371 | |
372 | package RCI_Locator_Table is | |
373 | new Simple_HTable (Header_Num => Hash_Index, | |
374 | Element => Entity_Id, | |
375 | No_Element => Empty, | |
376 | Key => Entity_Id, | |
377 | Hash => Hash, | |
378 | Equal => "="); | |
379 | -- Mapping between a RCI package on which All_Calls_Remote applies and | |
48ab1182 | 380 | -- the generic instantiation of RCI_Locator for this package. |
70482933 RK |
381 | |
382 | package RCI_Calling_Stubs_Table is | |
383 | new Simple_HTable (Header_Num => Hash_Index, | |
384 | Element => Entity_Id, | |
385 | No_Element => Empty, | |
386 | Key => Entity_Id, | |
387 | Hash => Hash, | |
388 | Equal => "="); | |
389 | -- Mapping between a RCI subprogram and the corresponding calling stubs | |
390 | ||
d693e39d TQ |
391 | function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure; |
392 | -- Return the stub information associated with the given RACW type | |
393 | ||
70482933 | 394 | procedure Add_Stub_Type |
82c80734 | 395 | (Designated_Type : Entity_Id; |
bd7f7a65 AC |
396 | RACW_Type : Entity_Id; |
397 | Decls : List_Id; | |
398 | Stub_Type : out Entity_Id; | |
399 | Stub_Type_Access : out Entity_Id; | |
400 | RPC_Receiver_Decl : out Node_Id; | |
8aa23fe3 | 401 | Body_Decls : out List_Id; |
bd7f7a65 | 402 | Existing : out Boolean); |
70482933 RK |
403 | -- Add the declaration of the stub type, the access to stub type and the |
404 | -- object RPC receiver at the end of Decls. If these already exist, | |
405 | -- then nothing is added in the tree but the right values are returned | |
406 | -- anyhow and Existing is set to True. | |
407 | ||
8aa23fe3 TQ |
408 | function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id; |
409 | -- Retrieve the Body_Decls list associated to RACW_Type in the stub | |
410 | -- structure table, reset it to No_List, and return the previous value. | |
411 | ||
5885facb TQ |
412 | procedure Add_RACW_Asynchronous_Flag |
413 | (Declarations : List_Id; | |
414 | RACW_Type : Entity_Id); | |
415 | -- Declare a boolean constant associated with RACW_Type whose value | |
416 | -- indicates at run time whether a pragma Asynchronous applies to it. | |
417 | ||
1735e55d AC |
418 | procedure Assign_Subprogram_Identifier |
419 | (Def : Entity_Id; | |
420 | Spn : Int; | |
421 | Id : out String_Id); | |
422 | -- Determine the distribution subprogram identifier to | |
423 | -- be used for remote subprogram Def, return it in Id and | |
424 | -- store it in a hash table for later retrieval by | |
425 | -- Get_Subprogram_Id. Spn is the subprogram number. | |
70482933 RK |
426 | |
427 | function RCI_Package_Locator | |
428 | (Loc : Source_Ptr; | |
c885d7a1 | 429 | Package_Spec : Node_Id) return Node_Id; |
48ab1182 | 430 | -- Instantiate the generic package RCI_Locator in order to locate the |
70482933 RK |
431 | -- RCI package whose spec is given as argument. |
432 | ||
433 | function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id; | |
434 | -- Surround a node N by a tag check, as in: | |
435 | -- begin | |
436 | -- <N>; | |
437 | -- exception | |
438 | -- when E : Ada.Tags.Tag_Error => | |
439 | -- Raise_Exception (Program_Error'Identity, | |
440 | -- Exception_Message (E)); | |
441 | -- end; | |
442 | ||
443 | function Input_With_Tag_Check | |
444 | (Loc : Source_Ptr; | |
445 | Var_Type : Entity_Id; | |
16db96c5 | 446 | Stream : Node_Id) return Node_Id; |
70482933 RK |
447 | -- Return a function with the following form: |
448 | -- function R return Var_Type is | |
449 | -- begin | |
450 | -- return Var_Type'Input (S); | |
451 | -- exception | |
452 | -- when E : Ada.Tags.Tag_Error => | |
453 | -- Raise_Exception (Program_Error'Identity, | |
454 | -- Exception_Message (E)); | |
455 | -- end R; | |
456 | ||
8aa23fe3 TQ |
457 | procedure Build_Actual_Object_Declaration |
458 | (Object : Entity_Id; | |
459 | Etyp : Entity_Id; | |
460 | Variable : Boolean; | |
461 | Expr : Node_Id; | |
462 | Decls : List_Id); | |
463 | -- Build the declaration of an object with the given defining identifier, | |
464 | -- initialized with Expr if provided, to serve as actual parameter in a | |
465 | -- server stub. If Variable is true, the declared object will be a variable | |
466 | -- (case of an out or in out formal), else it will be a constant. Object's | |
467 | -- Ekind is set accordingly. The declaration, as well as any other | |
468 | -- declarations it requires, are appended to Decls. | |
469 | ||
1735e55d AC |
470 | -------------------------------------------- |
471 | -- Hooks for PCS-specific code generation -- | |
472 | -------------------------------------------- | |
473 | ||
474 | -- Part of the code generation circuitry for distribution needs to be | |
475 | -- tailored for each implementation of the PCS. For each routine that | |
476 | -- needs to be specialized, a Specific_<routine> wrapper is created, | |
477 | -- which calls the corresponding <routine> in package | |
478 | -- <pcs_implementation>_Support. | |
479 | ||
480 | procedure Specific_Add_RACW_Features | |
481 | (RACW_Type : Entity_Id; | |
482 | Desig : Entity_Id; | |
483 | Stub_Type : Entity_Id; | |
484 | Stub_Type_Access : Entity_Id; | |
485 | RPC_Receiver_Decl : Node_Id; | |
8aa23fe3 | 486 | Body_Decls : List_Id); |
1735e55d | 487 | -- Add declaration for TSSs for a given RACW type. The declarations are |
7f0b5314 TQ |
488 | -- added just after the declaration of the RACW type itself. If the RACW |
489 | -- appears in the main unit, Body_Decls is a list of declarations to which | |
490 | -- the bodies are appended. Else Body_Decls is No_List. | |
491 | -- PCS-specific ancillary subprogram for Add_RACW_Features. | |
1735e55d AC |
492 | |
493 | procedure Specific_Add_RAST_Features | |
494 | (Vis_Decl : Node_Id; | |
c857f5ed TQ |
495 | RAS_Type : Entity_Id); |
496 | -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary | |
1735e55d AC |
497 | -- subprogram for Add_RAST_Features. |
498 | ||
bd7f7a65 AC |
499 | -- An RPC_Target record is used during construction of calling stubs |
500 | -- to pass PCS-specific tree fragments corresponding to the information | |
501 | -- necessary to locate the target of a remote subprogram call. | |
502 | ||
503 | type RPC_Target (PCS_Kind : PCS_Names) is record | |
504 | case PCS_Kind is | |
505 | when Name_PolyORB_DSA => | |
bfc2cdb1 | 506 | Object : Node_Id; |
bd7f7a65 AC |
507 | -- An expression whose value is a PolyORB reference to the target |
508 | -- object. | |
bfc2cdb1 | 509 | |
d8f43ee6 | 510 | when others => |
bfc2cdb1 | 511 | Partition : Entity_Id; |
8fc789c8 | 512 | -- A variable containing the Partition_ID of the target partition |
bd7f7a65 AC |
513 | |
514 | RPC_Receiver : Node_Id; | |
515 | -- An expression whose value is the address of the target RPC | |
516 | -- receiver. | |
517 | end case; | |
518 | end record; | |
519 | ||
520 | procedure Specific_Build_General_Calling_Stubs | |
521 | (Decls : List_Id; | |
522 | Statements : List_Id; | |
523 | Target : RPC_Target; | |
524 | Subprogram_Id : Node_Id; | |
525 | Asynchronous : Node_Id := Empty; | |
526 | Is_Known_Asynchronous : Boolean := False; | |
527 | Is_Known_Non_Asynchronous : Boolean := False; | |
528 | Is_Function : Boolean; | |
529 | Spec : Node_Id; | |
530 | Stub_Type : Entity_Id := Empty; | |
531 | RACW_Type : Entity_Id := Empty; | |
532 | Nod : Node_Id); | |
533 | -- Build calling stubs for general purpose. The parameters are: | |
d18bbd25 AC |
534 | -- Decls : A place to put declarations |
535 | -- Statements : A place to put statements | |
536 | -- Target : PCS-specific target information (see details in | |
537 | -- RPC_Target declaration). | |
538 | -- Subprogram_Id : A node containing the subprogram ID | |
bd7f7a65 AC |
539 | -- Asynchronous : True if an APC must be made instead of an RPC. |
540 | -- The value needs not be supplied if one of the | |
541 | -- Is_Known_... is True. | |
542 | -- Is_Known_Async... : True if we know that this is asynchronous | |
543 | -- Is_Known_Non_A... : True if we know that this is not asynchronous | |
d18bbd25 AC |
544 | -- Spec : Node with a Parameter_Specifications and a |
545 | -- Result_Definition if applicable | |
546 | -- Stub_Type : For case of RACW stubs, parameters of type access | |
547 | -- to Stub_Type will be marshalled using the address | |
bd7f7a65 AC |
548 | -- address of the object (the addr field) rather |
549 | -- than using the 'Write on the stub itself | |
d18bbd25 | 550 | -- Nod : Used to provide sloc for generated code |
bd7f7a65 AC |
551 | |
552 | function Specific_Build_Stub_Target | |
553 | (Loc : Source_Ptr; | |
554 | Decls : List_Id; | |
555 | RCI_Locator : Entity_Id; | |
556 | Controlling_Parameter : Entity_Id) return RPC_Target; | |
557 | -- Build call target information nodes for use within calling stubs. In the | |
558 | -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If | |
559 | -- for an RACW, Controlling_Parameter is the entity for the controlling | |
560 | -- formal parameter used to determine the location of the target of the | |
561 | -- call. Decls provides a location where variable declarations can be | |
562 | -- appended to construct the necessary values. | |
563 | ||
a3068ca6 AC |
564 | function Specific_RPC_Receiver_Decl |
565 | (RACW_Type : Entity_Id) return Node_Id; | |
566 | -- Build the RPC receiver, for RACW, if applicable, else return Empty | |
bd7f7a65 | 567 | |
16db96c5 AC |
568 | procedure Specific_Build_RPC_Receiver_Body |
569 | (RPC_Receiver : Entity_Id; | |
570 | Request : out Entity_Id; | |
571 | Subp_Id : out Entity_Id; | |
572 | Subp_Index : out Entity_Id; | |
573 | Stmts : out List_Id; | |
574 | Decl : out Node_Id); | |
575 | -- Make a subprogram body for an RPC receiver, with the given | |
576 | -- defining unit name. On return: | |
577 | -- - Subp_Id is the subprogram identifier from the PCS. | |
578 | -- - Subp_Index is the index in the list of subprograms | |
579 | -- used for dispatching (a variable of type Subprogram_Id). | |
580 | -- - Stmts is the place where the request dispatching | |
581 | -- statements can occur, | |
582 | -- - Decl is the subprogram body declaration. | |
583 | ||
584 | function Specific_Build_Subprogram_Receiving_Stubs | |
585 | (Vis_Decl : Node_Id; | |
586 | Asynchronous : Boolean; | |
587 | Dynamically_Asynchronous : Boolean := False; | |
588 | Stub_Type : Entity_Id := Empty; | |
589 | RACW_Type : Entity_Id := Empty; | |
590 | Parent_Primitive : Entity_Id := Empty) return Node_Id; | |
591 | -- Build the receiving stub for a given subprogram. The subprogram | |
592 | -- declaration is also built by this procedure, and the value returned | |
593 | -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is | |
594 | -- found in the specification, then its address is read from the stream | |
595 | -- instead of the object itself and converted into an access to | |
596 | -- class-wide type before doing the real call using any of the RACW type | |
597 | -- pointing on the designated type. | |
598 | ||
82c80734 RD |
599 | procedure Specific_Add_Obj_RPC_Receiver_Completion |
600 | (Loc : Source_Ptr; | |
601 | Decls : List_Id; | |
602 | RPC_Receiver : Entity_Id; | |
603 | Stub_Elements : Stub_Structure); | |
604 | -- Add the necessary code to Decls after the completion of generation | |
605 | -- of the RACW RPC receiver described by Stub_Elements. | |
606 | ||
16db96c5 AC |
607 | procedure Specific_Add_Receiving_Stubs_To_Declarations |
608 | (Pkg_Spec : Node_Id; | |
8aa23fe3 TQ |
609 | Decls : List_Id; |
610 | Stmts : List_Id); | |
82c80734 | 611 | -- Add receiving stubs to the declarative part of an RCI unit |
16db96c5 | 612 | |
c6f39437 AC |
613 | -------------------- |
614 | -- GARLIC_Support -- | |
615 | -------------------- | |
616 | ||
1735e55d AC |
617 | package GARLIC_Support is |
618 | ||
619 | -- Support for generating DSA code that uses the GARLIC PCS | |
620 | ||
bfc2cdb1 TQ |
621 | -- The subprograms below provide the GARLIC versions of the |
622 | -- corresponding Specific_<subprogram> routine declared above. | |
bd7f7a65 | 623 | |
1735e55d AC |
624 | procedure Add_RACW_Features |
625 | (RACW_Type : Entity_Id; | |
626 | Stub_Type : Entity_Id; | |
627 | Stub_Type_Access : Entity_Id; | |
628 | RPC_Receiver_Decl : Node_Id; | |
8aa23fe3 | 629 | Body_Decls : List_Id); |
1735e55d AC |
630 | |
631 | procedure Add_RAST_Features | |
632 | (Vis_Decl : Node_Id; | |
c857f5ed | 633 | RAS_Type : Entity_Id); |
1735e55d | 634 | |
bd7f7a65 AC |
635 | procedure Build_General_Calling_Stubs |
636 | (Decls : List_Id; | |
637 | Statements : List_Id; | |
638 | Target_Partition : Entity_Id; -- From RPC_Target | |
639 | Target_RPC_Receiver : Node_Id; -- From RPC_Target | |
640 | Subprogram_Id : Node_Id; | |
641 | Asynchronous : Node_Id := Empty; | |
642 | Is_Known_Asynchronous : Boolean := False; | |
643 | Is_Known_Non_Asynchronous : Boolean := False; | |
644 | Is_Function : Boolean; | |
645 | Spec : Node_Id; | |
646 | Stub_Type : Entity_Id := Empty; | |
647 | RACW_Type : Entity_Id := Empty; | |
648 | Nod : Node_Id); | |
649 | ||
650 | function Build_Stub_Target | |
651 | (Loc : Source_Ptr; | |
652 | Decls : List_Id; | |
653 | RCI_Locator : Entity_Id; | |
654 | Controlling_Parameter : Entity_Id) return RPC_Target; | |
655 | ||
a3068ca6 | 656 | function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id; |
bd7f7a65 | 657 | |
16db96c5 AC |
658 | function Build_Subprogram_Receiving_Stubs |
659 | (Vis_Decl : Node_Id; | |
660 | Asynchronous : Boolean; | |
661 | Dynamically_Asynchronous : Boolean := False; | |
662 | Stub_Type : Entity_Id := Empty; | |
663 | RACW_Type : Entity_Id := Empty; | |
664 | Parent_Primitive : Entity_Id := Empty) return Node_Id; | |
665 | ||
82c80734 RD |
666 | procedure Add_Obj_RPC_Receiver_Completion |
667 | (Loc : Source_Ptr; | |
668 | Decls : List_Id; | |
669 | RPC_Receiver : Entity_Id; | |
670 | Stub_Elements : Stub_Structure); | |
671 | ||
16db96c5 AC |
672 | procedure Add_Receiving_Stubs_To_Declarations |
673 | (Pkg_Spec : Node_Id; | |
8aa23fe3 TQ |
674 | Decls : List_Id; |
675 | Stmts : List_Id); | |
16db96c5 AC |
676 | |
677 | procedure Build_RPC_Receiver_Body | |
678 | (RPC_Receiver : Entity_Id; | |
679 | Request : out Entity_Id; | |
680 | Subp_Id : out Entity_Id; | |
681 | Subp_Index : out Entity_Id; | |
682 | Stmts : out List_Id; | |
683 | Decl : out Node_Id); | |
bd7f7a65 | 684 | |
1735e55d AC |
685 | end GARLIC_Support; |
686 | ||
c6f39437 AC |
687 | --------------------- |
688 | -- PolyORB_Support -- | |
689 | --------------------- | |
690 | ||
1735e55d AC |
691 | package PolyORB_Support is |
692 | ||
693 | -- Support for generating DSA code that uses the PolyORB PCS | |
694 | ||
bfc2cdb1 TQ |
695 | -- The subprograms below provide the PolyORB versions of the |
696 | -- corresponding Specific_<subprogram> routine declared above. | |
bd7f7a65 | 697 | |
1735e55d AC |
698 | procedure Add_RACW_Features |
699 | (RACW_Type : Entity_Id; | |
700 | Desig : Entity_Id; | |
701 | Stub_Type : Entity_Id; | |
702 | Stub_Type_Access : Entity_Id; | |
703 | RPC_Receiver_Decl : Node_Id; | |
8aa23fe3 | 704 | Body_Decls : List_Id); |
1735e55d AC |
705 | |
706 | procedure Add_RAST_Features | |
707 | (Vis_Decl : Node_Id; | |
c857f5ed | 708 | RAS_Type : Entity_Id); |
1735e55d | 709 | |
bd7f7a65 AC |
710 | procedure Build_General_Calling_Stubs |
711 | (Decls : List_Id; | |
712 | Statements : List_Id; | |
713 | Target_Object : Node_Id; -- From RPC_Target | |
714 | Subprogram_Id : Node_Id; | |
715 | Asynchronous : Node_Id := Empty; | |
716 | Is_Known_Asynchronous : Boolean := False; | |
717 | Is_Known_Non_Asynchronous : Boolean := False; | |
718 | Is_Function : Boolean; | |
719 | Spec : Node_Id; | |
720 | Stub_Type : Entity_Id := Empty; | |
721 | RACW_Type : Entity_Id := Empty; | |
722 | Nod : Node_Id); | |
723 | ||
724 | function Build_Stub_Target | |
725 | (Loc : Source_Ptr; | |
726 | Decls : List_Id; | |
727 | RCI_Locator : Entity_Id; | |
728 | Controlling_Parameter : Entity_Id) return RPC_Target; | |
729 | ||
a3068ca6 | 730 | function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id; |
bd7f7a65 | 731 | |
16db96c5 AC |
732 | function Build_Subprogram_Receiving_Stubs |
733 | (Vis_Decl : Node_Id; | |
734 | Asynchronous : Boolean; | |
735 | Dynamically_Asynchronous : Boolean := False; | |
736 | Stub_Type : Entity_Id := Empty; | |
737 | RACW_Type : Entity_Id := Empty; | |
738 | Parent_Primitive : Entity_Id := Empty) return Node_Id; | |
739 | ||
82c80734 RD |
740 | procedure Add_Obj_RPC_Receiver_Completion |
741 | (Loc : Source_Ptr; | |
742 | Decls : List_Id; | |
743 | RPC_Receiver : Entity_Id; | |
744 | Stub_Elements : Stub_Structure); | |
745 | ||
16db96c5 AC |
746 | procedure Add_Receiving_Stubs_To_Declarations |
747 | (Pkg_Spec : Node_Id; | |
8aa23fe3 TQ |
748 | Decls : List_Id; |
749 | Stmts : List_Id); | |
bd7f7a65 | 750 | |
16db96c5 AC |
751 | procedure Build_RPC_Receiver_Body |
752 | (RPC_Receiver : Entity_Id; | |
753 | Request : out Entity_Id; | |
754 | Subp_Id : out Entity_Id; | |
755 | Subp_Index : out Entity_Id; | |
756 | Stmts : out List_Id; | |
757 | Decl : out Node_Id); | |
758 | ||
759 | procedure Reserve_NamingContext_Methods; | |
760 | -- Mark the method names for interface NamingContext as already used in | |
761 | -- the overload table, so no clashes occur with user code (with the | |
762 | -- PolyORB PCS, RCIs Implement The NamingContext interface to allow | |
763 | -- their methods to be accessed as objects, for the implementation of | |
764 | -- remote access-to-subprogram types). | |
bd7f7a65 | 765 | |
c6f39437 AC |
766 | ------------- |
767 | -- Helpers -- | |
768 | ------------- | |
769 | ||
bd7f7a65 AC |
770 | package Helpers is |
771 | ||
8fc789c8 | 772 | -- Routines to build distribution helper subprograms for user-defined |
bd7f7a65 AC |
773 | -- types. For implementation of the Distributed systems annex (DSA) |
774 | -- over the PolyORB generic middleware components, it is necessary to | |
775 | -- generate several supporting subprograms for each application data | |
776 | -- type used in inter-partition communication. These subprograms are: | |
bfc2cdb1 TQ |
777 | |
778 | -- A Typecode function returning a high-level description of the | |
779 | -- type's structure; | |
780 | ||
781 | -- Two conversion functions allowing conversion of values of the | |
782 | -- type from and to the generic data containers used by PolyORB. | |
783 | -- These generic containers are called 'Any' type values after the | |
784 | -- CORBA terminology, and hence the conversion subprograms are | |
785 | -- named To_Any and From_Any. | |
bd7f7a65 | 786 | |
bd7f7a65 AC |
787 | function Build_From_Any_Call |
788 | (Typ : Entity_Id; | |
789 | N : Node_Id; | |
790 | Decls : List_Id) return Node_Id; | |
791 | -- Build call to From_Any attribute function of type Typ with | |
792 | -- expression N as actual parameter. Decls is the declarations list | |
793 | -- for an appropriate enclosing scope of the point where the call | |
794 | -- will be inserted; if the From_Any attribute for Typ needs to be | |
795 | -- generated at this point, its declaration is appended to Decls. | |
796 | ||
797 | procedure Build_From_Any_Function | |
798 | (Loc : Source_Ptr; | |
799 | Typ : Entity_Id; | |
800 | Decl : out Node_Id; | |
801 | Fnam : out Entity_Id); | |
802 | -- Build From_Any attribute function for Typ. Loc is the reference | |
803 | -- location for generated nodes, Typ is the type for which the | |
804 | -- conversion function is generated. On return, Decl and Fnam contain | |
805 | -- the declaration and entity for the newly-created function. | |
806 | ||
807 | function Build_To_Any_Call | |
8b64ed4c TQ |
808 | (Loc : Source_Ptr; |
809 | N : Node_Id; | |
810 | Decls : List_Id; | |
811 | Constrained : Boolean := False) return Node_Id; | |
bd7f7a65 | 812 | -- Build call to To_Any attribute function with expression as actual |
8b64ed4c | 813 | -- parameter. Loc is the reference location of generated nodes, |
30ebb114 AC |
814 | -- Decls is the declarations list for an appropriate enclosing scope |
815 | -- of the point where the call will be inserted; if the To_Any | |
816 | -- attribute for the type of N needs to be generated at this point, | |
8b64ed4c TQ |
817 | -- its declaration is appended to Decls. For the case of a limited |
818 | -- type, there is an additional parameter Constrained indicating | |
819 | -- whether 'Write (when True) or 'Output (when False) is used. | |
bd7f7a65 AC |
820 | |
821 | procedure Build_To_Any_Function | |
822 | (Loc : Source_Ptr; | |
823 | Typ : Entity_Id; | |
824 | Decl : out Node_Id; | |
825 | Fnam : out Entity_Id); | |
826 | -- Build To_Any attribute function for Typ. Loc is the reference | |
827 | -- location for generated nodes, Typ is the type for which the | |
828 | -- conversion function is generated. On return, Decl and Fnam contain | |
829 | -- the declaration and entity for the newly-created function. | |
830 | ||
831 | function Build_TypeCode_Call | |
832 | (Loc : Source_Ptr; | |
833 | Typ : Entity_Id; | |
834 | Decls : List_Id) return Node_Id; | |
835 | -- Build call to TypeCode attribute function for Typ. Decls is the | |
836 | -- declarations list for an appropriate enclosing scope of the point | |
837 | -- where the call will be inserted; if the To_Any attribute for Typ | |
838 | -- needs to be generated at this point, its declaration is appended | |
839 | -- to Decls. | |
840 | ||
841 | procedure Build_TypeCode_Function | |
842 | (Loc : Source_Ptr; | |
843 | Typ : Entity_Id; | |
844 | Decl : out Node_Id; | |
845 | Fnam : out Entity_Id); | |
846 | -- Build TypeCode attribute function for Typ. Loc is the reference | |
847 | -- location for generated nodes, Typ is the type for which the | |
baad9830 | 848 | -- typecode function is generated. On return, Decl and Fnam contain |
bd7f7a65 AC |
849 | -- the declaration and entity for the newly-created function. |
850 | ||
851 | procedure Build_Name_And_Repository_Id | |
852 | (E : Entity_Id; | |
853 | Name_Str : out String_Id; | |
854 | Repo_Id_Str : out String_Id); | |
855 | -- In the PolyORB distribution model, each distributed object type | |
856 | -- and each distributed operation has a globally unique identifier, | |
857 | -- its Repository Id. This subprogram builds and returns two strings | |
858 | -- for entity E (a distributed object type or operation): one | |
859 | -- containing the name of E, the second containing its repository id. | |
860 | ||
72a3d7c7 | 861 | procedure Assign_Opaque_From_Any |
8b64ed4c TQ |
862 | (Loc : Source_Ptr; |
863 | Stms : List_Id; | |
864 | Typ : Entity_Id; | |
865 | N : Node_Id; | |
866 | Target : Entity_Id; | |
867 | Constrained : Boolean := False); | |
72a3d7c7 AC |
868 | -- For a Target object of type Typ, which has opaque representation |
869 | -- as a sequence of octets determined by stream attributes (which | |
870 | -- includes all limited types), append code to Stmts performing the | |
871 | -- equivalent of: | |
872 | -- Target := Typ'From_Any (N) | |
959dd7d8 | 873 | -- |
72a3d7c7 AC |
874 | -- or, if Target is Empty: |
875 | -- return Typ'From_Any (N) | |
8b64ed4c TQ |
876 | -- |
877 | -- Constrained determines whether 'Input (when False) or 'Read | |
878 | -- (when True) is used. | |
72a3d7c7 | 879 | |
bd7f7a65 AC |
880 | end Helpers; |
881 | ||
1735e55d AC |
882 | end PolyORB_Support; |
883 | ||
54838d1f AC |
884 | -- The following PolyORB-specific subprograms are made visible to Exp_Attr: |
885 | ||
886 | function Build_From_Any_Call | |
887 | (Typ : Entity_Id; | |
888 | N : Node_Id; | |
889 | Decls : List_Id) return Node_Id | |
890 | renames PolyORB_Support.Helpers.Build_From_Any_Call; | |
891 | ||
892 | function Build_To_Any_Call | |
8b64ed4c TQ |
893 | (Loc : Source_Ptr; |
894 | N : Node_Id; | |
895 | Decls : List_Id; | |
896 | Constrained : Boolean := False) return Node_Id | |
54838d1f AC |
897 | renames PolyORB_Support.Helpers.Build_To_Any_Call; |
898 | ||
899 | function Build_TypeCode_Call | |
900 | (Loc : Source_Ptr; | |
901 | Typ : Entity_Id; | |
902 | Decls : List_Id) return Node_Id | |
903 | renames PolyORB_Support.Helpers.Build_TypeCode_Call; | |
904 | ||
70482933 RK |
905 | ------------------------------------ |
906 | -- Local variables and structures -- | |
907 | ------------------------------------ | |
908 | ||
b514643c | 909 | RCI_Cache : Node_Id := Empty; |
1735e55d | 910 | -- Needs comments ??? |
70482933 RK |
911 | |
912 | Output_From_Constrained : constant array (Boolean) of Name_Id := | |
913 | (False => Name_Output, | |
914 | True => Name_Write); | |
915 | -- The attribute to choose depending on the fact that the parameter | |
916 | -- is constrained or not. There is no such thing as Input_From_Constrained | |
917 | -- since this require separate mechanisms ('Input is a function while | |
918 | -- 'Read is a procedure). | |
919 | ||
ff2efe85 AC |
920 | generic |
921 | with procedure Process_Subprogram_Declaration (Decl : Node_Id); | |
922 | -- Generate calling or receiving stub for this subprogram declaration | |
923 | ||
924 | procedure Build_Package_Stubs (Pkg_Spec : Node_Id); | |
925 | -- Recursively visit the given RCI Package_Specification, calling | |
926 | -- Process_Subprogram_Declaration for each remote subprogram. | |
927 | ||
928 | ------------------------- | |
929 | -- Build_Package_Stubs -- | |
930 | ------------------------- | |
931 | ||
932 | procedure Build_Package_Stubs (Pkg_Spec : Node_Id) is | |
933 | Decls : constant List_Id := Visible_Declarations (Pkg_Spec); | |
934 | Decl : Node_Id; | |
935 | ||
936 | procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id); | |
937 | -- Recurse for the given nested package declaration | |
938 | ||
8016e567 PT |
939 | ---------------------- |
940 | -- Visit_Nested_Pkg -- | |
941 | ---------------------- | |
ff2efe85 AC |
942 | |
943 | procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id) is | |
944 | Nested_Pkg_Spec : constant Node_Id := Specification (Nested_Pkg_Decl); | |
945 | begin | |
946 | Push_Scope (Scope_Of_Spec (Nested_Pkg_Spec)); | |
947 | Build_Package_Stubs (Nested_Pkg_Spec); | |
948 | Pop_Scope; | |
949 | end Visit_Nested_Pkg; | |
950 | ||
951 | -- Start of processing for Build_Package_Stubs | |
952 | ||
953 | begin | |
954 | Decl := First (Decls); | |
955 | while Present (Decl) loop | |
956 | case Nkind (Decl) is | |
957 | when N_Subprogram_Declaration => | |
958 | ||
959 | -- Note: we test Comes_From_Source on Spec, not Decl, because | |
960 | -- in the case of a subprogram instance, only the specification | |
961 | -- (not the declaration) is marked as coming from source. | |
962 | ||
963 | if Comes_From_Source (Specification (Decl)) then | |
964 | Process_Subprogram_Declaration (Decl); | |
965 | end if; | |
966 | ||
967 | when N_Package_Declaration => | |
968 | ||
969 | -- Case of a nested package or package instantiation coming | |
27b2fbc9 EB |
970 | -- from source, including the wrapper package for an instance |
971 | -- of a generic subprogram. | |
ff2efe85 AC |
972 | |
973 | declare | |
974 | Pkg_Ent : constant Entity_Id := | |
975 | Defining_Unit_Name (Specification (Decl)); | |
976 | begin | |
977 | if Comes_From_Source (Decl) | |
978 | or else | |
979 | (Is_Generic_Instance (Pkg_Ent) | |
980 | and then Comes_From_Source | |
ed323421 | 981 | (Get_Unit_Instantiation_Node (Pkg_Ent))) |
ff2efe85 AC |
982 | then |
983 | Visit_Nested_Pkg (Decl); | |
984 | end if; | |
985 | end; | |
986 | ||
ff2efe85 AC |
987 | when others => |
988 | null; | |
989 | end case; | |
d8f43ee6 | 990 | |
ff2efe85 AC |
991 | Next (Decl); |
992 | end loop; | |
993 | end Build_Package_Stubs; | |
994 | ||
70482933 RK |
995 | --------------------------------------- |
996 | -- Add_Calling_Stubs_To_Declarations -- | |
997 | --------------------------------------- | |
998 | ||
ff2efe85 AC |
999 | procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id) is |
1000 | Loc : constant Source_Ptr := Sloc (Pkg_Spec); | |
1001 | ||
c885d7a1 AC |
1002 | Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; |
1003 | -- Subprogram id 0 is reserved for calls received from | |
1004 | -- remote access-to-subprogram dereferences. | |
70482933 | 1005 | |
f2acf80c | 1006 | RCI_Instantiation : Node_Id; |
70482933 | 1007 | |
ff2efe85 AC |
1008 | procedure Visit_Subprogram (Decl : Node_Id); |
1009 | -- Generate calling stub for one remote subprogram | |
1010 | ||
1011 | ---------------------- | |
1012 | -- Visit_Subprogram -- | |
1013 | ---------------------- | |
1014 | ||
1015 | procedure Visit_Subprogram (Decl : Node_Id) is | |
1016 | Loc : constant Source_Ptr := Sloc (Decl); | |
1017 | Spec : constant Node_Id := Specification (Decl); | |
1018 | Subp_Stubs : Node_Id; | |
f2acf80c AC |
1019 | |
1020 | Subp_Str : String_Id; | |
ff2efe85 AC |
1021 | pragma Warnings (Off, Subp_Str); |
1022 | ||
1023 | begin | |
9fde638d RD |
1024 | -- Disable expansion of stubs if serious errors have been diagnosed, |
1025 | -- because otherwise some illegal remote subprogram declarations | |
1026 | -- could cause cascaded errors in stubs. | |
1027 | ||
170b2989 AC |
1028 | if Serious_Errors_Detected /= 0 then |
1029 | return; | |
1030 | end if; | |
1031 | ||
ff2efe85 AC |
1032 | Assign_Subprogram_Identifier |
1033 | (Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str); | |
1034 | ||
1035 | Subp_Stubs := | |
f2acf80c AC |
1036 | Build_Subprogram_Calling_Stubs |
1037 | (Vis_Decl => Decl, | |
1038 | Subp_Id => | |
1039 | Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)), | |
1040 | Asynchronous => | |
1041 | Nkind (Spec) = N_Procedure_Specification | |
1042 | and then Is_Asynchronous (Defining_Unit_Name (Spec))); | |
ff2efe85 AC |
1043 | |
1044 | Append_To (List_Containing (Decl), Subp_Stubs); | |
1045 | Analyze (Subp_Stubs); | |
1046 | ||
1047 | Current_Subprogram_Number := Current_Subprogram_Number + 1; | |
1048 | end Visit_Subprogram; | |
1049 | ||
1050 | procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); | |
1051 | ||
1052 | -- Start of processing for Add_Calling_Stubs_To_Declarations | |
2cd6f54e | 1053 | |
70482933 | 1054 | begin |
ff2efe85 AC |
1055 | Push_Scope (Scope_Of_Spec (Pkg_Spec)); |
1056 | ||
70482933 | 1057 | -- The first thing added is an instantiation of the generic package |
bfc2cdb1 TQ |
1058 | -- System.Partition_Interface.RCI_Locator with the name of this remote |
1059 | -- package. This will act as an interface with the name server to | |
1060 | -- determine the Partition_ID and the RPC_Receiver for the receiver | |
1061 | -- of this package. | |
70482933 RK |
1062 | |
1063 | RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec); | |
1064 | RCI_Cache := Defining_Unit_Name (RCI_Instantiation); | |
1065 | ||
ff2efe85 | 1066 | Append_To (Visible_Declarations (Pkg_Spec), RCI_Instantiation); |
70482933 RK |
1067 | Analyze (RCI_Instantiation); |
1068 | ||
bfc2cdb1 TQ |
1069 | -- For each subprogram declaration visible in the spec, we do build a |
1070 | -- body. We also increment a counter to assign a different Subprogram_Id | |
f2acf80c | 1071 | -- to each subprogram. The receiving stubs processing uses the same |
bfc2cdb1 TQ |
1072 | -- mechanism and will thus assign the same Id and do the correct |
1073 | -- dispatching. | |
70482933 | 1074 | |
1735e55d | 1075 | Overload_Counter_Table.Reset; |
16db96c5 | 1076 | PolyORB_Support.Reserve_NamingContext_Methods; |
1735e55d | 1077 | |
ff2efe85 | 1078 | Visit_Spec (Pkg_Spec); |
c7532b2d | 1079 | |
ff2efe85 | 1080 | Pop_Scope; |
70482933 RK |
1081 | end Add_Calling_Stubs_To_Declarations; |
1082 | ||
bd7f7a65 AC |
1083 | ----------------------------- |
1084 | -- Add_Parameter_To_NVList -- | |
1085 | ----------------------------- | |
1086 | ||
1087 | function Add_Parameter_To_NVList | |
1088 | (Loc : Source_Ptr; | |
1089 | NVList : Entity_Id; | |
1090 | Parameter : Entity_Id; | |
1091 | Constrained : Boolean; | |
1092 | RACW_Ctrl : Boolean := False; | |
1093 | Any : Entity_Id) return Node_Id | |
1094 | is | |
1095 | Parameter_Name_String : String_Id; | |
1096 | Parameter_Mode : Node_Id; | |
1097 | ||
1098 | function Parameter_Passing_Mode | |
1099 | (Loc : Source_Ptr; | |
1100 | Parameter : Entity_Id; | |
1101 | Constrained : Boolean) return Node_Id; | |
2cd6f54e TQ |
1102 | -- Return an expression that denotes the parameter passing mode to be |
1103 | -- used for Parameter in distribution stubs, where Constrained is | |
1104 | -- Parameter's constrained status. | |
bd7f7a65 AC |
1105 | |
1106 | ---------------------------- | |
1107 | -- Parameter_Passing_Mode -- | |
1108 | ---------------------------- | |
1109 | ||
1110 | function Parameter_Passing_Mode | |
1111 | (Loc : Source_Ptr; | |
1112 | Parameter : Entity_Id; | |
1113 | Constrained : Boolean) return Node_Id | |
1114 | is | |
1115 | Lib_RE : RE_Id; | |
1116 | ||
1117 | begin | |
1118 | if Out_Present (Parameter) then | |
1119 | if In_Present (Parameter) | |
1120 | or else not Constrained | |
1121 | then | |
1122 | -- Unconstrained formals must be translated | |
1123 | -- to 'in' or 'inout', not 'out', because | |
1124 | -- they need to be constrained by the actual. | |
1125 | ||
1126 | Lib_RE := RE_Mode_Inout; | |
1127 | else | |
1128 | Lib_RE := RE_Mode_Out; | |
1129 | end if; | |
1130 | ||
1131 | else | |
1132 | Lib_RE := RE_Mode_In; | |
1133 | end if; | |
1134 | ||
1135 | return New_Occurrence_Of (RTE (Lib_RE), Loc); | |
1136 | end Parameter_Passing_Mode; | |
1137 | ||
1138 | -- Start of processing for Add_Parameter_To_NVList | |
1139 | ||
1140 | begin | |
1141 | if Nkind (Parameter) = N_Defining_Identifier then | |
1142 | Get_Name_String (Chars (Parameter)); | |
1143 | else | |
bfc2cdb1 | 1144 | Get_Name_String (Chars (Defining_Identifier (Parameter))); |
bd7f7a65 AC |
1145 | end if; |
1146 | ||
1147 | Parameter_Name_String := String_From_Name_Buffer; | |
1148 | ||
8aa23fe3 TQ |
1149 | if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then |
1150 | ||
1151 | -- When the parameter passed to Add_Parameter_To_NVList is an | |
1152 | -- Extra_Constrained parameter, Parameter is an N_Defining_ | |
1153 | -- Identifier, instead of a complete N_Parameter_Specification. | |
1154 | -- Thus, we explicitly set 'in' mode in this case. | |
1155 | ||
1156 | Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc); | |
1157 | ||
bd7f7a65 | 1158 | else |
bfc2cdb1 TQ |
1159 | Parameter_Mode := |
1160 | Parameter_Passing_Mode (Loc, Parameter, Constrained); | |
bd7f7a65 AC |
1161 | end if; |
1162 | ||
1163 | return | |
1164 | Make_Procedure_Call_Statement (Loc, | |
6782b1ef AC |
1165 | Name => |
1166 | New_Occurrence_Of (RTE (RE_NVList_Add_Item), Loc), | |
bd7f7a65 AC |
1167 | Parameter_Associations => New_List ( |
1168 | New_Occurrence_Of (NVList, Loc), | |
1169 | Make_Function_Call (Loc, | |
6782b1ef AC |
1170 | Name => |
1171 | New_Occurrence_Of (RTE (RE_To_PolyORB_String), Loc), | |
bd7f7a65 | 1172 | Parameter_Associations => New_List ( |
6782b1ef | 1173 | Make_String_Literal (Loc, Strval => Parameter_Name_String))), |
bd7f7a65 AC |
1174 | New_Occurrence_Of (Any, Loc), |
1175 | Parameter_Mode)); | |
1176 | end Add_Parameter_To_NVList; | |
1177 | ||
5885facb TQ |
1178 | -------------------------------- |
1179 | -- Add_RACW_Asynchronous_Flag -- | |
1180 | -------------------------------- | |
1181 | ||
1182 | procedure Add_RACW_Asynchronous_Flag | |
1183 | (Declarations : List_Id; | |
1184 | RACW_Type : Entity_Id) | |
1185 | is | |
1186 | Loc : constant Source_Ptr := Sloc (RACW_Type); | |
1187 | ||
1188 | Asynchronous_Flag : constant Entity_Id := | |
1189 | Make_Defining_Identifier (Loc, | |
1190 | New_External_Name (Chars (RACW_Type), 'A')); | |
1191 | ||
1192 | begin | |
1193 | -- Declare the asynchronous flag. This flag will be changed to True | |
1194 | -- whenever it is known that the RACW type is asynchronous. | |
1195 | ||
1196 | Append_To (Declarations, | |
1197 | Make_Object_Declaration (Loc, | |
1198 | Defining_Identifier => Asynchronous_Flag, | |
1199 | Constant_Present => True, | |
1200 | Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), | |
1201 | Expression => New_Occurrence_Of (Standard_False, Loc))); | |
1202 | ||
1203 | Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag); | |
1204 | end Add_RACW_Asynchronous_Flag; | |
1205 | ||
70482933 RK |
1206 | ----------------------- |
1207 | -- Add_RACW_Features -- | |
1208 | ----------------------- | |
1209 | ||
92869a7b TQ |
1210 | procedure Add_RACW_Features (RACW_Type : Entity_Id) is |
1211 | Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type)); | |
1212 | Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type); | |
8aa23fe3 TQ |
1213 | |
1214 | Pkg_Spec : Node_Id; | |
92869a7b | 1215 | Decls : List_Id; |
8aa23fe3 | 1216 | Body_Decls : List_Id; |
70482933 | 1217 | |
bd7f7a65 AC |
1218 | Stub_Type : Entity_Id; |
1219 | Stub_Type_Access : Entity_Id; | |
1220 | RPC_Receiver_Decl : Node_Id; | |
92869a7b TQ |
1221 | |
1222 | Existing : Boolean; | |
1223 | -- True when appropriate stubs have already been generated (this is the | |
1224 | -- case when another RACW with the same designated type has already been | |
25e9b6fe TQ |
1225 | -- encountered), in which case we reuse the previous stubs rather than |
1226 | -- generating new ones. | |
70482933 RK |
1227 | |
1228 | begin | |
1229 | if not Expander_Active then | |
1230 | return; | |
1231 | end if; | |
1232 | ||
8aa23fe3 TQ |
1233 | -- Mark the current package declaration as containing an RACW, so that |
1234 | -- the bodies for the calling stubs and the RACW stream subprograms | |
1235 | -- are attached to the tree when the corresponding body is encountered. | |
70482933 | 1236 | |
8aa23fe3 TQ |
1237 | Set_Has_RACW (Current_Scope); |
1238 | ||
1239 | -- Look for place to declare the RACW stub type and RACW operations | |
1240 | ||
1241 | Pkg_Spec := Empty; | |
92869a7b TQ |
1242 | |
1243 | if Same_Scope then | |
70482933 | 1244 | |
8aa23fe3 TQ |
1245 | -- Case of declaring the RACW in the same package as its designated |
1246 | -- type: we know that the designated type is a private type, so we | |
1247 | -- use the private declarations list. | |
1248 | ||
1249 | Pkg_Spec := Package_Specification_Of_Scope (Current_Scope); | |
70482933 | 1250 | |
8aa23fe3 TQ |
1251 | if Present (Private_Declarations (Pkg_Spec)) then |
1252 | Decls := Private_Declarations (Pkg_Spec); | |
1253 | else | |
1254 | Decls := Visible_Declarations (Pkg_Spec); | |
1255 | end if; | |
92869a7b TQ |
1256 | |
1257 | else | |
8aa23fe3 TQ |
1258 | -- Case of declaring the RACW in another package than its designated |
1259 | -- type: use the private declarations list if present; otherwise | |
1260 | -- use the visible declarations. | |
1261 | ||
92869a7b TQ |
1262 | Decls := List_Containing (Declaration_Node (RACW_Type)); |
1263 | ||
70482933 RK |
1264 | end if; |
1265 | ||
1266 | -- If we were unable to find the declarations, that means that the | |
92869a7b TQ |
1267 | -- completion of the type was missing. We can safely return and let the |
1268 | -- error be caught by the semantic analysis. | |
70482933 RK |
1269 | |
1270 | if No (Decls) then | |
1271 | return; | |
1272 | end if; | |
1273 | ||
1274 | Add_Stub_Type | |
1275 | (Designated_Type => Desig, | |
1276 | RACW_Type => RACW_Type, | |
1277 | Decls => Decls, | |
1278 | Stub_Type => Stub_Type, | |
1279 | Stub_Type_Access => Stub_Type_Access, | |
1735e55d | 1280 | RPC_Receiver_Decl => RPC_Receiver_Decl, |
8aa23fe3 | 1281 | Body_Decls => Body_Decls, |
70482933 RK |
1282 | Existing => Existing); |
1283 | ||
7f0b5314 TQ |
1284 | -- If this RACW is not in the main unit, do not generate primitive or |
1285 | -- TSS bodies. | |
1286 | ||
1287 | if not Entity_Is_In_Main_Unit (RACW_Type) then | |
1288 | Body_Decls := No_List; | |
1289 | end if; | |
1290 | ||
5885facb TQ |
1291 | Add_RACW_Asynchronous_Flag |
1292 | (Declarations => Decls, | |
1293 | RACW_Type => RACW_Type); | |
1294 | ||
1735e55d | 1295 | Specific_Add_RACW_Features |
70482933 | 1296 | (RACW_Type => RACW_Type, |
1735e55d | 1297 | Desig => Desig, |
70482933 RK |
1298 | Stub_Type => Stub_Type, |
1299 | Stub_Type_Access => Stub_Type_Access, | |
1735e55d | 1300 | RPC_Receiver_Decl => RPC_Receiver_Decl, |
8aa23fe3 | 1301 | Body_Decls => Body_Decls); |
70482933 | 1302 | |
25e9b6fe | 1303 | -- If we already have stubs for this designated type, nothing to do |
70482933 | 1304 | |
25e9b6fe TQ |
1305 | if Existing then |
1306 | return; | |
1307 | end if; | |
70482933 | 1308 | |
25e9b6fe | 1309 | if Is_Frozen (Desig) then |
92869a7b | 1310 | Validate_RACW_Primitives (RACW_Type); |
70482933 RK |
1311 | Add_RACW_Primitive_Declarations_And_Bodies |
1312 | (Designated_Type => Desig, | |
1735e55d | 1313 | Insertion_Node => RPC_Receiver_Decl, |
8aa23fe3 | 1314 | Body_Decls => Body_Decls); |
70482933 RK |
1315 | |
1316 | else | |
25e9b6fe TQ |
1317 | -- Validate_RACW_Primitives requires the list of all primitives of |
1318 | -- the designated type, so defer processing until Desig is frozen. | |
1319 | -- See Exp_Ch3.Freeze_Type. | |
92869a7b | 1320 | |
70482933 RK |
1321 | Add_Access_Type_To_Process (E => Desig, A => RACW_Type); |
1322 | end if; | |
1323 | end Add_RACW_Features; | |
1324 | ||
15ce9ca2 AC |
1325 | ------------------------------------------------ |
1326 | -- Add_RACW_Primitive_Declarations_And_Bodies -- | |
1327 | ------------------------------------------------ | |
70482933 RK |
1328 | |
1329 | procedure Add_RACW_Primitive_Declarations_And_Bodies | |
15ce9ca2 AC |
1330 | (Designated_Type : Entity_Id; |
1331 | Insertion_Node : Node_Id; | |
8aa23fe3 | 1332 | Body_Decls : List_Id) |
70482933 | 1333 | is |
92869a7b | 1334 | Loc : constant Source_Ptr := Sloc (Insertion_Node); |
bd7f7a65 | 1335 | -- Set Sloc of generated declaration copy of insertion node Sloc, so |
5885facb | 1336 | -- the declarations are recognized as belonging to the current package. |
70482933 | 1337 | |
70482933 | 1338 | Stub_Elements : constant Stub_Structure := |
c885d7a1 | 1339 | Stubs_Table.Get (Designated_Type); |
70482933 RK |
1340 | |
1341 | pragma Assert (Stub_Elements /= Empty_Stub_Structure); | |
92869a7b | 1342 | |
1735e55d | 1343 | Is_RAS : constant Boolean := |
92869a7b | 1344 | not Comes_From_Source (Stub_Elements.RACW_Type); |
8aa23fe3 TQ |
1345 | -- Case of the RACW generated to implement a remote access-to- |
1346 | -- subprogram type. | |
1347 | ||
1348 | Build_Bodies : constant Boolean := | |
1349 | In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type); | |
1350 | -- True when bodies must be prepared in Body_Decls. Bodies are generated | |
1351 | -- only when the main unit is the unit that contains the stub type. | |
70482933 RK |
1352 | |
1353 | Current_Insertion_Node : Node_Id := Insertion_Node; | |
1354 | ||
bd7f7a65 | 1355 | RPC_Receiver : Entity_Id; |
70482933 RK |
1356 | RPC_Receiver_Statements : List_Id; |
1357 | RPC_Receiver_Case_Alternatives : constant List_Id := New_List; | |
1f8766d3 AC |
1358 | RPC_Receiver_Elsif_Parts : List_Id := No_List; |
1359 | RPC_Receiver_Request : Entity_Id := Empty; | |
1360 | RPC_Receiver_Subp_Id : Entity_Id := Empty; | |
1361 | RPC_Receiver_Subp_Index : Entity_Id := Empty; | |
70482933 | 1362 | |
1735e55d AC |
1363 | Subp_Str : String_Id; |
1364 | ||
70482933 RK |
1365 | Current_Primitive_Elmt : Elmt_Id; |
1366 | Current_Primitive : Entity_Id; | |
1367 | Current_Primitive_Body : Node_Id; | |
1368 | Current_Primitive_Spec : Node_Id; | |
1369 | Current_Primitive_Decl : Node_Id; | |
1370 | Current_Primitive_Number : Int := 0; | |
bfc2cdb1 TQ |
1371 | Current_Primitive_Alias : Node_Id; |
1372 | Current_Receiver : Entity_Id; | |
1373 | Current_Receiver_Body : Node_Id; | |
1374 | RPC_Receiver_Decl : Node_Id; | |
1375 | Possibly_Asynchronous : Boolean; | |
70482933 RK |
1376 | |
1377 | begin | |
70482933 RK |
1378 | if not Expander_Active then |
1379 | return; | |
1380 | end if; | |
1381 | ||
1735e55d | 1382 | if not Is_RAS then |
2287a75d | 1383 | RPC_Receiver := Make_Temporary (Loc, 'P'); |
d693e39d | 1384 | |
bfc2cdb1 TQ |
1385 | Specific_Build_RPC_Receiver_Body |
1386 | (RPC_Receiver => RPC_Receiver, | |
1387 | Request => RPC_Receiver_Request, | |
1388 | Subp_Id => RPC_Receiver_Subp_Id, | |
1389 | Subp_Index => RPC_Receiver_Subp_Index, | |
1390 | Stmts => RPC_Receiver_Statements, | |
1391 | Decl => RPC_Receiver_Decl); | |
82c80734 RD |
1392 | |
1393 | if Get_PCS_Name = Name_PolyORB_DSA then | |
1394 | ||
1395 | -- For the case of PolyORB, we need to map a textual operation | |
92869a7b TQ |
1396 | -- name into a primitive index. Currently we do so using a simple |
1397 | -- sequence of string comparisons. | |
82c80734 RD |
1398 | |
1399 | RPC_Receiver_Elsif_Parts := New_List; | |
82c80734 | 1400 | end if; |
1735e55d AC |
1401 | end if; |
1402 | ||
70482933 | 1403 | -- Build callers, receivers for every primitive operations and a RPC |
46202729 AC |
1404 | -- receiver for this type. Note that we use Direct_Primitive_Operations, |
1405 | -- not Primitive_Operations, because we really want just the primitives | |
1406 | -- of the tagged type itself, and in the case of a tagged synchronized | |
1407 | -- type we do not want to get the primitives of the corresponding | |
1408 | -- record type). | |
70482933 | 1409 | |
46202729 | 1410 | if Present (Direct_Primitive_Operations (Designated_Type)) then |
1735e55d AC |
1411 | Overload_Counter_Table.Reset; |
1412 | ||
70482933 | 1413 | Current_Primitive_Elmt := |
46202729 | 1414 | First_Elmt (Direct_Primitive_Operations (Designated_Type)); |
70482933 | 1415 | while Current_Primitive_Elmt /= No_Elmt loop |
70482933 RK |
1416 | Current_Primitive := Node (Current_Primitive_Elmt); |
1417 | ||
92869a7b | 1418 | -- Copy the primitive of all the parents, except predefined ones |
2cd6f54e TQ |
1419 | -- that are not remotely dispatching. Also omit hidden primitives |
1420 | -- (occurs in the case of primitives of interface progenitors | |
1421 | -- other than immediate ancestors of the Designated_Type). | |
70482933 RK |
1422 | |
1423 | if Chars (Current_Primitive) /= Name_uSize | |
fbf5a39b | 1424 | and then Chars (Current_Primitive) /= Name_uAlignment |
c3d593c9 TQ |
1425 | and then not |
1426 | (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else | |
1427 | Is_TSS (Current_Primitive, TSS_Stream_Input) or else | |
1428 | Is_TSS (Current_Primitive, TSS_Stream_Output) or else | |
1429 | Is_TSS (Current_Primitive, TSS_Stream_Read) or else | |
ef2a63ba JM |
1430 | Is_TSS (Current_Primitive, TSS_Stream_Write) |
1431 | or else | |
1432 | Is_Predefined_Interface_Primitive (Current_Primitive)) | |
2cd6f54e | 1433 | and then not Is_Hidden (Current_Primitive) |
70482933 | 1434 | then |
92869a7b | 1435 | -- The first thing to do is build an up-to-date copy of the |
c6f39437 | 1436 | -- spec with all the formals referencing Controlling_Type |
70482933 RK |
1437 | -- transformed into formals referencing Stub_Type. Since this |
1438 | -- primitive may have been inherited, go back the alias chain | |
1439 | -- until the real primitive has been found. | |
1440 | ||
b81a5940 | 1441 | Current_Primitive_Alias := Ultimate_Alias (Current_Primitive); |
70482933 | 1442 | |
8aa23fe3 TQ |
1443 | -- Copy the spec from the original declaration for the purpose |
1444 | -- of declaring an overriding subprogram: we need to replace | |
1445 | -- the type of each controlling formal with Stub_Type. The | |
c6f39437 | 1446 | -- primitive may have been declared for Controlling_Type or |
8aa23fe3 TQ |
1447 | -- inherited from some ancestor type for which we do not have |
1448 | -- an easily determined Entity_Id. We have no systematic way | |
1449 | -- of knowing which type to substitute Stub_Type for. Instead, | |
1450 | -- Copy_Specification relies on the flag Is_Controlling_Formal | |
1451 | -- to determine which formals to change. | |
1452 | ||
70482933 RK |
1453 | Current_Primitive_Spec := |
1454 | Copy_Specification (Loc, | |
1455 | Spec => Parent (Current_Primitive_Alias), | |
8aa23fe3 | 1456 | Ctrl_Type => Stub_Elements.Stub_Type); |
70482933 RK |
1457 | |
1458 | Current_Primitive_Decl := | |
1459 | Make_Subprogram_Declaration (Loc, | |
1460 | Specification => Current_Primitive_Spec); | |
1461 | ||
8aa23fe3 TQ |
1462 | Insert_After_And_Analyze (Current_Insertion_Node, |
1463 | Current_Primitive_Decl); | |
70482933 RK |
1464 | Current_Insertion_Node := Current_Primitive_Decl; |
1465 | ||
1466 | Possibly_Asynchronous := | |
1467 | Nkind (Current_Primitive_Spec) = N_Procedure_Specification | |
1468 | and then Could_Be_Asynchronous (Current_Primitive_Spec); | |
1469 | ||
1735e55d AC |
1470 | Assign_Subprogram_Identifier ( |
1471 | Defining_Unit_Name (Current_Primitive_Spec), | |
1472 | Current_Primitive_Number, | |
1473 | Subp_Str); | |
1474 | ||
8aa23fe3 TQ |
1475 | if Build_Bodies then |
1476 | Current_Primitive_Body := | |
1477 | Build_Subprogram_Calling_Stubs | |
1478 | (Vis_Decl => Current_Primitive_Decl, | |
1479 | Subp_Id => | |
1480 | Build_Subprogram_Id (Loc, | |
1481 | Defining_Unit_Name (Current_Primitive_Spec)), | |
1482 | Asynchronous => Possibly_Asynchronous, | |
1483 | Dynamically_Asynchronous => Possibly_Asynchronous, | |
1484 | Stub_Type => Stub_Elements.Stub_Type, | |
1485 | RACW_Type => Stub_Elements.RACW_Type); | |
1486 | Append_To (Body_Decls, Current_Primitive_Body); | |
1487 | ||
bfc2cdb1 TQ |
1488 | -- Analyzing the body here would cause the Stub type to |
1489 | -- be frozen, thus preventing subsequent primitive | |
1490 | -- declarations. For this reason, it will be analyzed | |
1491 | -- later in the regular flow (and in the context of the | |
8aa23fe3 TQ |
1492 | -- appropriate unit body, see Append_RACW_Bodies). |
1493 | ||
1494 | end if; | |
70482933 RK |
1495 | |
1496 | -- Build the receiver stubs | |
1497 | ||
8aa23fe3 | 1498 | if Build_Bodies and then not Is_RAS then |
1735e55d | 1499 | Current_Receiver_Body := |
16db96c5 | 1500 | Specific_Build_Subprogram_Receiving_Stubs |
1735e55d AC |
1501 | (Vis_Decl => Current_Primitive_Decl, |
1502 | Asynchronous => Possibly_Asynchronous, | |
1503 | Dynamically_Asynchronous => Possibly_Asynchronous, | |
1504 | Stub_Type => Stub_Elements.Stub_Type, | |
1505 | RACW_Type => Stub_Elements.RACW_Type, | |
1506 | Parent_Primitive => Current_Primitive); | |
1507 | ||
ef2a63ba JM |
1508 | Current_Receiver := |
1509 | Defining_Unit_Name (Specification (Current_Receiver_Body)); | |
1735e55d | 1510 | |
8aa23fe3 | 1511 | Append_To (Body_Decls, Current_Receiver_Body); |
1735e55d AC |
1512 | |
1513 | -- Add a case alternative to the receiver | |
1514 | ||
82c80734 RD |
1515 | if Get_PCS_Name = Name_PolyORB_DSA then |
1516 | Append_To (RPC_Receiver_Elsif_Parts, | |
1517 | Make_Elsif_Part (Loc, | |
1518 | Condition => | |
1519 | Make_Function_Call (Loc, | |
1520 | Name => | |
1521 | New_Occurrence_Of ( | |
1522 | RTE (RE_Caseless_String_Eq), Loc), | |
1523 | Parameter_Associations => New_List ( | |
1524 | New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc), | |
1525 | Make_String_Literal (Loc, Subp_Str))), | |
d693e39d | 1526 | |
82c80734 RD |
1527 | Then_Statements => New_List ( |
1528 | Make_Assignment_Statement (Loc, | |
1529 | Name => New_Occurrence_Of ( | |
1530 | RPC_Receiver_Subp_Index, Loc), | |
1531 | Expression => | |
1532 | Make_Integer_Literal (Loc, | |
d693e39d | 1533 | Intval => Current_Primitive_Number))))); |
82c80734 RD |
1534 | end if; |
1535 | ||
1735e55d AC |
1536 | Append_To (RPC_Receiver_Case_Alternatives, |
1537 | Make_Case_Statement_Alternative (Loc, | |
1538 | Discrete_Choices => New_List ( | |
1539 | Make_Integer_Literal (Loc, Current_Primitive_Number)), | |
1540 | ||
1541 | Statements => New_List ( | |
1542 | Make_Procedure_Call_Statement (Loc, | |
1543 | Name => | |
1544 | New_Occurrence_Of (Current_Receiver, Loc), | |
1545 | Parameter_Associations => New_List ( | |
16db96c5 | 1546 | New_Occurrence_Of (RPC_Receiver_Request, Loc)))))); |
1735e55d | 1547 | end if; |
70482933 RK |
1548 | |
1549 | -- Increment the index of current primitive | |
1550 | ||
1551 | Current_Primitive_Number := Current_Primitive_Number + 1; | |
1552 | end if; | |
1553 | ||
1554 | Next_Elmt (Current_Primitive_Elmt); | |
1555 | end loop; | |
1556 | end if; | |
1557 | ||
1558 | -- Build the case statement and the heart of the subprogram | |
1559 | ||
8aa23fe3 | 1560 | if Build_Bodies and then not Is_RAS then |
0772a6ea TQ |
1561 | if Get_PCS_Name = Name_PolyORB_DSA |
1562 | and then Present (First (RPC_Receiver_Elsif_Parts)) | |
1563 | then | |
1564 | Append_To (RPC_Receiver_Statements, | |
1565 | Make_Implicit_If_Statement (Designated_Type, | |
1566 | Condition => New_Occurrence_Of (Standard_False, Loc), | |
1567 | Then_Statements => New_List, | |
1568 | Elsif_Parts => RPC_Receiver_Elsif_Parts)); | |
1569 | end if; | |
1570 | ||
1735e55d AC |
1571 | Append_To (RPC_Receiver_Case_Alternatives, |
1572 | Make_Case_Statement_Alternative (Loc, | |
1573 | Discrete_Choices => New_List (Make_Others_Choice (Loc)), | |
1574 | Statements => New_List (Make_Null_Statement (Loc)))); | |
1575 | ||
1576 | Append_To (RPC_Receiver_Statements, | |
1577 | Make_Case_Statement (Loc, | |
1578 | Expression => | |
16db96c5 | 1579 | New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc), |
1735e55d AC |
1580 | Alternatives => RPC_Receiver_Case_Alternatives)); |
1581 | ||
8aa23fe3 | 1582 | Append_To (Body_Decls, RPC_Receiver_Decl); |
82c80734 | 1583 | Specific_Add_Obj_RPC_Receiver_Completion (Loc, |
8aa23fe3 | 1584 | Body_Decls, RPC_Receiver, Stub_Elements); |
70482933 | 1585 | |
8aa23fe3 TQ |
1586 | -- Do not analyze RPC receiver body at this stage since it references |
1587 | -- subprograms that have not been analyzed yet. It will be analyzed in | |
1588 | -- the regular flow (see Append_RACW_Bodies). | |
70482933 | 1589 | |
8aa23fe3 | 1590 | end if; |
70482933 RK |
1591 | end Add_RACW_Primitive_Declarations_And_Bodies; |
1592 | ||
1593 | ----------------------------- | |
1735e55d | 1594 | -- Add_RAS_Dereference_TSS -- |
70482933 RK |
1595 | ----------------------------- |
1596 | ||
1735e55d AC |
1597 | procedure Add_RAS_Dereference_TSS (N : Node_Id) is |
1598 | Loc : constant Source_Ptr := Sloc (N); | |
70482933 | 1599 | |
bfc2cdb1 | 1600 | Type_Def : constant Node_Id := Type_Definition (N); |
1735e55d AC |
1601 | RAS_Type : constant Entity_Id := Defining_Identifier (N); |
1602 | Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type); | |
1603 | RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type); | |
fbf5a39b | 1604 | |
1735e55d | 1605 | RACW_Primitive_Name : Node_Id; |
fbf5a39b | 1606 | |
1735e55d AC |
1607 | Proc : constant Entity_Id := |
1608 | Make_Defining_Identifier (Loc, | |
1609 | Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference)); | |
fbf5a39b | 1610 | |
1735e55d AC |
1611 | Proc_Spec : Node_Id; |
1612 | Param_Specs : List_Id; | |
1613 | Param_Assoc : constant List_Id := New_List; | |
1614 | Stmts : constant List_Id := New_List; | |
70482933 | 1615 | |
2287a75d | 1616 | RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'P'); |
70482933 | 1617 | |
1735e55d AC |
1618 | Is_Function : constant Boolean := |
1619 | Nkind (Type_Def) = N_Access_Function_Definition; | |
70482933 | 1620 | |
1735e55d | 1621 | Is_Degenerate : Boolean; |
92869a7b TQ |
1622 | -- Set to True if the subprogram_specification for this RAS has an |
1623 | -- anonymous access parameter (see Process_Remote_AST_Declaration). | |
70482933 | 1624 | |
1735e55d | 1625 | Spec : constant Node_Id := Type_Def; |
70482933 | 1626 | |
1735e55d | 1627 | Current_Parameter : Node_Id; |
70482933 | 1628 | |
1735e55d | 1629 | -- Start of processing for Add_RAS_Dereference_TSS |
70482933 | 1630 | |
1735e55d | 1631 | begin |
92869a7b TQ |
1632 | -- The Dereference TSS for a remote access-to-subprogram type has the |
1633 | -- form: | |
bd7f7a65 AC |
1634 | |
1635 | -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>) | |
1636 | -- [return <>] | |
1637 | ||
1638 | -- This is called whenever a value of a RAS type is dereferenced | |
70482933 | 1639 | |
1735e55d | 1640 | -- First construct a list of parameter specifications: |
70482933 | 1641 | |
1735e55d | 1642 | -- The first formal is the RAS values |
70482933 | 1643 | |
1735e55d AC |
1644 | Param_Specs := New_List ( |
1645 | Make_Parameter_Specification (Loc, | |
1646 | Defining_Identifier => RAS_Parameter, | |
1647 | In_Present => True, | |
1648 | Parameter_Type => | |
1649 | New_Occurrence_Of (Fat_Type, Loc))); | |
70482933 | 1650 | |
1735e55d | 1651 | -- The following formals are copied from the type declaration |
70482933 | 1652 | |
1735e55d AC |
1653 | Is_Degenerate := False; |
1654 | Current_Parameter := First (Parameter_Specifications (Type_Def)); | |
1655 | Parameters : while Present (Current_Parameter) loop | |
92869a7b TQ |
1656 | if Nkind (Parameter_Type (Current_Parameter)) = |
1657 | N_Access_Definition | |
1735e55d AC |
1658 | then |
1659 | Is_Degenerate := True; | |
1660 | end if; | |
92869a7b | 1661 | |
1735e55d AC |
1662 | Append_To (Param_Specs, |
1663 | Make_Parameter_Specification (Loc, | |
1664 | Defining_Identifier => | |
1665 | Make_Defining_Identifier (Loc, | |
1666 | Chars => Chars (Defining_Identifier (Current_Parameter))), | |
1667 | In_Present => In_Present (Current_Parameter), | |
1668 | Out_Present => Out_Present (Current_Parameter), | |
1669 | Parameter_Type => | |
1670 | New_Copy_Tree (Parameter_Type (Current_Parameter)), | |
1671 | Expression => | |
1672 | New_Copy_Tree (Expression (Current_Parameter)))); | |
c885d7a1 | 1673 | |
1735e55d AC |
1674 | Append_To (Param_Assoc, |
1675 | Make_Identifier (Loc, | |
1676 | Chars => Chars (Defining_Identifier (Current_Parameter)))); | |
c885d7a1 | 1677 | |
1735e55d AC |
1678 | Next (Current_Parameter); |
1679 | end loop Parameters; | |
70482933 | 1680 | |
1735e55d AC |
1681 | if Is_Degenerate then |
1682 | Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc)); | |
70482933 | 1683 | |
1735e55d AC |
1684 | -- Generate a dummy body. This code will never actually be executed, |
1685 | -- because null is the only legal value for a degenerate RAS type. | |
bfc2cdb1 TQ |
1686 | -- For legality's sake (in order to avoid generating a function that |
1687 | -- does not contain a return statement), we include a dummy recursive | |
1688 | -- call on the TSS itself. | |
70482933 | 1689 | |
1735e55d AC |
1690 | Append_To (Stmts, |
1691 | Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); | |
1692 | RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc); | |
70482933 | 1693 | |
1735e55d AC |
1694 | else |
1695 | -- For a normal RAS type, we cast the RAS formal to the corresponding | |
92869a7b TQ |
1696 | -- tagged type, and perform a dispatching call to its Call primitive |
1697 | -- operation. | |
70482933 | 1698 | |
1735e55d AC |
1699 | Prepend_To (Param_Assoc, |
1700 | Unchecked_Convert_To (RACW_Type, | |
1701 | New_Occurrence_Of (RAS_Parameter, Loc))); | |
70482933 | 1702 | |
8aa23fe3 TQ |
1703 | RACW_Primitive_Name := |
1704 | Make_Selected_Component (Loc, | |
1705 | Prefix => Scope (RACW_Type), | |
1706 | Selector_Name => Name_uCall); | |
1735e55d | 1707 | end if; |
70482933 | 1708 | |
1735e55d AC |
1709 | if Is_Function then |
1710 | Append_To (Stmts, | |
bfc2cdb1 | 1711 | Make_Simple_Return_Statement (Loc, |
1735e55d AC |
1712 | Expression => |
1713 | Make_Function_Call (Loc, | |
8aa23fe3 TQ |
1714 | Name => RACW_Primitive_Name, |
1715 | Parameter_Associations => Param_Assoc))); | |
70482933 | 1716 | |
1735e55d AC |
1717 | else |
1718 | Append_To (Stmts, | |
1719 | Make_Procedure_Call_Statement (Loc, | |
8aa23fe3 | 1720 | Name => RACW_Primitive_Name, |
1735e55d AC |
1721 | Parameter_Associations => Param_Assoc)); |
1722 | end if; | |
70482933 | 1723 | |
1735e55d | 1724 | -- Build the complete subprogram |
70482933 | 1725 | |
1735e55d AC |
1726 | if Is_Function then |
1727 | Proc_Spec := | |
1728 | Make_Function_Specification (Loc, | |
1729 | Defining_Unit_Name => Proc, | |
1730 | Parameter_Specifications => Param_Specs, | |
3eb8fddc | 1731 | Result_Definition => |
1735e55d | 1732 | New_Occurrence_Of ( |
3eb8fddc | 1733 | Entity (Result_Definition (Spec)), Loc)); |
70482933 | 1734 | |
1735e55d AC |
1735 | Set_Ekind (Proc, E_Function); |
1736 | Set_Etype (Proc, | |
3eb8fddc | 1737 | New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc)); |
70482933 | 1738 | |
1735e55d AC |
1739 | else |
1740 | Proc_Spec := | |
1741 | Make_Procedure_Specification (Loc, | |
1742 | Defining_Unit_Name => Proc, | |
1743 | Parameter_Specifications => Param_Specs); | |
70482933 | 1744 | |
1735e55d AC |
1745 | Set_Ekind (Proc, E_Procedure); |
1746 | Set_Etype (Proc, Standard_Void_Type); | |
1747 | end if; | |
70482933 | 1748 | |
1735e55d AC |
1749 | Discard_Node ( |
1750 | Make_Subprogram_Body (Loc, | |
1751 | Specification => Proc_Spec, | |
1752 | Declarations => New_List, | |
1753 | Handled_Statement_Sequence => | |
1754 | Make_Handled_Sequence_Of_Statements (Loc, | |
1755 | Statements => Stmts))); | |
70482933 | 1756 | |
1735e55d AC |
1757 | Set_TSS (Fat_Type, Proc); |
1758 | end Add_RAS_Dereference_TSS; | |
70482933 | 1759 | |
1735e55d AC |
1760 | ------------------------------- |
1761 | -- Add_RAS_Proxy_And_Analyze -- | |
1762 | ------------------------------- | |
70482933 | 1763 | |
1735e55d AC |
1764 | procedure Add_RAS_Proxy_And_Analyze |
1765 | (Decls : List_Id; | |
1766 | Vis_Decl : Node_Id; | |
1767 | All_Calls_Remote_E : Entity_Id; | |
1768 | Proxy_Object_Addr : out Entity_Id) | |
70482933 | 1769 | is |
1735e55d | 1770 | Loc : constant Source_Ptr := Sloc (Vis_Decl); |
70482933 | 1771 | |
1735e55d AC |
1772 | Subp_Name : constant Entity_Id := |
1773 | Defining_Unit_Name (Specification (Vis_Decl)); | |
c885d7a1 | 1774 | |
d693e39d TQ |
1775 | Pkg_Name : constant Entity_Id := |
1776 | Make_Defining_Identifier (Loc, | |
1777 | Chars => New_External_Name (Chars (Subp_Name), 'P', -1)); | |
70482933 | 1778 | |
1735e55d AC |
1779 | Proxy_Type : constant Entity_Id := |
1780 | Make_Defining_Identifier (Loc, | |
1781 | Chars => | |
d693e39d TQ |
1782 | New_External_Name |
1783 | (Related_Id => Chars (Subp_Name), | |
1784 | Suffix => 'P')); | |
70482933 | 1785 | |
1735e55d AC |
1786 | Proxy_Type_Full_View : constant Entity_Id := |
1787 | Make_Defining_Identifier (Loc, | |
1788 | Chars (Proxy_Type)); | |
70482933 | 1789 | |
1735e55d AC |
1790 | Subp_Decl_Spec : constant Node_Id := |
1791 | Build_RAS_Primitive_Specification | |
1792 | (Subp_Spec => Specification (Vis_Decl), | |
1793 | Remote_Object_Type => Proxy_Type); | |
fbf5a39b | 1794 | |
1735e55d AC |
1795 | Subp_Body_Spec : constant Node_Id := |
1796 | Build_RAS_Primitive_Specification | |
1797 | (Subp_Spec => Specification (Vis_Decl), | |
1798 | Remote_Object_Type => Proxy_Type); | |
fbf5a39b | 1799 | |
1735e55d AC |
1800 | Vis_Decls : constant List_Id := New_List; |
1801 | Pvt_Decls : constant List_Id := New_List; | |
1802 | Actuals : constant List_Id := New_List; | |
1803 | Formal : Node_Id; | |
1804 | Perform_Call : Node_Id; | |
70482933 RK |
1805 | |
1806 | begin | |
1735e55d AC |
1807 | -- type subpP is tagged limited private; |
1808 | ||
1809 | Append_To (Vis_Decls, | |
1810 | Make_Private_Type_Declaration (Loc, | |
1811 | Defining_Identifier => Proxy_Type, | |
1812 | Tagged_Present => True, | |
1813 | Limited_Present => True)); | |
70482933 | 1814 | |
1735e55d AC |
1815 | -- [subprogram] Call |
1816 | -- (Self : access subpP; | |
1817 | -- ...other-formals...) | |
1818 | -- [return T]; | |
c885d7a1 | 1819 | |
1735e55d AC |
1820 | Append_To (Vis_Decls, |
1821 | Make_Subprogram_Declaration (Loc, | |
1822 | Specification => Subp_Decl_Spec)); | |
c885d7a1 | 1823 | |
1735e55d | 1824 | -- A : constant System.Address; |
c885d7a1 | 1825 | |
1735e55d | 1826 | Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA); |
c885d7a1 | 1827 | |
1735e55d AC |
1828 | Append_To (Vis_Decls, |
1829 | Make_Object_Declaration (Loc, | |
d693e39d TQ |
1830 | Defining_Identifier => Proxy_Object_Addr, |
1831 | Constant_Present => True, | |
1832 | Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc))); | |
70482933 | 1833 | |
1735e55d | 1834 | -- private |
70482933 | 1835 | |
1735e55d AC |
1836 | -- type subpP is tagged limited record |
1837 | -- All_Calls_Remote : Boolean := [All_Calls_Remote?]; | |
1838 | -- ... | |
1839 | -- end record; | |
70482933 | 1840 | |
1735e55d AC |
1841 | Append_To (Pvt_Decls, |
1842 | Make_Full_Type_Declaration (Loc, | |
d693e39d | 1843 | Defining_Identifier => Proxy_Type_Full_View, |
1735e55d AC |
1844 | Type_Definition => |
1845 | Build_Remote_Subprogram_Proxy_Type (Loc, | |
1846 | New_Occurrence_Of (All_Calls_Remote_E, Loc)))); | |
70482933 | 1847 | |
8aa23fe3 TQ |
1848 | -- Trick semantic analysis into swapping the public and full view when |
1849 | -- freezing the public view. | |
70482933 | 1850 | |
1735e55d | 1851 | Set_Comes_From_Source (Proxy_Type_Full_View, True); |
70482933 | 1852 | |
1735e55d AC |
1853 | -- procedure Call |
1854 | -- (Self : access O; | |
1855 | -- ...other-formals...) is | |
1856 | -- begin | |
1857 | -- P (...other-formals...); | |
1858 | -- end Call; | |
70482933 | 1859 | |
1735e55d AC |
1860 | -- function Call |
1861 | -- (Self : access O; | |
1862 | -- ...other-formals...) | |
1863 | -- return T is | |
1864 | -- begin | |
1865 | -- return F (...other-formals...); | |
1866 | -- end Call; | |
70482933 | 1867 | |
1735e55d AC |
1868 | if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then |
1869 | Perform_Call := | |
1870 | Make_Procedure_Call_Statement (Loc, | |
d693e39d TQ |
1871 | Name => New_Occurrence_Of (Subp_Name, Loc), |
1872 | Parameter_Associations => Actuals); | |
1735e55d AC |
1873 | else |
1874 | Perform_Call := | |
bfc2cdb1 | 1875 | Make_Simple_Return_Statement (Loc, |
1735e55d | 1876 | Expression => |
d693e39d TQ |
1877 | Make_Function_Call (Loc, |
1878 | Name => New_Occurrence_Of (Subp_Name, Loc), | |
1879 | Parameter_Associations => Actuals)); | |
1735e55d | 1880 | end if; |
70482933 | 1881 | |
1735e55d AC |
1882 | Formal := First (Parameter_Specifications (Subp_Decl_Spec)); |
1883 | pragma Assert (Present (Formal)); | |
bd7f7a65 | 1884 | loop |
1735e55d | 1885 | Next (Formal); |
bd7f7a65 AC |
1886 | exit when No (Formal); |
1887 | Append_To (Actuals, | |
1888 | New_Occurrence_Of (Defining_Identifier (Formal), Loc)); | |
1735e55d | 1889 | end loop; |
70482933 | 1890 | |
1735e55d | 1891 | -- O : aliased subpP; |
70482933 | 1892 | |
1735e55d AC |
1893 | Append_To (Pvt_Decls, |
1894 | Make_Object_Declaration (Loc, | |
d693e39d TQ |
1895 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), |
1896 | Aliased_Present => True, | |
1897 | Object_Definition => New_Occurrence_Of (Proxy_Type, Loc))); | |
70482933 | 1898 | |
1735e55d | 1899 | -- A : constant System.Address := O'Address; |
70482933 | 1900 | |
1735e55d AC |
1901 | Append_To (Pvt_Decls, |
1902 | Make_Object_Declaration (Loc, | |
1903 | Defining_Identifier => | |
d693e39d | 1904 | Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)), |
8e4bea29 TQ |
1905 | Constant_Present => True, |
1906 | Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc), | |
70482933 | 1907 | Expression => |
1735e55d AC |
1908 | Make_Attribute_Reference (Loc, |
1909 | Prefix => New_Occurrence_Of ( | |
1910 | Defining_Identifier (Last (Pvt_Decls)), Loc), | |
d693e39d | 1911 | Attribute_Name => Name_Address))); |
70482933 | 1912 | |
1735e55d AC |
1913 | Append_To (Decls, |
1914 | Make_Package_Declaration (Loc, | |
1915 | Specification => Make_Package_Specification (Loc, | |
1916 | Defining_Unit_Name => Pkg_Name, | |
1917 | Visible_Declarations => Vis_Decls, | |
1918 | Private_Declarations => Pvt_Decls, | |
1919 | End_Label => Empty))); | |
1920 | Analyze (Last (Decls)); | |
70482933 | 1921 | |
1735e55d AC |
1922 | Append_To (Decls, |
1923 | Make_Package_Body (Loc, | |
1924 | Defining_Unit_Name => | |
d693e39d | 1925 | Make_Defining_Identifier (Loc, Chars (Pkg_Name)), |
1735e55d AC |
1926 | Declarations => New_List ( |
1927 | Make_Subprogram_Body (Loc, | |
d693e39d | 1928 | Specification => Subp_Body_Spec, |
1735e55d AC |
1929 | Declarations => New_List, |
1930 | Handled_Statement_Sequence => | |
1931 | Make_Handled_Sequence_Of_Statements (Loc, | |
1932 | Statements => New_List (Perform_Call)))))); | |
1933 | Analyze (Last (Decls)); | |
1934 | end Add_RAS_Proxy_And_Analyze; | |
c885d7a1 | 1935 | |
1735e55d AC |
1936 | ----------------------- |
1937 | -- Add_RAST_Features -- | |
1938 | ----------------------- | |
70482933 | 1939 | |
1735e55d AC |
1940 | procedure Add_RAST_Features (Vis_Decl : Node_Id) is |
1941 | RAS_Type : constant Entity_Id := | |
1942 | Equivalent_Type (Defining_Identifier (Vis_Decl)); | |
1735e55d AC |
1943 | begin |
1944 | pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access))); | |
1735e55d | 1945 | Add_RAS_Dereference_TSS (Vis_Decl); |
c857f5ed | 1946 | Specific_Add_RAST_Features (Vis_Decl, RAS_Type); |
1735e55d | 1947 | end Add_RAST_Features; |
c885d7a1 | 1948 | |
1735e55d AC |
1949 | ------------------- |
1950 | -- Add_Stub_Type -- | |
1951 | ------------------- | |
70482933 | 1952 | |
1735e55d AC |
1953 | procedure Add_Stub_Type |
1954 | (Designated_Type : Entity_Id; | |
1955 | RACW_Type : Entity_Id; | |
1956 | Decls : List_Id; | |
1957 | Stub_Type : out Entity_Id; | |
1958 | Stub_Type_Access : out Entity_Id; | |
1959 | RPC_Receiver_Decl : out Node_Id; | |
8aa23fe3 | 1960 | Body_Decls : out List_Id; |
1735e55d AC |
1961 | Existing : out Boolean) |
1962 | is | |
1963 | Loc : constant Source_Ptr := Sloc (RACW_Type); | |
70482933 | 1964 | |
c6f39437 AC |
1965 | Stub_Elements : constant Stub_Structure := |
1966 | Stubs_Table.Get (Designated_Type); | |
bd7f7a65 AC |
1967 | Stub_Type_Decl : Node_Id; |
1968 | Stub_Type_Access_Decl : Node_Id; | |
c885d7a1 | 1969 | |
1735e55d AC |
1970 | begin |
1971 | if Stub_Elements /= Empty_Stub_Structure then | |
1972 | Stub_Type := Stub_Elements.Stub_Type; | |
1973 | Stub_Type_Access := Stub_Elements.Stub_Type_Access; | |
1974 | RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl; | |
8aa23fe3 | 1975 | Body_Decls := Stub_Elements.Body_Decls; |
1735e55d AC |
1976 | Existing := True; |
1977 | return; | |
70482933 RK |
1978 | end if; |
1979 | ||
bfc2cdb1 | 1980 | Existing := False; |
2287a75d | 1981 | Stub_Type := Make_Temporary (Loc, 'S'); |
25e9b6fe TQ |
1982 | Set_Ekind (Stub_Type, E_Record_Type); |
1983 | Set_Is_RACW_Stub_Type (Stub_Type); | |
bd7f7a65 AC |
1984 | Stub_Type_Access := |
1985 | Make_Defining_Identifier (Loc, | |
bfc2cdb1 TQ |
1986 | Chars => New_External_Name |
1987 | (Related_Id => Chars (Stub_Type), Suffix => 'A')); | |
70482933 | 1988 | |
a3068ca6 AC |
1989 | RPC_Receiver_Decl := Specific_RPC_Receiver_Decl (RACW_Type); |
1990 | ||
1991 | -- Create new stub type, copying components from generic RACW_Stub_Type | |
c6f39437 AC |
1992 | |
1993 | Stub_Type_Decl := | |
1994 | Make_Full_Type_Declaration (Loc, | |
1995 | Defining_Identifier => Stub_Type, | |
1996 | Type_Definition => | |
1997 | Make_Record_Definition (Loc, | |
1998 | Tagged_Present => True, | |
1999 | Limited_Present => True, | |
2000 | Component_List => | |
2001 | Make_Component_List (Loc, | |
a3068ca6 AC |
2002 | Component_Items => |
2003 | Copy_Component_List (RTE (RE_RACW_Stub_Type), Loc)))); | |
c6f39437 AC |
2004 | |
2005 | -- Does the stub type need to explicitly implement interfaces from the | |
2006 | -- designated type??? | |
2007 | ||
2008 | -- In particular are there issues in the case where the designated type | |
2009 | -- is a synchronized interface??? | |
70482933 | 2010 | |
bd7f7a65 AC |
2011 | Stub_Type_Access_Decl := |
2012 | Make_Full_Type_Declaration (Loc, | |
2013 | Defining_Identifier => Stub_Type_Access, | |
2014 | Type_Definition => | |
2015 | Make_Access_To_Object_Definition (Loc, | |
2016 | All_Present => True, | |
2017 | Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc))); | |
c885d7a1 | 2018 | |
bd7f7a65 AC |
2019 | Append_To (Decls, Stub_Type_Decl); |
2020 | Analyze (Last (Decls)); | |
2021 | Append_To (Decls, Stub_Type_Access_Decl); | |
2022 | Analyze (Last (Decls)); | |
70482933 | 2023 | |
c6f39437 AC |
2024 | -- We can't directly derive the stub type from the designated type, |
2025 | -- because we don't want any components or discriminants from the real | |
2026 | -- type, so instead we manually fake a derivation to get an appropriate | |
2027 | -- dispatch table. | |
70482933 | 2028 | |
1735e55d AC |
2029 | Derive_Subprograms (Parent_Type => Designated_Type, |
2030 | Derived_Type => Stub_Type); | |
70482933 | 2031 | |
bd7f7a65 AC |
2032 | if Present (RPC_Receiver_Decl) then |
2033 | Append_To (Decls, RPC_Receiver_Decl); | |
a3068ca6 | 2034 | |
bd7f7a65 | 2035 | else |
bb012790 AC |
2036 | -- Case of RACW implementing a RAS with the GARLIC PCS: there is |
2037 | -- no RPC receiver in that case, this is just an indication of | |
2038 | -- where to insert code in the tree (see comment in declaration of | |
2039 | -- type Stub_Structure). | |
a3068ca6 | 2040 | |
bd7f7a65 | 2041 | RPC_Receiver_Decl := Last (Decls); |
1735e55d | 2042 | end if; |
c885d7a1 | 2043 | |
8aa23fe3 TQ |
2044 | Body_Decls := New_List; |
2045 | ||
1735e55d AC |
2046 | Stubs_Table.Set (Designated_Type, |
2047 | (Stub_Type => Stub_Type, | |
2048 | Stub_Type_Access => Stub_Type_Access, | |
2049 | RPC_Receiver_Decl => RPC_Receiver_Decl, | |
8aa23fe3 | 2050 | Body_Decls => Body_Decls, |
1735e55d AC |
2051 | RACW_Type => RACW_Type)); |
2052 | end Add_Stub_Type; | |
c885d7a1 | 2053 | |
8aa23fe3 TQ |
2054 | ------------------------ |
2055 | -- Append_RACW_Bodies -- | |
2056 | ------------------------ | |
2057 | ||
2058 | procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is | |
2059 | E : Entity_Id; | |
c6f39437 | 2060 | |
8aa23fe3 TQ |
2061 | begin |
2062 | E := First_Entity (Spec_Id); | |
2063 | while Present (E) loop | |
2064 | if Is_Remote_Access_To_Class_Wide_Type (E) then | |
2065 | Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E)); | |
2066 | end if; | |
2067 | ||
2068 | Next_Entity (E); | |
2069 | end loop; | |
2070 | end Append_RACW_Bodies; | |
2071 | ||
1735e55d AC |
2072 | ---------------------------------- |
2073 | -- Assign_Subprogram_Identifier -- | |
2074 | ---------------------------------- | |
c885d7a1 | 2075 | |
1735e55d AC |
2076 | procedure Assign_Subprogram_Identifier |
2077 | (Def : Entity_Id; | |
2078 | Spn : Int; | |
2079 | Id : out String_Id) | |
2080 | is | |
2081 | N : constant Name_Id := Chars (Def); | |
c885d7a1 | 2082 | |
1df4f514 | 2083 | Overload_Order : constant Int := Overload_Counter_Table.Get (N) + 1; |
c885d7a1 AC |
2084 | |
2085 | begin | |
1735e55d | 2086 | Overload_Counter_Table.Set (N, Overload_Order); |
c885d7a1 | 2087 | |
1735e55d | 2088 | Get_Name_String (N); |
c885d7a1 | 2089 | |
c6f39437 AC |
2090 | -- Homonym handling: as in Exp_Dbug, but much simpler, because the only |
2091 | -- entities for which we have to generate names here need only to be | |
2092 | -- disambiguated within their own scope. | |
c885d7a1 | 2093 | |
1735e55d AC |
2094 | if Overload_Order > 1 then |
2095 | Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__"; | |
2096 | Name_Len := Name_Len + 2; | |
2097 | Add_Nat_To_Name_Buffer (Overload_Order); | |
2098 | end if; | |
c885d7a1 | 2099 | |
1735e55d | 2100 | Id := String_From_Name_Buffer; |
c6f39437 AC |
2101 | Subprogram_Identifier_Table.Set |
2102 | (Def, | |
2103 | Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn)); | |
1735e55d | 2104 | end Assign_Subprogram_Identifier; |
c885d7a1 | 2105 | |
8aa23fe3 TQ |
2106 | ------------------------------------- |
2107 | -- Build_Actual_Object_Declaration -- | |
2108 | ------------------------------------- | |
2109 | ||
2110 | procedure Build_Actual_Object_Declaration | |
2111 | (Object : Entity_Id; | |
2112 | Etyp : Entity_Id; | |
2113 | Variable : Boolean; | |
2114 | Expr : Node_Id; | |
2115 | Decls : List_Id) | |
2116 | is | |
2117 | Loc : constant Source_Ptr := Sloc (Object); | |
c6f39437 | 2118 | |
8aa23fe3 TQ |
2119 | begin |
2120 | -- Declare a temporary object for the actual, possibly initialized with | |
2121 | -- a 'Input/From_Any call. | |
2122 | ||
2123 | -- Complication arises in the case of limited types, for which such a | |
2124 | -- declaration is illegal in Ada 95. In that case, we first generate a | |
2125 | -- renaming declaration of the 'Input call, and then if needed we | |
2126 | -- generate an overlaid non-constant view. | |
2127 | ||
2128 | if Ada_Version <= Ada_95 | |
2129 | and then Is_Limited_Type (Etyp) | |
2130 | and then Present (Expr) | |
2131 | then | |
2132 | ||
2133 | -- Object : Etyp renames <func-call> | |
2134 | ||
2135 | Append_To (Decls, | |
2136 | Make_Object_Renaming_Declaration (Loc, | |
2137 | Defining_Identifier => Object, | |
2138 | Subtype_Mark => New_Occurrence_Of (Etyp, Loc), | |
2139 | Name => Expr)); | |
2140 | ||
2141 | if Variable then | |
2142 | ||
2143 | -- The name defined by the renaming declaration denotes a | |
2144 | -- constant view; create a non-constant object at the same address | |
2145 | -- to be used as the actual. | |
2146 | ||
2147 | declare | |
2148 | Constant_Object : constant Entity_Id := | |
2287a75d AC |
2149 | Make_Temporary (Loc, 'P'); |
2150 | ||
8aa23fe3 TQ |
2151 | begin |
2152 | Set_Defining_Identifier | |
2153 | (Last (Decls), Constant_Object); | |
2154 | ||
2155 | -- We have an unconstrained Etyp: build the actual constrained | |
2156 | -- subtype for the value we just read from the stream. | |
2157 | ||
8fc789c8 | 2158 | -- subtype S is <actual subtype of Constant_Object>; |
8aa23fe3 TQ |
2159 | |
2160 | Append_To (Decls, | |
2161 | Build_Actual_Subtype (Etyp, | |
2162 | New_Occurrence_Of (Constant_Object, Loc))); | |
2163 | ||
2164 | -- Object : S; | |
2165 | ||
2166 | Append_To (Decls, | |
2167 | Make_Object_Declaration (Loc, | |
2168 | Defining_Identifier => Object, | |
2169 | Object_Definition => | |
2170 | New_Occurrence_Of | |
2171 | (Defining_Identifier (Last (Decls)), Loc))); | |
2172 | Set_Ekind (Object, E_Variable); | |
2173 | ||
2174 | -- Suppress default initialization: | |
2175 | -- pragma Import (Ada, Object); | |
2176 | ||
2177 | Append_To (Decls, | |
2178 | Make_Pragma (Loc, | |
3860d469 | 2179 | Chars => Name_Import, |
8aa23fe3 TQ |
2180 | Pragma_Argument_Associations => New_List ( |
2181 | Make_Pragma_Argument_Association (Loc, | |
2182 | Chars => Name_Convention, | |
2183 | Expression => Make_Identifier (Loc, Name_Ada)), | |
2184 | Make_Pragma_Argument_Association (Loc, | |
2185 | Chars => Name_Entity, | |
2186 | Expression => New_Occurrence_Of (Object, Loc))))); | |
2187 | ||
2188 | -- for Object'Address use Constant_Object'Address; | |
2189 | ||
2190 | Append_To (Decls, | |
2191 | Make_Attribute_Definition_Clause (Loc, | |
2192 | Name => New_Occurrence_Of (Object, Loc), | |
2193 | Chars => Name_Address, | |
2194 | Expression => | |
2195 | Make_Attribute_Reference (Loc, | |
d693e39d TQ |
2196 | Prefix => New_Occurrence_Of (Constant_Object, Loc), |
2197 | Attribute_Name => Name_Address))); | |
8aa23fe3 TQ |
2198 | end; |
2199 | end if; | |
2200 | ||
2201 | else | |
8aa23fe3 TQ |
2202 | -- General case of a regular object declaration. Object is flagged |
2203 | -- constant unless it has mode out or in out, to allow the backend | |
2204 | -- to optimize where possible. | |
2205 | ||
2206 | -- Object : [constant] Etyp [:= <expr>]; | |
2207 | ||
2208 | Append_To (Decls, | |
2209 | Make_Object_Declaration (Loc, | |
2210 | Defining_Identifier => Object, | |
2211 | Constant_Present => Present (Expr) and then not Variable, | |
d693e39d | 2212 | Object_Definition => New_Occurrence_Of (Etyp, Loc), |
8aa23fe3 TQ |
2213 | Expression => Expr)); |
2214 | ||
2215 | if Constant_Present (Last (Decls)) then | |
2216 | Set_Ekind (Object, E_Constant); | |
2217 | else | |
2218 | Set_Ekind (Object, E_Variable); | |
2219 | end if; | |
2220 | end if; | |
2221 | end Build_Actual_Object_Declaration; | |
2222 | ||
bd7f7a65 AC |
2223 | ------------------------------ |
2224 | -- Build_Get_Unique_RP_Call -- | |
2225 | ------------------------------ | |
c885d7a1 | 2226 | |
bd7f7a65 AC |
2227 | function Build_Get_Unique_RP_Call |
2228 | (Loc : Source_Ptr; | |
2229 | Pointer : Entity_Id; | |
2230 | Stub_Type : Entity_Id) return List_Id | |
1735e55d | 2231 | is |
bd7f7a65 AC |
2232 | begin |
2233 | return New_List ( | |
2234 | Make_Procedure_Call_Statement (Loc, | |
2235 | Name => | |
2236 | New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc), | |
2237 | Parameter_Associations => New_List ( | |
2238 | Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), | |
2239 | New_Occurrence_Of (Pointer, Loc)))), | |
c885d7a1 | 2240 | |
bd7f7a65 AC |
2241 | Make_Assignment_Statement (Loc, |
2242 | Name => | |
2243 | Make_Selected_Component (Loc, | |
d693e39d | 2244 | Prefix => New_Occurrence_Of (Pointer, Loc), |
bd7f7a65 | 2245 | Selector_Name => |
a9d8907c | 2246 | New_Occurrence_Of (First_Tag_Component |
bd7f7a65 AC |
2247 | (Designated_Type (Etype (Pointer))), Loc)), |
2248 | Expression => | |
2249 | Make_Attribute_Reference (Loc, | |
d693e39d TQ |
2250 | Prefix => New_Occurrence_Of (Stub_Type, Loc), |
2251 | Attribute_Name => Name_Tag))); | |
c885d7a1 | 2252 | |
bd7f7a65 AC |
2253 | -- Note: The assignment to Pointer._Tag is safe here because |
2254 | -- we carefully ensured that Stub_Type has exactly the same layout | |
2255 | -- as System.Partition_Interface.RACW_Stub_Type. | |
c885d7a1 | 2256 | |
bd7f7a65 | 2257 | end Build_Get_Unique_RP_Call; |
c885d7a1 | 2258 | |
bd7f7a65 AC |
2259 | ----------------------------------- |
2260 | -- Build_Ordered_Parameters_List -- | |
2261 | ----------------------------------- | |
c885d7a1 | 2262 | |
bd7f7a65 AC |
2263 | function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is |
2264 | Constrained_List : List_Id; | |
2265 | Unconstrained_List : List_Id; | |
2266 | Current_Parameter : Node_Id; | |
7f0b5314 | 2267 | Ptyp : Node_Id; |
70482933 | 2268 | |
bd7f7a65 AC |
2269 | First_Parameter : Node_Id; |
2270 | For_RAS : Boolean := False; | |
70482933 | 2271 | |
1735e55d | 2272 | begin |
d48e258e | 2273 | if No (Parameter_Specifications (Spec)) then |
bd7f7a65 AC |
2274 | return New_List; |
2275 | end if; | |
70482933 | 2276 | |
bd7f7a65 AC |
2277 | Constrained_List := New_List; |
2278 | Unconstrained_List := New_List; | |
2279 | First_Parameter := First (Parameter_Specifications (Spec)); | |
70482933 | 2280 | |
bd7f7a65 AC |
2281 | if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition |
2282 | and then Chars (Defining_Identifier (First_Parameter)) = Name_uS | |
2283 | then | |
2284 | For_RAS := True; | |
2285 | end if; | |
70482933 | 2286 | |
7f0b5314 TQ |
2287 | -- Loop through the parameters and add them to the right list. Note that |
2288 | -- we treat a parameter of a null-excluding access type as unconstrained | |
2289 | -- because we can't declare an object of such a type with default | |
2290 | -- initialization. | |
70482933 | 2291 | |
bd7f7a65 AC |
2292 | Current_Parameter := First_Parameter; |
2293 | while Present (Current_Parameter) loop | |
7f0b5314 TQ |
2294 | Ptyp := Parameter_Type (Current_Parameter); |
2295 | ||
2296 | if (Nkind (Ptyp) = N_Access_Definition | |
2297 | or else not Transmit_As_Unconstrained (Etype (Ptyp))) | |
bd7f7a65 AC |
2298 | and then not (For_RAS and then Current_Parameter = First_Parameter) |
2299 | then | |
2300 | Append_To (Constrained_List, New_Copy (Current_Parameter)); | |
2301 | else | |
2302 | Append_To (Unconstrained_List, New_Copy (Current_Parameter)); | |
2303 | end if; | |
70482933 | 2304 | |
bd7f7a65 AC |
2305 | Next (Current_Parameter); |
2306 | end loop; | |
70482933 | 2307 | |
bd7f7a65 | 2308 | -- Unconstrained parameters are returned first |
70482933 | 2309 | |
bd7f7a65 | 2310 | Append_List_To (Unconstrained_List, Constrained_List); |
70482933 | 2311 | |
bd7f7a65 AC |
2312 | return Unconstrained_List; |
2313 | end Build_Ordered_Parameters_List; | |
70482933 | 2314 | |
bd7f7a65 AC |
2315 | ---------------------------------- |
2316 | -- Build_Passive_Partition_Stub -- | |
2317 | ---------------------------------- | |
2318 | ||
2319 | procedure Build_Passive_Partition_Stub (U : Node_Id) is | |
2320 | Pkg_Spec : Node_Id; | |
72267417 | 2321 | Pkg_Ent : Entity_Id; |
bd7f7a65 AC |
2322 | L : List_Id; |
2323 | Reg : Node_Id; | |
2324 | Loc : constant Source_Ptr := Sloc (U); | |
70482933 | 2325 | |
bd7f7a65 AC |
2326 | begin |
2327 | -- Verify that the implementation supports distribution, by accessing | |
2328 | -- a type defined in the proper version of system.rpc | |
70482933 | 2329 | |
bd7f7a65 AC |
2330 | declare |
2331 | Dist_OK : Entity_Id; | |
2332 | pragma Warnings (Off, Dist_OK); | |
2333 | begin | |
2334 | Dist_OK := RTE (RE_Params_Stream_Type); | |
2335 | end; | |
2336 | ||
2337 | -- Use body if present, spec otherwise | |
2338 | ||
2339 | if Nkind (U) = N_Package_Declaration then | |
2340 | Pkg_Spec := Specification (U); | |
2341 | L := Visible_Declarations (Pkg_Spec); | |
2342 | else | |
2343 | Pkg_Spec := Parent (Corresponding_Spec (U)); | |
2344 | L := Declarations (U); | |
2345 | end if; | |
72267417 | 2346 | Pkg_Ent := Defining_Entity (Pkg_Spec); |
bd7f7a65 | 2347 | |
bd7f7a65 AC |
2348 | Reg := |
2349 | Make_Procedure_Call_Statement (Loc, | |
2350 | Name => | |
2351 | New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc), | |
2352 | Parameter_Associations => New_List ( | |
72267417 AC |
2353 | Make_String_Literal (Loc, |
2354 | Fully_Qualified_Name_String (Pkg_Ent, Append_NUL => False)), | |
1735e55d | 2355 | Make_Attribute_Reference (Loc, |
72267417 | 2356 | Prefix => New_Occurrence_Of (Pkg_Ent, Loc), |
d693e39d | 2357 | Attribute_Name => Name_Version))); |
bd7f7a65 AC |
2358 | Append_To (L, Reg); |
2359 | Analyze (Reg); | |
2360 | end Build_Passive_Partition_Stub; | |
70482933 | 2361 | |
16db96c5 AC |
2362 | -------------------------------------- |
2363 | -- Build_RPC_Receiver_Specification -- | |
2364 | -------------------------------------- | |
2365 | ||
2366 | function Build_RPC_Receiver_Specification | |
2367 | (RPC_Receiver : Entity_Id; | |
2368 | Request_Parameter : Entity_Id) return Node_Id | |
2369 | is | |
2370 | Loc : constant Source_Ptr := Sloc (RPC_Receiver); | |
2371 | begin | |
2372 | return | |
2373 | Make_Procedure_Specification (Loc, | |
2374 | Defining_Unit_Name => RPC_Receiver, | |
2375 | Parameter_Specifications => New_List ( | |
2376 | Make_Parameter_Specification (Loc, | |
2377 | Defining_Identifier => Request_Parameter, | |
2378 | Parameter_Type => | |
2379 | New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); | |
2380 | end Build_RPC_Receiver_Specification; | |
2381 | ||
bd7f7a65 AC |
2382 | ---------------------------------------- |
2383 | -- Build_Remote_Subprogram_Proxy_Type -- | |
2384 | ---------------------------------------- | |
70482933 | 2385 | |
bd7f7a65 AC |
2386 | function Build_Remote_Subprogram_Proxy_Type |
2387 | (Loc : Source_Ptr; | |
2388 | ACR_Expression : Node_Id) return Node_Id | |
2389 | is | |
2390 | begin | |
2391 | return | |
2392 | Make_Record_Definition (Loc, | |
2393 | Tagged_Present => True, | |
2394 | Limited_Present => True, | |
2395 | Component_List => | |
2396 | Make_Component_List (Loc, | |
bd7f7a65 AC |
2397 | Component_Items => New_List ( |
2398 | Make_Component_Declaration (Loc, | |
16db96c5 AC |
2399 | Defining_Identifier => |
2400 | Make_Defining_Identifier (Loc, | |
2401 | Name_All_Calls_Remote), | |
2402 | Component_Definition => | |
2403 | Make_Component_Definition (Loc, | |
2404 | Subtype_Indication => | |
2405 | New_Occurrence_Of (Standard_Boolean, Loc)), | |
2406 | Expression => | |
2407 | ACR_Expression), | |
70482933 | 2408 | |
bd7f7a65 | 2409 | Make_Component_Declaration (Loc, |
16db96c5 AC |
2410 | Defining_Identifier => |
2411 | Make_Defining_Identifier (Loc, | |
2412 | Name_Receiver), | |
2413 | Component_Definition => | |
2414 | Make_Component_Definition (Loc, | |
2415 | Subtype_Indication => | |
2416 | New_Occurrence_Of (RTE (RE_Address), Loc)), | |
2417 | Expression => | |
2418 | New_Occurrence_Of (RTE (RE_Null_Address), Loc)), | |
70482933 | 2419 | |
bd7f7a65 | 2420 | Make_Component_Declaration (Loc, |
16db96c5 AC |
2421 | Defining_Identifier => |
2422 | Make_Defining_Identifier (Loc, | |
2423 | Name_Subp_Id), | |
2424 | Component_Definition => | |
2425 | Make_Component_Definition (Loc, | |
2426 | Subtype_Indication => | |
2427 | New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)))))); | |
bd7f7a65 | 2428 | end Build_Remote_Subprogram_Proxy_Type; |
c885d7a1 | 2429 | |
d693e39d TQ |
2430 | -------------------- |
2431 | -- Build_Stub_Tag -- | |
2432 | -------------------- | |
2433 | ||
2434 | function Build_Stub_Tag | |
2435 | (Loc : Source_Ptr; | |
2436 | RACW_Type : Entity_Id) return Node_Id | |
2437 | is | |
2438 | Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type); | |
2439 | begin | |
2440 | return | |
2441 | Make_Attribute_Reference (Loc, | |
2442 | Prefix => New_Occurrence_Of (Stub_Type, Loc), | |
2443 | Attribute_Name => Name_Tag); | |
2444 | end Build_Stub_Tag; | |
2445 | ||
bd7f7a65 AC |
2446 | ------------------------------------ |
2447 | -- Build_Subprogram_Calling_Stubs -- | |
2448 | ------------------------------------ | |
c885d7a1 | 2449 | |
bd7f7a65 AC |
2450 | function Build_Subprogram_Calling_Stubs |
2451 | (Vis_Decl : Node_Id; | |
2452 | Subp_Id : Node_Id; | |
2453 | Asynchronous : Boolean; | |
2454 | Dynamically_Asynchronous : Boolean := False; | |
2455 | Stub_Type : Entity_Id := Empty; | |
2456 | RACW_Type : Entity_Id := Empty; | |
2457 | Locator : Entity_Id := Empty; | |
2458 | New_Name : Name_Id := No_Name) return Node_Id | |
2459 | is | |
2460 | Loc : constant Source_Ptr := Sloc (Vis_Decl); | |
70482933 | 2461 | |
bd7f7a65 AC |
2462 | Decls : constant List_Id := New_List; |
2463 | Statements : constant List_Id := New_List; | |
70482933 | 2464 | |
bd7f7a65 AC |
2465 | Subp_Spec : Node_Id; |
2466 | -- The specification of the body | |
70482933 | 2467 | |
bd7f7a65 | 2468 | Controlling_Parameter : Entity_Id := Empty; |
70482933 | 2469 | |
bd7f7a65 | 2470 | Asynchronous_Expr : Node_Id := Empty; |
70482933 | 2471 | |
bd7f7a65 | 2472 | RCI_Locator : Entity_Id; |
70482933 | 2473 | |
bd7f7a65 | 2474 | Spec_To_Use : Node_Id; |
70482933 | 2475 | |
bd7f7a65 AC |
2476 | procedure Insert_Partition_Check (Parameter : Node_Id); |
2477 | -- Check that the parameter has been elaborated on the same partition | |
2478 | -- than the controlling parameter (E.4(19)). | |
1735e55d | 2479 | |
bd7f7a65 AC |
2480 | ---------------------------- |
2481 | -- Insert_Partition_Check -- | |
2482 | ---------------------------- | |
1735e55d | 2483 | |
bd7f7a65 AC |
2484 | procedure Insert_Partition_Check (Parameter : Node_Id) is |
2485 | Parameter_Entity : constant Entity_Id := | |
2486 | Defining_Identifier (Parameter); | |
2487 | begin | |
2488 | -- The expression that will be built is of the form: | |
1735e55d | 2489 | |
bd7f7a65 AC |
2490 | -- if not Same_Partition (Parameter, Controlling_Parameter) then |
2491 | -- raise Constraint_Error; | |
2492 | -- end if; | |
1735e55d | 2493 | |
bd7f7a65 AC |
2494 | -- We do not check that Parameter is in Stub_Type since such a check |
2495 | -- has been inserted at the point of call already (a tag check since | |
2496 | -- we have multiple controlling operands). | |
1735e55d | 2497 | |
bd7f7a65 AC |
2498 | Append_To (Decls, |
2499 | Make_Raise_Constraint_Error (Loc, | |
2500 | Condition => | |
2501 | Make_Op_Not (Loc, | |
2502 | Right_Opnd => | |
2503 | Make_Function_Call (Loc, | |
2504 | Name => | |
2505 | New_Occurrence_Of (RTE (RE_Same_Partition), Loc), | |
2506 | Parameter_Associations => | |
2507 | New_List ( | |
2508 | Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), | |
2509 | New_Occurrence_Of (Parameter_Entity, Loc)), | |
2510 | Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), | |
2511 | New_Occurrence_Of (Controlling_Parameter, Loc))))), | |
2512 | Reason => CE_Partition_Check_Failed)); | |
2513 | end Insert_Partition_Check; | |
1735e55d | 2514 | |
bd7f7a65 | 2515 | -- Start of processing for Build_Subprogram_Calling_Stubs |
1735e55d | 2516 | |
bd7f7a65 | 2517 | begin |
2287a75d AC |
2518 | Subp_Spec := |
2519 | Copy_Specification (Loc, | |
2520 | Spec => Specification (Vis_Decl), | |
2521 | New_Name => New_Name); | |
1735e55d | 2522 | |
bd7f7a65 AC |
2523 | if Locator = Empty then |
2524 | RCI_Locator := RCI_Cache; | |
2525 | Spec_To_Use := Specification (Vis_Decl); | |
2526 | else | |
2527 | RCI_Locator := Locator; | |
2528 | Spec_To_Use := Subp_Spec; | |
2529 | end if; | |
c885d7a1 | 2530 | |
bd7f7a65 AC |
2531 | -- Find a controlling argument if we have a stub type. Also check |
2532 | -- if this subprogram can be made asynchronous. | |
c885d7a1 | 2533 | |
bd7f7a65 AC |
2534 | if Present (Stub_Type) |
2535 | and then Present (Parameter_Specifications (Spec_To_Use)) | |
2536 | then | |
2537 | declare | |
2538 | Current_Parameter : Node_Id := | |
2539 | First (Parameter_Specifications | |
2540 | (Spec_To_Use)); | |
2541 | begin | |
1735e55d | 2542 | while Present (Current_Parameter) loop |
bd7f7a65 AC |
2543 | if |
2544 | Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) | |
2545 | then | |
2546 | if Controlling_Parameter = Empty then | |
2547 | Controlling_Parameter := | |
2548 | Defining_Identifier (Current_Parameter); | |
1735e55d | 2549 | else |
bd7f7a65 | 2550 | Insert_Partition_Check (Current_Parameter); |
1735e55d | 2551 | end if; |
bd7f7a65 | 2552 | end if; |
1735e55d AC |
2553 | |
2554 | Next (Current_Parameter); | |
2555 | end loop; | |
bd7f7a65 | 2556 | end; |
1735e55d | 2557 | end if; |
70482933 | 2558 | |
bd7f7a65 | 2559 | pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter)); |
70482933 | 2560 | |
bd7f7a65 | 2561 | if Dynamically_Asynchronous then |
16db96c5 AC |
2562 | Asynchronous_Expr := Make_Selected_Component (Loc, |
2563 | Prefix => Controlling_Parameter, | |
2564 | Selector_Name => Name_Asynchronous); | |
bd7f7a65 | 2565 | end if; |
70482933 | 2566 | |
bd7f7a65 AC |
2567 | Specific_Build_General_Calling_Stubs |
2568 | (Decls => Decls, | |
2569 | Statements => Statements, | |
2570 | Target => Specific_Build_Stub_Target (Loc, | |
2571 | Decls, RCI_Locator, Controlling_Parameter), | |
2572 | Subprogram_Id => Subp_Id, | |
2573 | Asynchronous => Asynchronous_Expr, | |
2574 | Is_Known_Asynchronous => Asynchronous | |
2575 | and then not Dynamically_Asynchronous, | |
2576 | Is_Known_Non_Asynchronous | |
2577 | => not Asynchronous | |
2578 | and then not Dynamically_Asynchronous, | |
2579 | Is_Function => Nkind (Spec_To_Use) = | |
2580 | N_Function_Specification, | |
2581 | Spec => Spec_To_Use, | |
2582 | Stub_Type => Stub_Type, | |
2583 | RACW_Type => RACW_Type, | |
2584 | Nod => Vis_Decl); | |
70482933 | 2585 | |
bd7f7a65 AC |
2586 | RCI_Calling_Stubs_Table.Set |
2587 | (Defining_Unit_Name (Specification (Vis_Decl)), | |
2588 | Defining_Unit_Name (Spec_To_Use)); | |
70482933 | 2589 | |
bd7f7a65 AC |
2590 | return |
2591 | Make_Subprogram_Body (Loc, | |
2592 | Specification => Subp_Spec, | |
2593 | Declarations => Decls, | |
2594 | Handled_Statement_Sequence => | |
2595 | Make_Handled_Sequence_Of_Statements (Loc, Statements)); | |
2596 | end Build_Subprogram_Calling_Stubs; | |
c885d7a1 | 2597 | |
bd7f7a65 AC |
2598 | ------------------------- |
2599 | -- Build_Subprogram_Id -- | |
2600 | ------------------------- | |
c885d7a1 | 2601 | |
bd7f7a65 AC |
2602 | function Build_Subprogram_Id |
2603 | (Loc : Source_Ptr; | |
2604 | E : Entity_Id) return Node_Id | |
1735e55d AC |
2605 | is |
2606 | begin | |
92869a7b TQ |
2607 | if Get_Subprogram_Ids (E).Str_Identifier = No_String then |
2608 | declare | |
2609 | Current_Declaration : Node_Id; | |
2610 | Current_Subp : Entity_Id; | |
2611 | Current_Subp_Str : String_Id; | |
2612 | Current_Subp_Number : Int := First_RCI_Subprogram_Id; | |
2613 | ||
2cd6f54e TQ |
2614 | pragma Warnings (Off, Current_Subp_Str); |
2615 | ||
92869a7b TQ |
2616 | begin |
2617 | -- Build_Subprogram_Id is called outside of the context of | |
2618 | -- generating calling or receiving stubs. Hence we are processing | |
2619 | -- an 'Access attribute_reference for an RCI subprogram, for the | |
2620 | -- purpose of obtaining a RAS value. | |
2621 | ||
2622 | pragma Assert | |
2623 | (Is_Remote_Call_Interface (Scope (E)) | |
2624 | and then | |
2625 | (Nkind (Parent (E)) = N_Procedure_Specification | |
2626 | or else | |
2627 | Nkind (Parent (E)) = N_Function_Specification)); | |
2628 | ||
2629 | Current_Declaration := | |
2630 | First (Visible_Declarations | |
2631 | (Package_Specification_Of_Scope (Scope (E)))); | |
2632 | while Present (Current_Declaration) loop | |
2633 | if Nkind (Current_Declaration) = N_Subprogram_Declaration | |
2634 | and then Comes_From_Source (Current_Declaration) | |
2635 | then | |
2636 | Current_Subp := Defining_Unit_Name (Specification ( | |
2637 | Current_Declaration)); | |
2638 | ||
2639 | Assign_Subprogram_Identifier | |
2640 | (Current_Subp, Current_Subp_Number, Current_Subp_Str); | |
2641 | ||
2642 | Current_Subp_Number := Current_Subp_Number + 1; | |
2643 | end if; | |
2644 | ||
2645 | Next (Current_Declaration); | |
2646 | end loop; | |
2647 | end; | |
2648 | end if; | |
2649 | ||
82c80734 RD |
2650 | case Get_PCS_Name is |
2651 | when Name_PolyORB_DSA => | |
92869a7b | 2652 | return Make_String_Literal (Loc, Get_Subprogram_Id (E)); |
d8f43ee6 | 2653 | |
82c80734 RD |
2654 | when others => |
2655 | return Make_Integer_Literal (Loc, Get_Subprogram_Id (E)); | |
2656 | end case; | |
bd7f7a65 | 2657 | end Build_Subprogram_Id; |
70482933 | 2658 | |
16db96c5 AC |
2659 | ------------------------ |
2660 | -- Copy_Specification -- | |
2661 | ------------------------ | |
70482933 | 2662 | |
16db96c5 | 2663 | function Copy_Specification |
7b27e183 AC |
2664 | (Loc : Source_Ptr; |
2665 | Spec : Node_Id; | |
2666 | Ctrl_Type : Entity_Id := Empty; | |
2667 | New_Name : Name_Id := No_Name) return Node_Id | |
bd7f7a65 | 2668 | is |
16db96c5 | 2669 | Parameters : List_Id := No_List; |
bd7f7a65 AC |
2670 | |
2671 | Current_Parameter : Node_Id; | |
2672 | Current_Identifier : Entity_Id; | |
2673 | Current_Type : Node_Id; | |
bd7f7a65 AC |
2674 | |
2675 | Name_For_New_Spec : Name_Id; | |
2676 | ||
2677 | New_Identifier : Entity_Id; | |
2678 | ||
2679 | -- Comments needed in body below ??? | |
2680 | ||
2681 | begin | |
2682 | if New_Name = No_Name then | |
2683 | pragma Assert (Nkind (Spec) = N_Function_Specification | |
2684 | or else Nkind (Spec) = N_Procedure_Specification); | |
2685 | ||
2686 | Name_For_New_Spec := Chars (Defining_Unit_Name (Spec)); | |
2687 | else | |
2688 | Name_For_New_Spec := New_Name; | |
2689 | end if; | |
2690 | ||
2691 | if Present (Parameter_Specifications (Spec)) then | |
2692 | Parameters := New_List; | |
2693 | Current_Parameter := First (Parameter_Specifications (Spec)); | |
2694 | while Present (Current_Parameter) loop | |
2695 | Current_Identifier := Defining_Identifier (Current_Parameter); | |
2696 | Current_Type := Parameter_Type (Current_Parameter); | |
2697 | ||
2698 | if Nkind (Current_Type) = N_Access_Definition then | |
8aa23fe3 TQ |
2699 | if Present (Ctrl_Type) then |
2700 | pragma Assert (Is_Controlling_Formal (Current_Identifier)); | |
bd7f7a65 AC |
2701 | Current_Type := |
2702 | Make_Access_Definition (Loc, | |
8aa23fe3 | 2703 | Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc), |
d48e258e ES |
2704 | Null_Exclusion_Present => |
2705 | Null_Exclusion_Present (Current_Type)); | |
2706 | ||
bd7f7a65 AC |
2707 | else |
2708 | Current_Type := | |
2709 | Make_Access_Definition (Loc, | |
2710 | Subtype_Mark => | |
8aa23fe3 | 2711 | New_Copy_Tree (Subtype_Mark (Current_Type)), |
d48e258e | 2712 | Null_Exclusion_Present => |
8aa23fe3 | 2713 | Null_Exclusion_Present (Current_Type)); |
bd7f7a65 AC |
2714 | end if; |
2715 | ||
2716 | else | |
8aa23fe3 TQ |
2717 | if Present (Ctrl_Type) |
2718 | and then Is_Controlling_Formal (Current_Identifier) | |
bd7f7a65 | 2719 | then |
8aa23fe3 | 2720 | Current_Type := New_Occurrence_Of (Ctrl_Type, Loc); |
bd7f7a65 | 2721 | else |
8aa23fe3 | 2722 | Current_Type := New_Copy_Tree (Current_Type); |
bd7f7a65 AC |
2723 | end if; |
2724 | end if; | |
2725 | ||
2726 | New_Identifier := Make_Defining_Identifier (Loc, | |
2727 | Chars (Current_Identifier)); | |
2728 | ||
2729 | Append_To (Parameters, | |
2730 | Make_Parameter_Specification (Loc, | |
2731 | Defining_Identifier => New_Identifier, | |
2732 | Parameter_Type => Current_Type, | |
2733 | In_Present => In_Present (Current_Parameter), | |
2734 | Out_Present => Out_Present (Current_Parameter), | |
2735 | Expression => | |
2736 | New_Copy_Tree (Expression (Current_Parameter)))); | |
2737 | ||
16db96c5 AC |
2738 | -- For a regular formal parameter (that needs to be marshalled |
2739 | -- in the context of remote calls), set the Etype now, because | |
2740 | -- marshalling processing might need it. | |
2741 | ||
2742 | if Is_Entity_Name (Current_Type) then | |
2743 | Set_Etype (New_Identifier, Entity (Current_Type)); | |
2744 | ||
2745 | -- Current_Type is an access definition, special processing | |
2746 | -- (not requiring etype) will occur for marshalling. | |
2747 | ||
2748 | else | |
2749 | null; | |
2750 | end if; | |
2751 | ||
bd7f7a65 AC |
2752 | Next (Current_Parameter); |
2753 | end loop; | |
2754 | end if; | |
2755 | ||
2756 | case Nkind (Spec) is | |
d8f43ee6 HK |
2757 | when N_Access_Function_Definition |
2758 | | N_Function_Specification | |
2759 | => | |
bd7f7a65 AC |
2760 | return |
2761 | Make_Function_Specification (Loc, | |
2762 | Defining_Unit_Name => | |
2763 | Make_Defining_Identifier (Loc, | |
2764 | Chars => Name_For_New_Spec), | |
2765 | Parameter_Specifications => Parameters, | |
3eb8fddc TQ |
2766 | Result_Definition => |
2767 | New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc)); | |
bd7f7a65 | 2768 | |
d8f43ee6 HK |
2769 | when N_Access_Procedure_Definition |
2770 | | N_Procedure_Specification | |
2771 | => | |
bd7f7a65 AC |
2772 | return |
2773 | Make_Procedure_Specification (Loc, | |
2774 | Defining_Unit_Name => | |
2775 | Make_Defining_Identifier (Loc, | |
2776 | Chars => Name_For_New_Spec), | |
2777 | Parameter_Specifications => Parameters); | |
2778 | ||
2779 | when others => | |
2780 | raise Program_Error; | |
2781 | end case; | |
2782 | end Copy_Specification; | |
2783 | ||
92869a7b TQ |
2784 | ----------------------------- |
2785 | -- Corresponding_Stub_Type -- | |
2786 | ----------------------------- | |
2787 | ||
2788 | function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is | |
2789 | Desig : constant Entity_Id := | |
2790 | Etype (Designated_Type (RACW_Type)); | |
2791 | Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); | |
2792 | begin | |
2793 | return Stub_Elements.Stub_Type; | |
2794 | end Corresponding_Stub_Type; | |
2795 | ||
bd7f7a65 AC |
2796 | --------------------------- |
2797 | -- Could_Be_Asynchronous -- | |
2798 | --------------------------- | |
2799 | ||
2800 | function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is | |
2801 | Current_Parameter : Node_Id; | |
2802 | ||
2803 | begin | |
2804 | if Present (Parameter_Specifications (Spec)) then | |
2805 | Current_Parameter := First (Parameter_Specifications (Spec)); | |
2806 | while Present (Current_Parameter) loop | |
2807 | if Out_Present (Current_Parameter) then | |
2808 | return False; | |
2809 | end if; | |
2810 | ||
2811 | Next (Current_Parameter); | |
2812 | end loop; | |
2813 | end if; | |
2814 | ||
2815 | return True; | |
2816 | end Could_Be_Asynchronous; | |
2817 | ||
2818 | --------------------------- | |
2819 | -- Declare_Create_NVList -- | |
2820 | --------------------------- | |
2821 | ||
2822 | procedure Declare_Create_NVList | |
2823 | (Loc : Source_Ptr; | |
2824 | NVList : Entity_Id; | |
2825 | Decls : List_Id; | |
2826 | Stmts : List_Id) | |
2827 | is | |
2828 | begin | |
2829 | Append_To (Decls, | |
2830 | Make_Object_Declaration (Loc, | |
2831 | Defining_Identifier => NVList, | |
2832 | Aliased_Present => False, | |
2833 | Object_Definition => | |
2834 | New_Occurrence_Of (RTE (RE_NVList_Ref), Loc))); | |
2835 | ||
2836 | Append_To (Stmts, | |
2837 | Make_Procedure_Call_Statement (Loc, | |
d693e39d | 2838 | Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc), |
bd7f7a65 AC |
2839 | Parameter_Associations => New_List ( |
2840 | New_Occurrence_Of (NVList, Loc)))); | |
2841 | end Declare_Create_NVList; | |
2842 | ||
2843 | --------------------------------------------- | |
2844 | -- Expand_All_Calls_Remote_Subprogram_Call -- | |
2845 | --------------------------------------------- | |
2846 | ||
2847 | procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is | |
0e41a941 | 2848 | Loc : constant Source_Ptr := Sloc (N); |
bd7f7a65 AC |
2849 | Called_Subprogram : constant Entity_Id := Entity (Name (N)); |
2850 | RCI_Package : constant Entity_Id := Scope (Called_Subprogram); | |
0e41a941 AC |
2851 | RCI_Locator_Decl : Node_Id; |
2852 | RCI_Locator : Entity_Id; | |
bd7f7a65 AC |
2853 | Calling_Stubs : Node_Id; |
2854 | E_Calling_Stubs : Entity_Id; | |
2855 | ||
2856 | begin | |
2857 | E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram); | |
2858 | ||
2859 | if E_Calling_Stubs = Empty then | |
0e41a941 | 2860 | RCI_Locator := RCI_Locator_Table.Get (RCI_Package); |
bd7f7a65 | 2861 | |
0e41a941 AC |
2862 | -- The RCI_Locator package and calling stub are is inserted at the |
2863 | -- top level in the current unit, and must appear in the proper scope | |
2864 | -- so that it is not prematurely removed by the GCC back end. | |
bd7f7a65 | 2865 | |
0e41a941 AC |
2866 | declare |
2867 | Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); | |
2868 | begin | |
2869 | if Ekind (Scop) = E_Package_Body then | |
2870 | Push_Scope (Spec_Entity (Scop)); | |
2871 | elsif Ekind (Scop) = E_Subprogram_Body then | |
2872 | Push_Scope | |
2873 | (Corresponding_Spec (Unit_Declaration_Node (Scop))); | |
2874 | else | |
2875 | Push_Scope (Scop); | |
2876 | end if; | |
2877 | end; | |
bd7f7a65 | 2878 | |
0e41a941 AC |
2879 | if RCI_Locator = Empty then |
2880 | RCI_Locator_Decl := | |
d12b19fa | 2881 | RCI_Package_Locator (Loc, Package_Specification (RCI_Package)); |
0e41a941 AC |
2882 | Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl); |
2883 | Analyze (RCI_Locator_Decl); | |
2884 | RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl); | |
bd7f7a65 AC |
2885 | |
2886 | else | |
0e41a941 | 2887 | RCI_Locator_Decl := Parent (RCI_Locator); |
bd7f7a65 AC |
2888 | end if; |
2889 | ||
2890 | Calling_Stubs := Build_Subprogram_Calling_Stubs | |
2891 | (Vis_Decl => Parent (Parent (Called_Subprogram)), | |
2892 | Subp_Id => | |
2893 | Build_Subprogram_Id (Loc, Called_Subprogram), | |
2894 | Asynchronous => Nkind (N) = N_Procedure_Call_Statement | |
2895 | and then | |
2896 | Is_Asynchronous (Called_Subprogram), | |
0e41a941 | 2897 | Locator => RCI_Locator, |
bd7f7a65 | 2898 | New_Name => New_Internal_Name ('S')); |
0e41a941 | 2899 | Insert_After (RCI_Locator_Decl, Calling_Stubs); |
bd7f7a65 | 2900 | Analyze (Calling_Stubs); |
0e41a941 AC |
2901 | Pop_Scope; |
2902 | ||
bd7f7a65 AC |
2903 | E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs)); |
2904 | end if; | |
2905 | ||
2906 | Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc)); | |
2907 | end Expand_All_Calls_Remote_Subprogram_Call; | |
2908 | ||
2909 | --------------------------------- | |
2910 | -- Expand_Calling_Stubs_Bodies -- | |
2911 | --------------------------------- | |
2912 | ||
2913 | procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is | |
2914 | Spec : constant Node_Id := Specification (Unit_Node); | |
bd7f7a65 | 2915 | begin |
ff2efe85 | 2916 | Add_Calling_Stubs_To_Declarations (Spec); |
bd7f7a65 AC |
2917 | end Expand_Calling_Stubs_Bodies; |
2918 | ||
2919 | ----------------------------------- | |
2920 | -- Expand_Receiving_Stubs_Bodies -- | |
2921 | ----------------------------------- | |
2922 | ||
2923 | procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is | |
bfc2cdb1 TQ |
2924 | Spec : Node_Id; |
2925 | Decls : List_Id; | |
2926 | Stubs_Decls : List_Id; | |
2927 | Stubs_Stmts : List_Id; | |
bd7f7a65 AC |
2928 | |
2929 | begin | |
2930 | if Nkind (Unit_Node) = N_Package_Declaration then | |
2931 | Spec := Specification (Unit_Node); | |
82c80734 RD |
2932 | Decls := Private_Declarations (Spec); |
2933 | ||
2934 | if No (Decls) then | |
2935 | Decls := Visible_Declarations (Spec); | |
2936 | end if; | |
2937 | ||
c3d593c9 | 2938 | Push_Scope (Scope_Of_Spec (Spec)); |
bfc2cdb1 TQ |
2939 | Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls); |
2940 | ||
bd7f7a65 | 2941 | else |
bfc2cdb1 | 2942 | Spec := |
bd7f7a65 AC |
2943 | Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node)); |
2944 | Decls := Declarations (Unit_Node); | |
8aa23fe3 | 2945 | |
c3d593c9 | 2946 | Push_Scope (Scope_Of_Spec (Unit_Node)); |
bfc2cdb1 TQ |
2947 | Stubs_Decls := New_List; |
2948 | Stubs_Stmts := New_List; | |
8aa23fe3 | 2949 | Specific_Add_Receiving_Stubs_To_Declarations |
bfc2cdb1 TQ |
2950 | (Spec, Stubs_Decls, Stubs_Stmts); |
2951 | ||
2952 | Insert_List_Before (First (Decls), Stubs_Decls); | |
2953 | ||
2954 | declare | |
2955 | HSS_Stmts : constant List_Id := | |
2956 | Statements (Handled_Statement_Sequence (Unit_Node)); | |
d693e39d | 2957 | |
bfc2cdb1 | 2958 | First_HSS_Stmt : constant Node_Id := First (HSS_Stmts); |
d693e39d | 2959 | |
bfc2cdb1 TQ |
2960 | begin |
2961 | if No (First_HSS_Stmt) then | |
2962 | Append_List_To (HSS_Stmts, Stubs_Stmts); | |
2963 | else | |
2964 | Insert_List_Before (First_HSS_Stmt, Stubs_Stmts); | |
2965 | end if; | |
2966 | end; | |
bd7f7a65 AC |
2967 | end if; |
2968 | ||
2969 | Pop_Scope; | |
2970 | end Expand_Receiving_Stubs_Bodies; | |
2971 | ||
2972 | -------------------- | |
2973 | -- GARLIC_Support -- | |
2974 | -------------------- | |
2975 | ||
2976 | package body GARLIC_Support is | |
2977 | ||
2978 | -- Local subprograms | |
2979 | ||
2980 | procedure Add_RACW_Read_Attribute | |
2981 | (RACW_Type : Entity_Id; | |
2982 | Stub_Type : Entity_Id; | |
2983 | Stub_Type_Access : Entity_Id; | |
8aa23fe3 TQ |
2984 | Body_Decls : List_Id); |
2985 | -- Add Read attribute for the RACW type. The declaration and attribute | |
2986 | -- definition clauses are inserted right after the declaration of | |
7f0b5314 TQ |
2987 | -- RACW_Type. If Body_Decls is not No_List, the subprogram body is |
2988 | -- appended to it (case where the RACW declaration is in the main unit). | |
bd7f7a65 AC |
2989 | |
2990 | procedure Add_RACW_Write_Attribute | |
2991 | (RACW_Type : Entity_Id; | |
2992 | Stub_Type : Entity_Id; | |
2993 | Stub_Type_Access : Entity_Id; | |
2994 | RPC_Receiver : Node_Id; | |
8aa23fe3 TQ |
2995 | Body_Decls : List_Id); |
2996 | -- Same as above for the Write attribute | |
bd7f7a65 AC |
2997 | |
2998 | function Stream_Parameter return Node_Id; | |
2999 | function Result return Node_Id; | |
3000 | function Object return Node_Id renames Result; | |
8aa23fe3 TQ |
3001 | -- Functions to create occurrences of the formal parameter names of the |
3002 | -- 'Read and 'Write attributes. | |
bd7f7a65 AC |
3003 | |
3004 | Loc : Source_Ptr; | |
8aa23fe3 TQ |
3005 | -- Shared source location used by Add_{Read,Write}_Read_Attribute and |
3006 | -- their ancillary subroutines (set on entry by Add_RACW_Features). | |
bd7f7a65 AC |
3007 | |
3008 | procedure Add_RAS_Access_TSS (N : Node_Id); | |
3009 | -- Add a subprogram body for RAS Access TSS | |
3010 | ||
82c80734 RD |
3011 | ------------------------------------- |
3012 | -- Add_Obj_RPC_Receiver_Completion -- | |
3013 | ------------------------------------- | |
3014 | ||
3015 | procedure Add_Obj_RPC_Receiver_Completion | |
3016 | (Loc : Source_Ptr; | |
3017 | Decls : List_Id; | |
3018 | RPC_Receiver : Entity_Id; | |
d693e39d TQ |
3019 | Stub_Elements : Stub_Structure) |
3020 | is | |
82c80734 RD |
3021 | begin |
3022 | -- The RPC receiver body should not be the completion of the | |
3023 | -- declaration recorded in the stub structure, because then the | |
8aa23fe3 TQ |
3024 | -- occurrences of the formal parameters within the body should refer |
3025 | -- to the entities from the declaration, not from the completion, to | |
3026 | -- which we do not have easy access. Instead, the RPC receiver body | |
3027 | -- acts as its own declaration, and the RPC receiver declaration is | |
3028 | -- completed by a renaming-as-body. | |
82c80734 RD |
3029 | |
3030 | Append_To (Decls, | |
3031 | Make_Subprogram_Renaming_Declaration (Loc, | |
3032 | Specification => | |
3033 | Copy_Specification (Loc, | |
3034 | Specification (Stub_Elements.RPC_Receiver_Decl)), | |
3035 | Name => New_Occurrence_Of (RPC_Receiver, Loc))); | |
3036 | end Add_Obj_RPC_Receiver_Completion; | |
3037 | ||
bd7f7a65 AC |
3038 | ----------------------- |
3039 | -- Add_RACW_Features -- | |
3040 | ----------------------- | |
3041 | ||
3042 | procedure Add_RACW_Features | |
3043 | (RACW_Type : Entity_Id; | |
3044 | Stub_Type : Entity_Id; | |
3045 | Stub_Type_Access : Entity_Id; | |
3046 | RPC_Receiver_Decl : Node_Id; | |
8aa23fe3 | 3047 | Body_Decls : List_Id) |
bd7f7a65 AC |
3048 | is |
3049 | RPC_Receiver : Node_Id; | |
3050 | Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); | |
3051 | ||
3052 | begin | |
3053 | Loc := Sloc (RACW_Type); | |
3054 | ||
3055 | if Is_RAS then | |
3056 | ||
8aa23fe3 TQ |
3057 | -- For a RAS, the RPC receiver is that of the RCI unit, not that |
3058 | -- of the corresponding distributed object type. We retrieve its | |
3059 | -- address from the local proxy object. | |
bd7f7a65 AC |
3060 | |
3061 | RPC_Receiver := Make_Selected_Component (Loc, | |
3062 | Prefix => | |
3063 | Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object), | |
3064 | Selector_Name => Make_Identifier (Loc, Name_Receiver)); | |
3065 | ||
3066 | else | |
3067 | RPC_Receiver := Make_Attribute_Reference (Loc, | |
3068 | Prefix => New_Occurrence_Of ( | |
3069 | Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc), | |
3070 | Attribute_Name => Name_Address); | |
3071 | end if; | |
3072 | ||
d693e39d TQ |
3073 | Add_RACW_Write_Attribute |
3074 | (RACW_Type, | |
3075 | Stub_Type, | |
3076 | Stub_Type_Access, | |
3077 | RPC_Receiver, | |
3078 | Body_Decls); | |
3079 | ||
3080 | Add_RACW_Read_Attribute | |
3081 | (RACW_Type, | |
3082 | Stub_Type, | |
3083 | Stub_Type_Access, | |
3084 | Body_Decls); | |
bd7f7a65 AC |
3085 | end Add_RACW_Features; |
3086 | ||
3087 | ----------------------------- | |
3088 | -- Add_RACW_Read_Attribute -- | |
3089 | ----------------------------- | |
3090 | ||
3091 | procedure Add_RACW_Read_Attribute | |
3092 | (RACW_Type : Entity_Id; | |
3093 | Stub_Type : Entity_Id; | |
3094 | Stub_Type_Access : Entity_Id; | |
8aa23fe3 | 3095 | Body_Decls : List_Id) |
bd7f7a65 AC |
3096 | is |
3097 | Proc_Decl : Node_Id; | |
3098 | Attr_Decl : Node_Id; | |
3099 | ||
3100 | Body_Node : Node_Id; | |
3101 | ||
7f0b5314 | 3102 | Statements : constant List_Id := New_List; |
bd7f7a65 | 3103 | Decls : List_Id; |
bd7f7a65 AC |
3104 | Local_Statements : List_Id; |
3105 | Remote_Statements : List_Id; | |
3106 | -- Various parts of the procedure | |
3107 | ||
2287a75d | 3108 | Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); |
bd7f7a65 AC |
3109 | Asynchronous_Flag : constant Entity_Id := |
3110 | Asynchronous_Flags_Table.Get (RACW_Type); | |
3111 | pragma Assert (Present (Asynchronous_Flag)); | |
3112 | ||
7f0b5314 TQ |
3113 | -- Prepare local identifiers |
3114 | ||
3115 | Source_Partition : Entity_Id; | |
3116 | Source_Receiver : Entity_Id; | |
3117 | Source_Address : Entity_Id; | |
3118 | Local_Stub : Entity_Id; | |
3119 | Stubbed_Result : Entity_Id; | |
3120 | ||
bd7f7a65 AC |
3121 | -- Start of processing for Add_RACW_Read_Attribute |
3122 | ||
3123 | begin | |
7f0b5314 TQ |
3124 | Build_Stream_Procedure (Loc, |
3125 | RACW_Type, Body_Node, Pnam, Statements, Outp => True); | |
3126 | Proc_Decl := Make_Subprogram_Declaration (Loc, | |
3127 | Copy_Specification (Loc, Specification (Body_Node))); | |
3128 | ||
3129 | Attr_Decl := | |
3130 | Make_Attribute_Definition_Clause (Loc, | |
3131 | Name => New_Occurrence_Of (RACW_Type, Loc), | |
3132 | Chars => Name_Read, | |
3133 | Expression => | |
3134 | New_Occurrence_Of ( | |
3135 | Defining_Unit_Name (Specification (Proc_Decl)), Loc)); | |
3136 | ||
3137 | Insert_After (Declaration_Node (RACW_Type), Proc_Decl); | |
3138 | Insert_After (Proc_Decl, Attr_Decl); | |
3139 | ||
3140 | if No (Body_Decls) then | |
d693e39d | 3141 | |
7f0b5314 TQ |
3142 | -- Case of processing an RACW type from another unit than the |
3143 | -- main one: do not generate a body. | |
3144 | ||
3145 | return; | |
3146 | end if; | |
3147 | ||
3148 | -- Prepare local identifiers | |
3149 | ||
2287a75d AC |
3150 | Source_Partition := Make_Temporary (Loc, 'P'); |
3151 | Source_Receiver := Make_Temporary (Loc, 'S'); | |
3152 | Source_Address := Make_Temporary (Loc, 'P'); | |
3153 | Local_Stub := Make_Temporary (Loc, 'L'); | |
3154 | Stubbed_Result := Make_Temporary (Loc, 'S'); | |
7f0b5314 | 3155 | |
bd7f7a65 AC |
3156 | -- Generate object declarations |
3157 | ||
3158 | Decls := New_List ( | |
3159 | Make_Object_Declaration (Loc, | |
3160 | Defining_Identifier => Source_Partition, | |
3161 | Object_Definition => | |
3162 | New_Occurrence_Of (RTE (RE_Partition_ID), Loc)), | |
3163 | ||
3164 | Make_Object_Declaration (Loc, | |
3165 | Defining_Identifier => Source_Receiver, | |
3166 | Object_Definition => | |
3167 | New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), | |
3168 | ||
3169 | Make_Object_Declaration (Loc, | |
3170 | Defining_Identifier => Source_Address, | |
3171 | Object_Definition => | |
3172 | New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), | |
3173 | ||
3174 | Make_Object_Declaration (Loc, | |
3175 | Defining_Identifier => Local_Stub, | |
3176 | Aliased_Present => True, | |
3177 | Object_Definition => New_Occurrence_Of (Stub_Type, Loc)), | |
3178 | ||
3179 | Make_Object_Declaration (Loc, | |
3180 | Defining_Identifier => Stubbed_Result, | |
3181 | Object_Definition => | |
3182 | New_Occurrence_Of (Stub_Type_Access, Loc), | |
3183 | Expression => | |
3184 | Make_Attribute_Reference (Loc, | |
3185 | Prefix => | |
3186 | New_Occurrence_Of (Local_Stub, Loc), | |
3187 | Attribute_Name => | |
3188 | Name_Unchecked_Access))); | |
3189 | ||
3190 | -- Read the source Partition_ID and RPC_Receiver from incoming stream | |
3191 | ||
7f0b5314 | 3192 | Append_List_To (Statements, New_List ( |
bd7f7a65 AC |
3193 | Make_Attribute_Reference (Loc, |
3194 | Prefix => | |
3195 | New_Occurrence_Of (RTE (RE_Partition_ID), Loc), | |
3196 | Attribute_Name => Name_Read, | |
3197 | Expressions => New_List ( | |
3198 | Stream_Parameter, | |
3199 | New_Occurrence_Of (Source_Partition, Loc))), | |
3200 | ||
3201 | Make_Attribute_Reference (Loc, | |
3202 | Prefix => | |
3203 | New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), | |
3204 | Attribute_Name => | |
3205 | Name_Read, | |
3206 | Expressions => New_List ( | |
3207 | Stream_Parameter, | |
3208 | New_Occurrence_Of (Source_Receiver, Loc))), | |
3209 | ||
3210 | Make_Attribute_Reference (Loc, | |
3211 | Prefix => | |
3212 | New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), | |
3213 | Attribute_Name => | |
3214 | Name_Read, | |
3215 | Expressions => New_List ( | |
3216 | Stream_Parameter, | |
7f0b5314 | 3217 | New_Occurrence_Of (Source_Address, Loc))))); |
bd7f7a65 AC |
3218 | |
3219 | -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result | |
3220 | ||
3221 | Set_Etype (Stubbed_Result, Stub_Type_Access); | |
3222 | ||
25e9b6fe | 3223 | -- If the Address is Null_Address, then return a null object, unless |
30783513 | 3224 | -- RACW_Type is null-excluding, in which case unconditionally raise |
25e9b6fe | 3225 | -- CONSTRAINT_ERROR instead. |
bd7f7a65 | 3226 | |
25e9b6fe TQ |
3227 | declare |
3228 | Zero_Statements : List_Id; | |
3229 | -- Statements executed when a zero value is received | |
651a2cb0 | 3230 | |
25e9b6fe TQ |
3231 | begin |
3232 | if Can_Never_Be_Null (RACW_Type) then | |
3233 | Zero_Statements := New_List ( | |
3234 | Make_Raise_Constraint_Error (Loc, | |
3235 | Reason => CE_Null_Not_Allowed)); | |
3236 | else | |
3237 | Zero_Statements := New_List ( | |
3238 | Make_Assignment_Statement (Loc, | |
3239 | Name => Result, | |
3240 | Expression => Make_Null (Loc)), | |
3241 | Make_Simple_Return_Statement (Loc)); | |
3242 | end if; | |
3243 | ||
3244 | Append_To (Statements, | |
3245 | Make_Implicit_If_Statement (RACW_Type, | |
3246 | Condition => | |
3247 | Make_Op_Eq (Loc, | |
3248 | Left_Opnd => New_Occurrence_Of (Source_Address, Loc), | |
3249 | Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), | |
3250 | Then_Statements => Zero_Statements)); | |
3251 | end; | |
bd7f7a65 AC |
3252 | |
3253 | -- If the RACW denotes an object created on the current partition, | |
3254 | -- Local_Statements will be executed. The real object will be used. | |
3255 | ||
3256 | Local_Statements := New_List ( | |
3257 | Make_Assignment_Statement (Loc, | |
3258 | Name => Result, | |
3259 | Expression => | |
3260 | Unchecked_Convert_To (RACW_Type, | |
3261 | OK_Convert_To (RTE (RE_Address), | |
3262 | New_Occurrence_Of (Source_Address, Loc))))); | |
3263 | ||
3264 | -- If the object is located on another partition, then a stub object | |
3265 | -- will be created with all the information needed to rebuild the | |
3266 | -- real object at the other end. | |
3267 | ||
3268 | Remote_Statements := New_List ( | |
3269 | ||
3270 | Make_Assignment_Statement (Loc, | |
3271 | Name => Make_Selected_Component (Loc, | |
16db96c5 AC |
3272 | Prefix => Stubbed_Result, |
3273 | Selector_Name => Name_Origin), | |
bd7f7a65 AC |
3274 | Expression => |
3275 | New_Occurrence_Of (Source_Partition, Loc)), | |
3276 | ||
3277 | Make_Assignment_Statement (Loc, | |
3278 | Name => Make_Selected_Component (Loc, | |
16db96c5 AC |
3279 | Prefix => Stubbed_Result, |
3280 | Selector_Name => Name_Receiver), | |
bd7f7a65 AC |
3281 | Expression => |
3282 | New_Occurrence_Of (Source_Receiver, Loc)), | |
3283 | ||
3284 | Make_Assignment_Statement (Loc, | |
3285 | Name => Make_Selected_Component (Loc, | |
16db96c5 AC |
3286 | Prefix => Stubbed_Result, |
3287 | Selector_Name => Name_Addr), | |
bd7f7a65 AC |
3288 | Expression => |
3289 | New_Occurrence_Of (Source_Address, Loc))); | |
3290 | ||
3291 | Append_To (Remote_Statements, | |
3292 | Make_Assignment_Statement (Loc, | |
3293 | Name => Make_Selected_Component (Loc, | |
16db96c5 AC |
3294 | Prefix => Stubbed_Result, |
3295 | Selector_Name => Name_Asynchronous), | |
bd7f7a65 AC |
3296 | Expression => |
3297 | New_Occurrence_Of (Asynchronous_Flag, Loc))); | |
3298 | ||
3299 | Append_List_To (Remote_Statements, | |
3300 | Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type)); | |
8aa23fe3 TQ |
3301 | -- ??? Issue with asynchronous calls here: the Asynchronous flag is |
3302 | -- set on the stub type if, and only if, the RACW type has a pragma | |
3303 | -- Asynchronous. This is incorrect for RACWs that implement RAS | |
3304 | -- types, because in that case the /designated subprogram/ (not the | |
3305 | -- type) might be asynchronous, and that causes the stub to need to | |
3306 | -- be asynchronous too. A solution is to transport a RAS as a struct | |
3307 | -- containing a RACW and an asynchronous flag, and to properly alter | |
3308 | -- the Asynchronous component in the stub type in the RAS's Input | |
3309 | -- TSS. | |
bd7f7a65 AC |
3310 | |
3311 | Append_To (Remote_Statements, | |
3312 | Make_Assignment_Statement (Loc, | |
3313 | Name => Result, | |
3314 | Expression => Unchecked_Convert_To (RACW_Type, | |
3315 | New_Occurrence_Of (Stubbed_Result, Loc)))); | |
3316 | ||
3317 | -- Distinguish between the local and remote cases, and execute the | |
3318 | -- appropriate piece of code. | |
3319 | ||
3320 | Append_To (Statements, | |
3321 | Make_Implicit_If_Statement (RACW_Type, | |
3322 | Condition => | |
3323 | Make_Op_Eq (Loc, | |
3324 | Left_Opnd => | |
3325 | Make_Function_Call (Loc, | |
3326 | Name => New_Occurrence_Of ( | |
3327 | RTE (RE_Get_Local_Partition_Id), Loc)), | |
3328 | Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)), | |
3329 | Then_Statements => Local_Statements, | |
3330 | Else_Statements => Remote_Statements)); | |
3331 | ||
bd7f7a65 | 3332 | Set_Declarations (Body_Node, Decls); |
8aa23fe3 | 3333 | Append_To (Body_Decls, Body_Node); |
bd7f7a65 AC |
3334 | end Add_RACW_Read_Attribute; |
3335 | ||
3336 | ------------------------------ | |
3337 | -- Add_RACW_Write_Attribute -- | |
3338 | ------------------------------ | |
3339 | ||
3340 | procedure Add_RACW_Write_Attribute | |
3341 | (RACW_Type : Entity_Id; | |
3342 | Stub_Type : Entity_Id; | |
3343 | Stub_Type_Access : Entity_Id; | |
3344 | RPC_Receiver : Node_Id; | |
8aa23fe3 | 3345 | Body_Decls : List_Id) |
bd7f7a65 AC |
3346 | is |
3347 | Body_Node : Node_Id; | |
3348 | Proc_Decl : Node_Id; | |
3349 | Attr_Decl : Node_Id; | |
3350 | ||
7f0b5314 | 3351 | Statements : constant List_Id := New_List; |
bd7f7a65 AC |
3352 | Local_Statements : List_Id; |
3353 | Remote_Statements : List_Id; | |
3354 | Null_Statements : List_Id; | |
3355 | ||
2287a75d | 3356 | Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); |
bd7f7a65 AC |
3357 | |
3358 | begin | |
7f0b5314 TQ |
3359 | Build_Stream_Procedure |
3360 | (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); | |
3361 | ||
3362 | Proc_Decl := Make_Subprogram_Declaration (Loc, | |
3363 | Copy_Specification (Loc, Specification (Body_Node))); | |
3364 | ||
3365 | Attr_Decl := | |
3366 | Make_Attribute_Definition_Clause (Loc, | |
3367 | Name => New_Occurrence_Of (RACW_Type, Loc), | |
3368 | Chars => Name_Write, | |
3369 | Expression => | |
3370 | New_Occurrence_Of ( | |
3371 | Defining_Unit_Name (Specification (Proc_Decl)), Loc)); | |
3372 | ||
3373 | Insert_After (Declaration_Node (RACW_Type), Proc_Decl); | |
3374 | Insert_After (Proc_Decl, Attr_Decl); | |
3375 | ||
3376 | if No (Body_Decls) then | |
3377 | return; | |
3378 | end if; | |
3379 | ||
bd7f7a65 AC |
3380 | -- Build the code fragment corresponding to the marshalling of a |
3381 | -- local object. | |
3382 | ||
3383 | Local_Statements := New_List ( | |
3384 | ||
3385 | Pack_Entity_Into_Stream_Access (Loc, | |
3386 | Stream => Stream_Parameter, | |
3387 | Object => RTE (RE_Get_Local_Partition_Id)), | |
3388 | ||
3389 | Pack_Node_Into_Stream_Access (Loc, | |
3390 | Stream => Stream_Parameter, | |
3391 | Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), | |
3392 | Etyp => RTE (RE_Unsigned_64)), | |
3393 | ||
3394 | Pack_Node_Into_Stream_Access (Loc, | |
3395 | Stream => Stream_Parameter, | |
3396 | Object => OK_Convert_To (RTE (RE_Unsigned_64), | |
3397 | Make_Attribute_Reference (Loc, | |
3398 | Prefix => | |
3399 | Make_Explicit_Dereference (Loc, | |
3400 | Prefix => Object), | |
3401 | Attribute_Name => Name_Address)), | |
3402 | Etyp => RTE (RE_Unsigned_64))); | |
3403 | ||
3404 | -- Build the code fragment corresponding to the marshalling of | |
3405 | -- a remote object. | |
3406 | ||
3407 | Remote_Statements := New_List ( | |
bd7f7a65 | 3408 | Pack_Node_Into_Stream_Access (Loc, |
d693e39d TQ |
3409 | Stream => Stream_Parameter, |
3410 | Object => | |
bd7f7a65 | 3411 | Make_Selected_Component (Loc, |
d693e39d TQ |
3412 | Prefix => |
3413 | Unchecked_Convert_To (Stub_Type_Access, Object), | |
3414 | Selector_Name => Make_Identifier (Loc, Name_Origin)), | |
3415 | Etyp => RTE (RE_Partition_ID)), | |
bd7f7a65 AC |
3416 | |
3417 | Pack_Node_Into_Stream_Access (Loc, | |
3418 | Stream => Stream_Parameter, | |
3419 | Object => | |
3420 | Make_Selected_Component (Loc, | |
d693e39d TQ |
3421 | Prefix => |
3422 | Unchecked_Convert_To (Stub_Type_Access, Object), | |
3423 | Selector_Name => Make_Identifier (Loc, Name_Receiver)), | |
bd7f7a65 AC |
3424 | Etyp => RTE (RE_Unsigned_64)), |
3425 | ||
3426 | Pack_Node_Into_Stream_Access (Loc, | |
3427 | Stream => Stream_Parameter, | |
3428 | Object => | |
3429 | Make_Selected_Component (Loc, | |
d693e39d TQ |
3430 | Prefix => |
3431 | Unchecked_Convert_To (Stub_Type_Access, Object), | |
3432 | Selector_Name => Make_Identifier (Loc, Name_Addr)), | |
bd7f7a65 AC |
3433 | Etyp => RTE (RE_Unsigned_64))); |
3434 | ||
3435 | -- Build code fragment corresponding to marshalling of a null object | |
3436 | ||
3437 | Null_Statements := New_List ( | |
3438 | ||
3439 | Pack_Entity_Into_Stream_Access (Loc, | |
3440 | Stream => Stream_Parameter, | |
3441 | Object => RTE (RE_Get_Local_Partition_Id)), | |
3442 | ||
3443 | Pack_Node_Into_Stream_Access (Loc, | |
3444 | Stream => Stream_Parameter, | |
3445 | Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), | |
3446 | Etyp => RTE (RE_Unsigned_64)), | |
3447 | ||
3448 | Pack_Node_Into_Stream_Access (Loc, | |
3449 | Stream => Stream_Parameter, | |
3450 | Object => Make_Integer_Literal (Loc, Uint_0), | |
3451 | Etyp => RTE (RE_Unsigned_64))); | |
3452 | ||
7f0b5314 | 3453 | Append_To (Statements, |
bd7f7a65 AC |
3454 | Make_Implicit_If_Statement (RACW_Type, |
3455 | Condition => | |
3456 | Make_Op_Eq (Loc, | |
3457 | Left_Opnd => Object, | |
3458 | Right_Opnd => Make_Null (Loc)), | |
d693e39d | 3459 | |
bd7f7a65 | 3460 | Then_Statements => Null_Statements, |
d693e39d | 3461 | |
bd7f7a65 AC |
3462 | Elsif_Parts => New_List ( |
3463 | Make_Elsif_Part (Loc, | |
3464 | Condition => | |
3465 | Make_Op_Eq (Loc, | |
3466 | Left_Opnd => | |
3467 | Make_Attribute_Reference (Loc, | |
3468 | Prefix => Object, | |
3469 | Attribute_Name => Name_Tag), | |
d693e39d | 3470 | |
bd7f7a65 AC |
3471 | Right_Opnd => |
3472 | Make_Attribute_Reference (Loc, | |
3473 | Prefix => New_Occurrence_Of (Stub_Type, Loc), | |
3474 | Attribute_Name => Name_Tag)), | |
3475 | Then_Statements => Remote_Statements)), | |
3476 | Else_Statements => Local_Statements)); | |
3477 | ||
8aa23fe3 | 3478 | Append_To (Body_Decls, Body_Node); |
bd7f7a65 AC |
3479 | end Add_RACW_Write_Attribute; |
3480 | ||
3481 | ------------------------ | |
3482 | -- Add_RAS_Access_TSS -- | |
3483 | ------------------------ | |
3484 | ||
3485 | procedure Add_RAS_Access_TSS (N : Node_Id) is | |
3486 | Loc : constant Source_Ptr := Sloc (N); | |
3487 | ||
3488 | Ras_Type : constant Entity_Id := Defining_Identifier (N); | |
3489 | Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); | |
3490 | -- Ras_Type is the access to subprogram type while Fat_Type is the | |
3491 | -- corresponding record type. | |
3492 | ||
3493 | RACW_Type : constant Entity_Id := | |
3494 | Underlying_RACW_Type (Ras_Type); | |
3495 | Desig : constant Entity_Id := | |
3496 | Etype (Designated_Type (RACW_Type)); | |
3497 | ||
3498 | Stub_Elements : constant Stub_Structure := | |
3499 | Stubs_Table.Get (Desig); | |
3500 | pragma Assert (Stub_Elements /= Empty_Stub_Structure); | |
3501 | ||
3502 | Proc : constant Entity_Id := | |
3503 | Make_Defining_Identifier (Loc, | |
3504 | Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); | |
3505 | ||
3506 | Proc_Spec : Node_Id; | |
3507 | ||
3508 | -- Formal parameters | |
3509 | ||
3510 | Package_Name : constant Entity_Id := | |
3511 | Make_Defining_Identifier (Loc, | |
3512 | Chars => Name_P); | |
3513 | -- Target package | |
3514 | ||
3515 | Subp_Id : constant Entity_Id := | |
3516 | Make_Defining_Identifier (Loc, | |
3517 | Chars => Name_S); | |
3518 | -- Target subprogram | |
3519 | ||
3520 | Asynch_P : constant Entity_Id := | |
3521 | Make_Defining_Identifier (Loc, | |
3522 | Chars => Name_Asynchronous); | |
3523 | -- Is the procedure to which the 'Access applies asynchronous? | |
3524 | ||
3525 | All_Calls_Remote : constant Entity_Id := | |
3526 | Make_Defining_Identifier (Loc, | |
3527 | Chars => Name_All_Calls_Remote); | |
3528 | -- True if an All_Calls_Remote pragma applies to the RCI unit | |
3529 | -- that contains the subprogram. | |
3530 | ||
3531 | -- Common local variables | |
3532 | ||
3533 | Proc_Decls : List_Id; | |
3534 | Proc_Statements : List_Id; | |
3535 | ||
2287a75d | 3536 | Origin : constant Entity_Id := Make_Temporary (Loc, 'P'); |
bd7f7a65 AC |
3537 | |
3538 | -- Additional local variables for the local case | |
3539 | ||
2287a75d | 3540 | Proxy_Addr : constant Entity_Id := Make_Temporary (Loc, 'P'); |
bd7f7a65 AC |
3541 | |
3542 | -- Additional local variables for the remote case | |
3543 | ||
2287a75d AC |
3544 | Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L'); |
3545 | Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S'); | |
bd7f7a65 AC |
3546 | |
3547 | function Set_Field | |
3548 | (Field_Name : Name_Id; | |
3549 | Value : Node_Id) return Node_Id; | |
3550 | -- Construct an assignment that sets the named component in the | |
3551 | -- returned record | |
3552 | ||
3553 | --------------- | |
3554 | -- Set_Field -- | |
3555 | --------------- | |
3556 | ||
3557 | function Set_Field | |
3558 | (Field_Name : Name_Id; | |
3559 | Value : Node_Id) return Node_Id | |
3560 | is | |
3561 | begin | |
3562 | return | |
3563 | Make_Assignment_Statement (Loc, | |
3564 | Name => | |
3565 | Make_Selected_Component (Loc, | |
16db96c5 AC |
3566 | Prefix => Stub_Ptr, |
3567 | Selector_Name => Field_Name), | |
bd7f7a65 AC |
3568 | Expression => Value); |
3569 | end Set_Field; | |
3570 | ||
3571 | -- Start of processing for Add_RAS_Access_TSS | |
3572 | ||
3573 | begin | |
3574 | Proc_Decls := New_List ( | |
3575 | ||
d693e39d | 3576 | -- Common declarations |
bd7f7a65 AC |
3577 | |
3578 | Make_Object_Declaration (Loc, | |
3579 | Defining_Identifier => Origin, | |
3580 | Constant_Present => True, | |
3581 | Object_Definition => | |
3582 | New_Occurrence_Of (RTE (RE_Partition_ID), Loc), | |
3583 | Expression => | |
3584 | Make_Function_Call (Loc, | |
3585 | Name => | |
3586 | New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc), | |
3587 | Parameter_Associations => New_List ( | |
3588 | New_Occurrence_Of (Package_Name, Loc)))), | |
3589 | ||
d693e39d | 3590 | -- Declaration use only in the local case: proxy address |
bd7f7a65 AC |
3591 | |
3592 | Make_Object_Declaration (Loc, | |
3593 | Defining_Identifier => Proxy_Addr, | |
3594 | Object_Definition => | |
3595 | New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), | |
3596 | ||
d693e39d TQ |
3597 | -- Declarations used only in the remote case: stub object and |
3598 | -- stub pointer. | |
bd7f7a65 AC |
3599 | |
3600 | Make_Object_Declaration (Loc, | |
3601 | Defining_Identifier => Local_Stub, | |
3602 | Aliased_Present => True, | |
3603 | Object_Definition => | |
3604 | New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), | |
3605 | ||
3606 | Make_Object_Declaration (Loc, | |
3607 | Defining_Identifier => | |
3608 | Stub_Ptr, | |
3609 | Object_Definition => | |
3610 | New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), | |
3611 | Expression => | |
3612 | Make_Attribute_Reference (Loc, | |
3613 | Prefix => New_Occurrence_Of (Local_Stub, Loc), | |
3614 | Attribute_Name => Name_Unchecked_Access))); | |
3615 | ||
3616 | Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); | |
d693e39d TQ |
3617 | |
3618 | -- Build_Get_Unique_RP_Call needs above information | |
bd7f7a65 AC |
3619 | |
3620 | -- Note: Here we assume that the Fat_Type is a record | |
3621 | -- containing just a pointer to a proxy or stub object. | |
3622 | ||
3623 | Proc_Statements := New_List ( | |
3624 | ||
3625 | -- Generate: | |
3626 | ||
3627 | -- Get_RAS_Info (Pkg, Subp, PA); | |
3628 | -- if Origin = Local_Partition_Id | |
3629 | -- and then not All_Calls_Remote | |
3630 | -- then | |
3631 | -- return Fat_Type!(PA); | |
3632 | -- end if; | |
3633 | ||
3634 | Make_Procedure_Call_Statement (Loc, | |
d693e39d | 3635 | Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), |
bd7f7a65 AC |
3636 | Parameter_Associations => New_List ( |
3637 | New_Occurrence_Of (Package_Name, Loc), | |
3638 | New_Occurrence_Of (Subp_Id, Loc), | |
3639 | New_Occurrence_Of (Proxy_Addr, Loc))), | |
3640 | ||
3641 | Make_Implicit_If_Statement (N, | |
3642 | Condition => | |
3643 | Make_And_Then (Loc, | |
3644 | Left_Opnd => | |
3645 | Make_Op_Eq (Loc, | |
3646 | Left_Opnd => | |
3647 | New_Occurrence_Of (Origin, Loc), | |
3648 | Right_Opnd => | |
3649 | Make_Function_Call (Loc, | |
3650 | New_Occurrence_Of ( | |
3651 | RTE (RE_Get_Local_Partition_Id), Loc))), | |
d693e39d | 3652 | |
bd7f7a65 AC |
3653 | Right_Opnd => |
3654 | Make_Op_Not (Loc, | |
3655 | New_Occurrence_Of (All_Calls_Remote, Loc))), | |
d693e39d | 3656 | |
bd7f7a65 | 3657 | Then_Statements => New_List ( |
bfc2cdb1 | 3658 | Make_Simple_Return_Statement (Loc, |
bd7f7a65 AC |
3659 | Unchecked_Convert_To (Fat_Type, |
3660 | OK_Convert_To (RTE (RE_Address), | |
3661 | New_Occurrence_Of (Proxy_Addr, Loc)))))), | |
3662 | ||
3663 | Set_Field (Name_Origin, | |
3664 | New_Occurrence_Of (Origin, Loc)), | |
3665 | ||
3666 | Set_Field (Name_Receiver, | |
3667 | Make_Function_Call (Loc, | |
3668 | Name => | |
3669 | New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc), | |
3670 | Parameter_Associations => New_List ( | |
3671 | New_Occurrence_Of (Package_Name, Loc)))), | |
3672 | ||
3673 | Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)), | |
3674 | ||
d693e39d TQ |
3675 | -- E.4.1(9) A remote call is asynchronous if it is a call to |
3676 | -- a procedure or a call through a value of an access-to-procedure | |
3677 | -- type to which a pragma Asynchronous applies. | |
bd7f7a65 | 3678 | |
d693e39d TQ |
3679 | -- Asynch_P is true when the procedure is asynchronous; |
3680 | -- Asynch_T is true when the type is asynchronous. | |
bd7f7a65 AC |
3681 | |
3682 | Set_Field (Name_Asynchronous, | |
3683 | Make_Or_Else (Loc, | |
3684 | New_Occurrence_Of (Asynch_P, Loc), | |
3685 | New_Occurrence_Of (Boolean_Literals ( | |
3686 | Is_Asynchronous (Ras_Type)), Loc)))); | |
3687 | ||
3688 | Append_List_To (Proc_Statements, | |
3689 | Build_Get_Unique_RP_Call | |
3690 | (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); | |
3691 | ||
3692 | -- Return the newly created value | |
3693 | ||
3694 | Append_To (Proc_Statements, | |
bfc2cdb1 | 3695 | Make_Simple_Return_Statement (Loc, |
bd7f7a65 AC |
3696 | Expression => |
3697 | Unchecked_Convert_To (Fat_Type, | |
3698 | New_Occurrence_Of (Stub_Ptr, Loc)))); | |
3699 | ||
3700 | Proc_Spec := | |
3701 | Make_Function_Specification (Loc, | |
3702 | Defining_Unit_Name => Proc, | |
3703 | Parameter_Specifications => New_List ( | |
3704 | Make_Parameter_Specification (Loc, | |
3705 | Defining_Identifier => Package_Name, | |
3706 | Parameter_Type => | |
3707 | New_Occurrence_Of (Standard_String, Loc)), | |
3708 | ||
3709 | Make_Parameter_Specification (Loc, | |
3710 | Defining_Identifier => Subp_Id, | |
3711 | Parameter_Type => | |
3712 | New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)), | |
3713 | ||
3714 | Make_Parameter_Specification (Loc, | |
3715 | Defining_Identifier => Asynch_P, | |
3716 | Parameter_Type => | |
3717 | New_Occurrence_Of (Standard_Boolean, Loc)), | |
3718 | ||
3719 | Make_Parameter_Specification (Loc, | |
3720 | Defining_Identifier => All_Calls_Remote, | |
3721 | Parameter_Type => | |
3722 | New_Occurrence_Of (Standard_Boolean, Loc))), | |
3723 | ||
3eb8fddc | 3724 | Result_Definition => |
bd7f7a65 AC |
3725 | New_Occurrence_Of (Fat_Type, Loc)); |
3726 | ||
3727 | -- Set the kind and return type of the function to prevent | |
3728 | -- ambiguities between Ras_Type and Fat_Type in subsequent analysis. | |
3729 | ||
3730 | Set_Ekind (Proc, E_Function); | |
3731 | Set_Etype (Proc, Fat_Type); | |
3732 | ||
3733 | Discard_Node ( | |
3734 | Make_Subprogram_Body (Loc, | |
3735 | Specification => Proc_Spec, | |
3736 | Declarations => Proc_Decls, | |
3737 | Handled_Statement_Sequence => | |
3738 | Make_Handled_Sequence_Of_Statements (Loc, | |
3739 | Statements => Proc_Statements))); | |
3740 | ||
3741 | Set_TSS (Fat_Type, Proc); | |
3742 | end Add_RAS_Access_TSS; | |
3743 | ||
3744 | ----------------------- | |
3745 | -- Add_RAST_Features -- | |
3746 | ----------------------- | |
3747 | ||
3748 | procedure Add_RAST_Features | |
3749 | (Vis_Decl : Node_Id; | |
c857f5ed | 3750 | RAS_Type : Entity_Id) |
bd7f7a65 | 3751 | is |
c857f5ed | 3752 | pragma Unreferenced (RAS_Type); |
bd7f7a65 AC |
3753 | begin |
3754 | Add_RAS_Access_TSS (Vis_Decl); | |
3755 | end Add_RAST_Features; | |
3756 | ||
16db96c5 AC |
3757 | ----------------------------------------- |
3758 | -- Add_Receiving_Stubs_To_Declarations -- | |
3759 | ----------------------------------------- | |
bd7f7a65 | 3760 | |
16db96c5 AC |
3761 | procedure Add_Receiving_Stubs_To_Declarations |
3762 | (Pkg_Spec : Node_Id; | |
8aa23fe3 TQ |
3763 | Decls : List_Id; |
3764 | Stmts : List_Id) | |
16db96c5 AC |
3765 | is |
3766 | Loc : constant Source_Ptr := Sloc (Pkg_Spec); | |
3767 | ||
3768 | Request_Parameter : Node_Id; | |
3769 | ||
3770 | Pkg_RPC_Receiver : constant Entity_Id := | |
2287a75d | 3771 | Make_Temporary (Loc, 'H'); |
16db96c5 AC |
3772 | Pkg_RPC_Receiver_Statements : List_Id; |
3773 | Pkg_RPC_Receiver_Cases : constant List_Id := New_List; | |
3774 | Pkg_RPC_Receiver_Body : Node_Id; | |
3775 | -- A Pkg_RPC_Receiver is built to decode the request | |
3776 | ||
ff2efe85 | 3777 | Lookup_RAS : Node_Id; |
2287a75d AC |
3778 | Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R'); |
3779 | -- A remote subprogram is created to allow peers to look up RAS | |
3780 | -- information using subprogram ids. | |
16db96c5 AC |
3781 | |
3782 | Subp_Id : Entity_Id; | |
3783 | Subp_Index : Entity_Id; | |
3784 | -- Subprogram_Id as read from the incoming stream | |
3785 | ||
ff2efe85 AC |
3786 | Current_Subp_Number : Int := First_RCI_Subprogram_Id; |
3787 | Current_Stubs : Node_Id; | |
16db96c5 | 3788 | |
2287a75d AC |
3789 | Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); |
3790 | Subp_Info_List : constant List_Id := New_List; | |
16db96c5 AC |
3791 | |
3792 | Register_Pkg_Actuals : constant List_Id := New_List; | |
3793 | ||
3794 | All_Calls_Remote_E : Entity_Id; | |
3795 | Proxy_Object_Addr : Entity_Id; | |
3796 | ||
3797 | procedure Append_Stubs_To | |
3798 | (RPC_Receiver_Cases : List_Id; | |
3799 | Stubs : Node_Id; | |
3800 | Subprogram_Number : Int); | |
3801 | -- Add one case to the specified RPC receiver case list | |
3802 | -- associating Subprogram_Number with the subprogram declared | |
3803 | -- by Declaration, for which we have receiving stubs in Stubs. | |
3804 | ||
ff2efe85 AC |
3805 | procedure Visit_Subprogram (Decl : Node_Id); |
3806 | -- Generate receiving stub for one remote subprogram | |
3807 | ||
16db96c5 AC |
3808 | --------------------- |
3809 | -- Append_Stubs_To -- | |
3810 | --------------------- | |
3811 | ||
3812 | procedure Append_Stubs_To | |
3813 | (RPC_Receiver_Cases : List_Id; | |
3814 | Stubs : Node_Id; | |
3815 | Subprogram_Number : Int) | |
3816 | is | |
3817 | begin | |
3818 | Append_To (RPC_Receiver_Cases, | |
3819 | Make_Case_Statement_Alternative (Loc, | |
3820 | Discrete_Choices => | |
3821 | New_List (Make_Integer_Literal (Loc, Subprogram_Number)), | |
3822 | Statements => | |
3823 | New_List ( | |
3824 | Make_Procedure_Call_Statement (Loc, | |
3825 | Name => | |
d693e39d | 3826 | New_Occurrence_Of (Defining_Entity (Stubs), Loc), |
16db96c5 AC |
3827 | Parameter_Associations => New_List ( |
3828 | New_Occurrence_Of (Request_Parameter, Loc)))))); | |
3829 | end Append_Stubs_To; | |
3830 | ||
ff2efe85 AC |
3831 | ---------------------- |
3832 | -- Visit_Subprogram -- | |
3833 | ---------------------- | |
3834 | ||
3835 | procedure Visit_Subprogram (Decl : Node_Id) is | |
3836 | Loc : constant Source_Ptr := Sloc (Decl); | |
3837 | Spec : constant Node_Id := Specification (Decl); | |
3838 | Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec); | |
3839 | ||
3840 | Subp_Val : String_Id; | |
3841 | pragma Warnings (Off, Subp_Val); | |
3842 | ||
3843 | begin | |
9fde638d RD |
3844 | -- Disable expansion of stubs if serious errors have been |
3845 | -- diagnosed, because otherwise some illegal remote subprogram | |
3846 | -- declarations could cause cascaded errors in stubs. | |
3847 | ||
170b2989 AC |
3848 | if Serious_Errors_Detected /= 0 then |
3849 | return; | |
3850 | end if; | |
3851 | ||
ff2efe85 AC |
3852 | -- Build receiving stub |
3853 | ||
3854 | Current_Stubs := | |
3855 | Build_Subprogram_Receiving_Stubs | |
3856 | (Vis_Decl => Decl, | |
3857 | Asynchronous => | |
3858 | Nkind (Spec) = N_Procedure_Specification | |
3859 | and then Is_Asynchronous (Subp_Def)); | |
3860 | ||
3861 | Append_To (Decls, Current_Stubs); | |
3862 | Analyze (Current_Stubs); | |
3863 | ||
3864 | -- Build RAS proxy | |
3865 | ||
3866 | Add_RAS_Proxy_And_Analyze (Decls, | |
3867 | Vis_Decl => Decl, | |
3868 | All_Calls_Remote_E => All_Calls_Remote_E, | |
3869 | Proxy_Object_Addr => Proxy_Object_Addr); | |
3870 | ||
3871 | -- Compute distribution identifier | |
3872 | ||
3873 | Assign_Subprogram_Identifier | |
a3068ca6 | 3874 | (Subp_Def, Current_Subp_Number, Subp_Val); |
ff2efe85 AC |
3875 | |
3876 | pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); | |
3877 | ||
3878 | -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms | |
3879 | -- table for this receiver. This aggregate must be kept consistent | |
3880 | -- with the declaration of RCI_Subp_Info in | |
3881 | -- System.Partition_Interface. | |
3882 | ||
3883 | Append_To (Subp_Info_List, | |
3884 | Make_Component_Association (Loc, | |
3885 | Choices => New_List ( | |
3886 | Make_Integer_Literal (Loc, Current_Subp_Number)), | |
3887 | ||
3888 | Expression => | |
3889 | Make_Aggregate (Loc, | |
3890 | Component_Associations => New_List ( | |
3891 | ||
3892 | -- Addr => | |
3893 | ||
3894 | Make_Component_Association (Loc, | |
3895 | Choices => | |
3896 | New_List (Make_Identifier (Loc, Name_Addr)), | |
3897 | Expression => | |
3898 | New_Occurrence_Of (Proxy_Object_Addr, Loc)))))); | |
3899 | ||
3900 | Append_Stubs_To (Pkg_RPC_Receiver_Cases, | |
3901 | Stubs => Current_Stubs, | |
3902 | Subprogram_Number => Current_Subp_Number); | |
3903 | ||
3904 | Current_Subp_Number := Current_Subp_Number + 1; | |
3905 | end Visit_Subprogram; | |
3906 | ||
3907 | procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); | |
3908 | ||
16db96c5 AC |
3909 | -- Start of processing for Add_Receiving_Stubs_To_Declarations |
3910 | ||
3911 | begin | |
3912 | -- Building receiving stubs consist in several operations: | |
3913 | ||
3914 | -- - a package RPC receiver must be built. This subprogram | |
3915 | -- will get a Subprogram_Id from the incoming stream | |
c3d593c9 | 3916 | -- and will dispatch the call to the right subprogram; |
16db96c5 | 3917 | |
c3d593c9 | 3918 | -- - a receiving stub for each subprogram visible in the package |
16db96c5 AC |
3919 | -- spec. This stub will read all the parameters from the stream, |
3920 | -- and put the result as well as the exception occurrence in the | |
c3d593c9 | 3921 | -- output stream; |
16db96c5 AC |
3922 | |
3923 | -- - a dummy package with an empty spec and a body made of an | |
3924 | -- elaboration part, whose job is to register the receiving | |
3925 | -- part of this RCI package on the name server. This is done | |
c3d593c9 | 3926 | -- by calling System.Partition_Interface.Register_Receiving_Stub. |
16db96c5 AC |
3927 | |
3928 | Build_RPC_Receiver_Body ( | |
3929 | RPC_Receiver => Pkg_RPC_Receiver, | |
3930 | Request => Request_Parameter, | |
3931 | Subp_Id => Subp_Id, | |
3932 | Subp_Index => Subp_Index, | |
3933 | Stmts => Pkg_RPC_Receiver_Statements, | |
3934 | Decl => Pkg_RPC_Receiver_Body); | |
3935 | pragma Assert (Subp_Id = Subp_Index); | |
3936 | ||
3937 | -- A null subp_id denotes a call through a RAS, in which case the | |
3938 | -- next Uint_64 element in the stream is the address of the local | |
3939 | -- proxy object, from which we can retrieve the actual subprogram id. | |
3940 | ||
3941 | Append_To (Pkg_RPC_Receiver_Statements, | |
3942 | Make_Implicit_If_Statement (Pkg_Spec, | |
3943 | Condition => | |
3944 | Make_Op_Eq (Loc, | |
3945 | New_Occurrence_Of (Subp_Id, Loc), | |
3946 | Make_Integer_Literal (Loc, 0)), | |
d693e39d | 3947 | |
16db96c5 AC |
3948 | Then_Statements => New_List ( |
3949 | Make_Assignment_Statement (Loc, | |
3950 | Name => | |
3951 | New_Occurrence_Of (Subp_Id, Loc), | |
d693e39d | 3952 | |
16db96c5 AC |
3953 | Expression => |
3954 | Make_Selected_Component (Loc, | |
3955 | Prefix => | |
3956 | Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), | |
3957 | OK_Convert_To (RTE (RE_Address), | |
3958 | Make_Attribute_Reference (Loc, | |
3959 | Prefix => | |
3960 | New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), | |
3961 | Attribute_Name => | |
3962 | Name_Input, | |
3963 | Expressions => New_List ( | |
3964 | Make_Selected_Component (Loc, | |
3965 | Prefix => Request_Parameter, | |
3966 | Selector_Name => Name_Params))))), | |
d693e39d | 3967 | |
7675ad4f | 3968 | Selector_Name => Make_Identifier (Loc, Name_Subp_Id)))))); |
16db96c5 AC |
3969 | |
3970 | -- Build a subprogram for RAS information lookups | |
3971 | ||
ff2efe85 | 3972 | Lookup_RAS := |
16db96c5 AC |
3973 | Make_Subprogram_Declaration (Loc, |
3974 | Specification => | |
3975 | Make_Function_Specification (Loc, | |
3976 | Defining_Unit_Name => | |
3977 | Lookup_RAS_Info, | |
3978 | Parameter_Specifications => New_List ( | |
3979 | Make_Parameter_Specification (Loc, | |
3980 | Defining_Identifier => | |
3981 | Make_Defining_Identifier (Loc, Name_Subp_Id), | |
3982 | In_Present => | |
3983 | True, | |
3984 | Parameter_Type => | |
3985 | New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))), | |
3eb8fddc | 3986 | Result_Definition => |
16db96c5 | 3987 | New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))); |
ff2efe85 AC |
3988 | Append_To (Decls, Lookup_RAS); |
3989 | Analyze (Lookup_RAS); | |
16db96c5 AC |
3990 | |
3991 | Current_Stubs := Build_Subprogram_Receiving_Stubs | |
ff2efe85 | 3992 | (Vis_Decl => Lookup_RAS, |
16db96c5 AC |
3993 | Asynchronous => False); |
3994 | Append_To (Decls, Current_Stubs); | |
3995 | Analyze (Current_Stubs); | |
3996 | ||
3997 | Append_Stubs_To (Pkg_RPC_Receiver_Cases, | |
ff2efe85 | 3998 | Stubs => Current_Stubs, |
16db96c5 AC |
3999 | Subprogram_Number => 1); |
4000 | ||
4001 | -- For each subprogram, the receiving stub will be built and a | |
4002 | -- case statement will be made on the Subprogram_Id to dispatch | |
4003 | -- to the right subprogram. | |
4004 | ||
2cd6f54e TQ |
4005 | All_Calls_Remote_E := |
4006 | Boolean_Literals | |
4007 | (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); | |
16db96c5 AC |
4008 | |
4009 | Overload_Counter_Table.Reset; | |
4010 | ||
ff2efe85 | 4011 | Visit_Spec (Pkg_Spec); |
16db96c5 AC |
4012 | |
4013 | -- If we receive an invalid Subprogram_Id, it is best to do nothing | |
4014 | -- rather than raising an exception since we do not want someone | |
4015 | -- to crash a remote partition by sending invalid subprogram ids. | |
4016 | -- This is consistent with the other parts of the case statement | |
4017 | -- since even in presence of incorrect parameters in the stream, | |
4018 | -- every exception will be caught and (if the subprogram is not an | |
4019 | -- APC) put into the result stream and sent away. | |
4020 | ||
4021 | Append_To (Pkg_RPC_Receiver_Cases, | |
4022 | Make_Case_Statement_Alternative (Loc, | |
d693e39d TQ |
4023 | Discrete_Choices => New_List (Make_Others_Choice (Loc)), |
4024 | Statements => New_List (Make_Null_Statement (Loc)))); | |
16db96c5 AC |
4025 | |
4026 | Append_To (Pkg_RPC_Receiver_Statements, | |
4027 | Make_Case_Statement (Loc, | |
d693e39d | 4028 | Expression => New_Occurrence_Of (Subp_Id, Loc), |
16db96c5 AC |
4029 | Alternatives => Pkg_RPC_Receiver_Cases)); |
4030 | ||
4031 | Append_To (Decls, | |
4032 | Make_Object_Declaration (Loc, | |
4033 | Defining_Identifier => Subp_Info_Array, | |
4034 | Constant_Present => True, | |
4035 | Aliased_Present => True, | |
4036 | Object_Definition => | |
4037 | Make_Subtype_Indication (Loc, | |
4038 | Subtype_Mark => | |
4039 | New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), | |
4040 | Constraint => | |
4041 | Make_Index_Or_Discriminant_Constraint (Loc, | |
4042 | New_List ( | |
4043 | Make_Range (Loc, | |
4044 | Low_Bound => Make_Integer_Literal (Loc, | |
4045 | First_RCI_Subprogram_Id), | |
4046 | High_Bound => | |
4047 | Make_Integer_Literal (Loc, | |
d693e39d TQ |
4048 | Intval => |
4049 | First_RCI_Subprogram_Id | |
4050 | + List_Length (Subp_Info_List) - 1))))))); | |
c3d593c9 TQ |
4051 | |
4052 | -- For a degenerate RCI with no visible subprograms, Subp_Info_List | |
4053 | -- has zero length, and the declaration is for an empty array, in | |
4054 | -- which case no initialization aggregate must be generated. | |
4055 | ||
4056 | if Present (First (Subp_Info_List)) then | |
4057 | Set_Expression (Last (Decls), | |
4058 | Make_Aggregate (Loc, | |
4059 | Component_Associations => Subp_Info_List)); | |
4060 | ||
4061 | -- No initialization provided: remove CONSTANT so that the | |
4062 | -- declaration is not an incomplete deferred constant. | |
4063 | ||
4064 | else | |
4065 | Set_Constant_Present (Last (Decls), False); | |
4066 | end if; | |
4067 | ||
16db96c5 AC |
4068 | Analyze (Last (Decls)); |
4069 | ||
c3d593c9 TQ |
4070 | declare |
4071 | Subp_Info_Addr : Node_Id; | |
4072 | -- Return statement for Lookup_RAS_Info: address of the subprogram | |
4073 | -- information record for the requested subprogram id. | |
4074 | ||
4075 | begin | |
4076 | if Present (First (Subp_Info_List)) then | |
4077 | Subp_Info_Addr := | |
4078 | Make_Selected_Component (Loc, | |
4079 | Prefix => | |
4080 | Make_Indexed_Component (Loc, | |
d693e39d | 4081 | Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), |
c3d593c9 TQ |
4082 | Expressions => New_List ( |
4083 | Convert_To (Standard_Integer, | |
4084 | Make_Identifier (Loc, Name_Subp_Id)))), | |
d693e39d | 4085 | Selector_Name => Make_Identifier (Loc, Name_Addr)); |
c3d593c9 TQ |
4086 | |
4087 | -- Case of no visible subprogram: just raise Constraint_Error, we | |
4088 | -- know for sure we got junk from a remote partition. | |
4089 | ||
4090 | else | |
4091 | Subp_Info_Addr := | |
4092 | Make_Raise_Constraint_Error (Loc, | |
4093 | Reason => CE_Range_Check_Failed); | |
4094 | Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64)); | |
4095 | end if; | |
4096 | ||
4097 | Append_To (Decls, | |
4098 | Make_Subprogram_Body (Loc, | |
4099 | Specification => | |
4100 | Copy_Specification (Loc, Parent (Lookup_RAS_Info)), | |
d693e39d | 4101 | Declarations => No_List, |
c3d593c9 TQ |
4102 | Handled_Statement_Sequence => |
4103 | Make_Handled_Sequence_Of_Statements (Loc, | |
4104 | Statements => New_List ( | |
bfc2cdb1 | 4105 | Make_Simple_Return_Statement (Loc, |
c3d593c9 | 4106 | Expression => |
d693e39d TQ |
4107 | OK_Convert_To |
4108 | (RTE (RE_Unsigned_64), Subp_Info_Addr)))))); | |
c3d593c9 TQ |
4109 | end; |
4110 | ||
16db96c5 AC |
4111 | Analyze (Last (Decls)); |
4112 | ||
4113 | Append_To (Decls, Pkg_RPC_Receiver_Body); | |
4114 | Analyze (Last (Decls)); | |
4115 | ||
c3d593c9 TQ |
4116 | -- Name |
4117 | ||
16db96c5 | 4118 | Append_To (Register_Pkg_Actuals, |
16db96c5 | 4119 | Make_String_Literal (Loc, |
72267417 AC |
4120 | Strval => |
4121 | Fully_Qualified_Name_String | |
4122 | (Defining_Entity (Pkg_Spec), Append_NUL => False))); | |
16db96c5 | 4123 | |
c3d593c9 TQ |
4124 | -- Receiver |
4125 | ||
16db96c5 | 4126 | Append_To (Register_Pkg_Actuals, |
16db96c5 | 4127 | Make_Attribute_Reference (Loc, |
d693e39d TQ |
4128 | Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc), |
4129 | Attribute_Name => Name_Unrestricted_Access)); | |
16db96c5 | 4130 | |
c3d593c9 TQ |
4131 | -- Version |
4132 | ||
16db96c5 | 4133 | Append_To (Register_Pkg_Actuals, |
16db96c5 AC |
4134 | Make_Attribute_Reference (Loc, |
4135 | Prefix => | |
4136 | New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), | |
d693e39d | 4137 | Attribute_Name => Name_Version)); |
16db96c5 | 4138 | |
c3d593c9 TQ |
4139 | -- Subp_Info |
4140 | ||
16db96c5 | 4141 | Append_To (Register_Pkg_Actuals, |
16db96c5 | 4142 | Make_Attribute_Reference (Loc, |
d693e39d TQ |
4143 | Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), |
4144 | Attribute_Name => Name_Address)); | |
16db96c5 | 4145 | |
c3d593c9 TQ |
4146 | -- Subp_Info_Len |
4147 | ||
16db96c5 | 4148 | Append_To (Register_Pkg_Actuals, |
16db96c5 | 4149 | Make_Attribute_Reference (Loc, |
d693e39d TQ |
4150 | Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), |
4151 | Attribute_Name => Name_Length)); | |
16db96c5 | 4152 | |
c3d593c9 TQ |
4153 | -- Generate the call |
4154 | ||
8aa23fe3 | 4155 | Append_To (Stmts, |
16db96c5 AC |
4156 | Make_Procedure_Call_Statement (Loc, |
4157 | Name => | |
4158 | New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc), | |
4159 | Parameter_Associations => Register_Pkg_Actuals)); | |
8aa23fe3 | 4160 | Analyze (Last (Stmts)); |
16db96c5 AC |
4161 | end Add_Receiving_Stubs_To_Declarations; |
4162 | ||
4163 | --------------------------------- | |
4164 | -- Build_General_Calling_Stubs -- | |
4165 | --------------------------------- | |
4166 | ||
4167 | procedure Build_General_Calling_Stubs | |
4168 | (Decls : List_Id; | |
4169 | Statements : List_Id; | |
4170 | Target_Partition : Entity_Id; | |
4171 | Target_RPC_Receiver : Node_Id; | |
4172 | Subprogram_Id : Node_Id; | |
4173 | Asynchronous : Node_Id := Empty; | |
4174 | Is_Known_Asynchronous : Boolean := False; | |
4175 | Is_Known_Non_Asynchronous : Boolean := False; | |
4176 | Is_Function : Boolean; | |
4177 | Spec : Node_Id; | |
4178 | Stub_Type : Entity_Id := Empty; | |
4179 | RACW_Type : Entity_Id := Empty; | |
4180 | Nod : Node_Id) | |
bd7f7a65 AC |
4181 | is |
4182 | Loc : constant Source_Ptr := Sloc (Nod); | |
4183 | ||
4184 | Stream_Parameter : Node_Id; | |
c6f39437 AC |
4185 | -- Name of the stream used to transmit parameters to the remote |
4186 | -- package. | |
bd7f7a65 AC |
4187 | |
4188 | Result_Parameter : Node_Id; | |
4189 | -- Name of the result parameter (in non-APC cases) which get the | |
4190 | -- result of the remote subprogram. | |
4191 | ||
4192 | Exception_Return_Parameter : Node_Id; | |
4193 | -- Name of the parameter which will hold the exception sent by the | |
4194 | -- remote subprogram. | |
4195 | ||
4196 | Current_Parameter : Node_Id; | |
4197 | -- Current parameter being handled | |
4198 | ||
4199 | Ordered_Parameters_List : constant List_Id := | |
4200 | Build_Ordered_Parameters_List (Spec); | |
4201 | ||
4202 | Asynchronous_Statements : List_Id := No_List; | |
4203 | Non_Asynchronous_Statements : List_Id := No_List; | |
4204 | -- Statements specifics to the Asynchronous/Non-Asynchronous cases | |
4205 | ||
4206 | Extra_Formal_Statements : constant List_Id := New_List; | |
4207 | -- List of statements for extra formal parameters. It will appear | |
4208 | -- after the regular statements for writing out parameters. | |
4209 | ||
bd7f7a65 AC |
4210 | pragma Unreferenced (RACW_Type); |
4211 | -- Used only for the PolyORB case | |
bd7f7a65 AC |
4212 | |
4213 | begin | |
4214 | -- The general form of a calling stub for a given subprogram is: | |
4215 | ||
4216 | -- procedure X (...) is P : constant Partition_ID := | |
4217 | -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased | |
4218 | -- System.RPC.Params_Stream_Type (0); begin | |
4219 | -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver | |
4220 | -- comes from RCI_Cache.Get_RCI_Package_Receiver) | |
4221 | -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC | |
4222 | -- (Stream, Result); Read_Exception_Occurrence_From_Result; | |
4223 | -- Raise_It; | |
4224 | -- Read_Out_Parameters_And_Function_Return_From_Stream; end X; | |
4225 | ||
4226 | -- There are some variations: Do_APC is called for an asynchronous | |
4227 | -- procedure and the part after the call is completely ommitted as | |
4228 | -- well as the declaration of Result. For a function call, 'Input is | |
4229 | -- always used to read the result even if it is constrained. | |
4230 | ||
2287a75d | 4231 | Stream_Parameter := Make_Temporary (Loc, 'S'); |
bd7f7a65 AC |
4232 | |
4233 | Append_To (Decls, | |
4234 | Make_Object_Declaration (Loc, | |
4235 | Defining_Identifier => Stream_Parameter, | |
4236 | Aliased_Present => True, | |
4237 | Object_Definition => | |
4238 | Make_Subtype_Indication (Loc, | |
4239 | Subtype_Mark => | |
4240 | New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), | |
4241 | Constraint => | |
4242 | Make_Index_Or_Discriminant_Constraint (Loc, | |
4243 | Constraints => | |
4244 | New_List (Make_Integer_Literal (Loc, 0)))))); | |
4245 | ||
4246 | if not Is_Known_Asynchronous then | |
2287a75d | 4247 | Result_Parameter := Make_Temporary (Loc, 'R'); |
bd7f7a65 AC |
4248 | |
4249 | Append_To (Decls, | |
4250 | Make_Object_Declaration (Loc, | |
4251 | Defining_Identifier => Result_Parameter, | |
4252 | Aliased_Present => True, | |
4253 | Object_Definition => | |
4254 | Make_Subtype_Indication (Loc, | |
4255 | Subtype_Mark => | |
4256 | New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), | |
4257 | Constraint => | |
4258 | Make_Index_Or_Discriminant_Constraint (Loc, | |
4259 | Constraints => | |
4260 | New_List (Make_Integer_Literal (Loc, 0)))))); | |
4261 | ||
2287a75d | 4262 | Exception_Return_Parameter := Make_Temporary (Loc, 'E'); |
bd7f7a65 AC |
4263 | |
4264 | Append_To (Decls, | |
4265 | Make_Object_Declaration (Loc, | |
4266 | Defining_Identifier => Exception_Return_Parameter, | |
4267 | Object_Definition => | |
4268 | New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); | |
4269 | ||
4270 | else | |
4271 | Result_Parameter := Empty; | |
4272 | Exception_Return_Parameter := Empty; | |
4273 | end if; | |
4274 | ||
4275 | -- Put first the RPC receiver corresponding to the remote package | |
4276 | ||
4277 | Append_To (Statements, | |
4278 | Make_Attribute_Reference (Loc, | |
4279 | Prefix => | |
4280 | New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), | |
4281 | Attribute_Name => Name_Write, | |
4282 | Expressions => New_List ( | |
4283 | Make_Attribute_Reference (Loc, | |
d693e39d TQ |
4284 | Prefix => New_Occurrence_Of (Stream_Parameter, Loc), |
4285 | Attribute_Name => Name_Access), | |
bd7f7a65 AC |
4286 | Target_RPC_Receiver))); |
4287 | ||
4288 | -- Then put the Subprogram_Id of the subprogram we want to call in | |
4289 | -- the stream. | |
4290 | ||
4291 | Append_To (Statements, | |
4292 | Make_Attribute_Reference (Loc, | |
d693e39d TQ |
4293 | Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), |
4294 | Attribute_Name => Name_Write, | |
bd7f7a65 AC |
4295 | Expressions => New_List ( |
4296 | Make_Attribute_Reference (Loc, | |
d693e39d | 4297 | Prefix => New_Occurrence_Of (Stream_Parameter, Loc), |
bd7f7a65 AC |
4298 | Attribute_Name => Name_Access), |
4299 | Subprogram_Id))); | |
4300 | ||
4301 | Current_Parameter := First (Ordered_Parameters_List); | |
4302 | while Present (Current_Parameter) loop | |
4303 | declare | |
4304 | Typ : constant Node_Id := | |
4305 | Parameter_Type (Current_Parameter); | |
4306 | Etyp : Entity_Id; | |
4307 | Constrained : Boolean; | |
4308 | Value : Node_Id; | |
4309 | Extra_Parameter : Entity_Id; | |
4310 | ||
4311 | begin | |
4312 | if Is_RACW_Controlling_Formal | |
d693e39d | 4313 | (Current_Parameter, Stub_Type) |
bd7f7a65 AC |
4314 | then |
4315 | -- In the case of a controlling formal argument, we marshall | |
4316 | -- its addr field rather than the local stub. | |
4317 | ||
4318 | Append_To (Statements, | |
4319 | Pack_Node_Into_Stream (Loc, | |
4320 | Stream => Stream_Parameter, | |
4321 | Object => | |
4322 | Make_Selected_Component (Loc, | |
4323 | Prefix => | |
16db96c5 AC |
4324 | Defining_Identifier (Current_Parameter), |
4325 | Selector_Name => Name_Addr), | |
bd7f7a65 AC |
4326 | Etyp => RTE (RE_Unsigned_64))); |
4327 | ||
4328 | else | |
d693e39d TQ |
4329 | Value := |
4330 | New_Occurrence_Of | |
4331 | (Defining_Identifier (Current_Parameter), Loc); | |
bd7f7a65 AC |
4332 | |
4333 | -- Access type parameters are transmitted as in out | |
4334 | -- parameters. However, a dereference is needed so that | |
4335 | -- we marshall the designated object. | |
4336 | ||
4337 | if Nkind (Typ) = N_Access_Definition then | |
4338 | Value := Make_Explicit_Dereference (Loc, Value); | |
4339 | Etyp := Etype (Subtype_Mark (Typ)); | |
4340 | else | |
4341 | Etyp := Etype (Typ); | |
4342 | end if; | |
4343 | ||
7f0b5314 | 4344 | Constrained := not Transmit_As_Unconstrained (Etyp); |
bd7f7a65 AC |
4345 | |
4346 | -- Any parameter but unconstrained out parameters are | |
4347 | -- transmitted to the peer. | |
4348 | ||
4349 | if In_Present (Current_Parameter) | |
4350 | or else not Out_Present (Current_Parameter) | |
4351 | or else not Constrained | |
4352 | then | |
4353 | Append_To (Statements, | |
4354 | Make_Attribute_Reference (Loc, | |
d693e39d | 4355 | Prefix => New_Occurrence_Of (Etyp, Loc), |
bd7f7a65 AC |
4356 | Attribute_Name => |
4357 | Output_From_Constrained (Constrained), | |
4358 | Expressions => New_List ( | |
4359 | Make_Attribute_Reference (Loc, | |
4360 | Prefix => | |
4361 | New_Occurrence_Of (Stream_Parameter, Loc), | |
4362 | Attribute_Name => Name_Access), | |
4363 | Value))); | |
4364 | end if; | |
4365 | end if; | |
4366 | ||
4367 | -- If the current parameter has a dynamic constrained status, | |
4368 | -- then this status is transmitted as well. | |
4369 | -- This should be done for accessibility as well ??? | |
4370 | ||
4371 | if Nkind (Typ) /= N_Access_Definition | |
4372 | and then Need_Extra_Constrained (Current_Parameter) | |
4373 | then | |
4374 | -- In this block, we do not use the extra formal that has | |
4375 | -- been created because it does not exist at the time of | |
4376 | -- expansion when building calling stubs for remote access | |
4377 | -- to subprogram types. We create an extra variable of this | |
4378 | -- type and push it in the stream after the regular | |
4379 | -- parameters. | |
4380 | ||
2287a75d | 4381 | Extra_Parameter := Make_Temporary (Loc, 'P'); |
bd7f7a65 AC |
4382 | |
4383 | Append_To (Decls, | |
4384 | Make_Object_Declaration (Loc, | |
4385 | Defining_Identifier => Extra_Parameter, | |
4386 | Constant_Present => True, | |
4387 | Object_Definition => | |
4388 | New_Occurrence_Of (Standard_Boolean, Loc), | |
4389 | Expression => | |
4390 | Make_Attribute_Reference (Loc, | |
4391 | Prefix => | |
4392 | New_Occurrence_Of ( | |
4393 | Defining_Identifier (Current_Parameter), Loc), | |
4394 | Attribute_Name => Name_Constrained))); | |
4395 | ||
4396 | Append_To (Extra_Formal_Statements, | |
4397 | Make_Attribute_Reference (Loc, | |
4398 | Prefix => | |
4399 | New_Occurrence_Of (Standard_Boolean, Loc), | |
d693e39d | 4400 | Attribute_Name => Name_Write, |
bd7f7a65 AC |
4401 | Expressions => New_List ( |
4402 | Make_Attribute_Reference (Loc, | |
4403 | Prefix => | |
d693e39d TQ |
4404 | New_Occurrence_Of |
4405 | (Stream_Parameter, Loc), Attribute_Name => | |
bd7f7a65 AC |
4406 | Name_Access), |
4407 | New_Occurrence_Of (Extra_Parameter, Loc)))); | |
4408 | end if; | |
4409 | ||
4410 | Next (Current_Parameter); | |
4411 | end; | |
4412 | end loop; | |
4413 | ||
4414 | -- Append the formal statements list to the statements | |
4415 | ||
4416 | Append_List_To (Statements, Extra_Formal_Statements); | |
4417 | ||
4418 | if not Is_Known_Non_Asynchronous then | |
4419 | ||
4420 | -- Build the call to System.RPC.Do_APC | |
4421 | ||
4422 | Asynchronous_Statements := New_List ( | |
4423 | Make_Procedure_Call_Statement (Loc, | |
4424 | Name => | |
4425 | New_Occurrence_Of (RTE (RE_Do_Apc), Loc), | |
4426 | Parameter_Associations => New_List ( | |
4427 | New_Occurrence_Of (Target_Partition, Loc), | |
4428 | Make_Attribute_Reference (Loc, | |
4429 | Prefix => | |
4430 | New_Occurrence_Of (Stream_Parameter, Loc), | |
d693e39d | 4431 | Attribute_Name => Name_Access)))); |
bd7f7a65 AC |
4432 | else |
4433 | Asynchronous_Statements := No_List; | |
4434 | end if; | |
4435 | ||
4436 | if not Is_Known_Asynchronous then | |
4437 | ||
4438 | -- Build the call to System.RPC.Do_RPC | |
4439 | ||
4440 | Non_Asynchronous_Statements := New_List ( | |
4441 | Make_Procedure_Call_Statement (Loc, | |
4442 | Name => | |
4443 | New_Occurrence_Of (RTE (RE_Do_Rpc), Loc), | |
4444 | Parameter_Associations => New_List ( | |
4445 | New_Occurrence_Of (Target_Partition, Loc), | |
4446 | ||
4447 | Make_Attribute_Reference (Loc, | |
4448 | Prefix => | |
4449 | New_Occurrence_Of (Stream_Parameter, Loc), | |
d693e39d | 4450 | Attribute_Name => Name_Access), |
bd7f7a65 AC |
4451 | |
4452 | Make_Attribute_Reference (Loc, | |
4453 | Prefix => | |
4454 | New_Occurrence_Of (Result_Parameter, Loc), | |
d693e39d | 4455 | Attribute_Name => Name_Access)))); |
bd7f7a65 AC |
4456 | |
4457 | -- Read the exception occurrence from the result stream and | |
4458 | -- reraise it. It does no harm if this is a Null_Occurrence since | |
4459 | -- this does nothing. | |
4460 | ||
4461 | Append_To (Non_Asynchronous_Statements, | |
4462 | Make_Attribute_Reference (Loc, | |
4463 | Prefix => | |
4464 | New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), | |
4465 | ||
d693e39d | 4466 | Attribute_Name => Name_Read, |
bd7f7a65 AC |
4467 | |
4468 | Expressions => New_List ( | |
4469 | Make_Attribute_Reference (Loc, | |
4470 | Prefix => | |
4471 | New_Occurrence_Of (Result_Parameter, Loc), | |
d693e39d | 4472 | Attribute_Name => Name_Access), |
bd7f7a65 AC |
4473 | New_Occurrence_Of (Exception_Return_Parameter, Loc)))); |
4474 | ||
4475 | Append_To (Non_Asynchronous_Statements, | |
4476 | Make_Procedure_Call_Statement (Loc, | |
4477 | Name => | |
4478 | New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc), | |
4479 | Parameter_Associations => New_List ( | |
4480 | New_Occurrence_Of (Exception_Return_Parameter, Loc)))); | |
4481 | ||
4482 | if Is_Function then | |
4483 | ||
4484 | -- If this is a function call, then read the value and return | |
4485 | -- it. The return value is written/read using 'Output/'Input. | |
4486 | ||
4487 | Append_To (Non_Asynchronous_Statements, | |
4488 | Make_Tag_Check (Loc, | |
bfc2cdb1 | 4489 | Make_Simple_Return_Statement (Loc, |
bd7f7a65 AC |
4490 | Expression => |
4491 | Make_Attribute_Reference (Loc, | |
4492 | Prefix => | |
4493 | New_Occurrence_Of ( | |
3eb8fddc | 4494 | Etype (Result_Definition (Spec)), Loc), |
bd7f7a65 AC |
4495 | |
4496 | Attribute_Name => Name_Input, | |
4497 | ||
4498 | Expressions => New_List ( | |
4499 | Make_Attribute_Reference (Loc, | |
4500 | Prefix => | |
4501 | New_Occurrence_Of (Result_Parameter, Loc), | |
4502 | Attribute_Name => Name_Access)))))); | |
4503 | ||
4504 | else | |
4505 | -- Loop around parameters and assign out (or in out) | |
4506 | -- parameters. In the case of RACW, controlling arguments | |
c6f39437 AC |
4507 | -- cannot possibly have changed since they are remote, so |
4508 | -- we do not read them from the stream. | |
bd7f7a65 AC |
4509 | |
4510 | Current_Parameter := First (Ordered_Parameters_List); | |
4511 | while Present (Current_Parameter) loop | |
4512 | declare | |
4513 | Typ : constant Node_Id := | |
4514 | Parameter_Type (Current_Parameter); | |
4515 | Etyp : Entity_Id; | |
4516 | Value : Node_Id; | |
4517 | ||
4518 | begin | |
4519 | Value := | |
4520 | New_Occurrence_Of | |
4521 | (Defining_Identifier (Current_Parameter), Loc); | |
4522 | ||
4523 | if Nkind (Typ) = N_Access_Definition then | |
4524 | Value := Make_Explicit_Dereference (Loc, Value); | |
4525 | Etyp := Etype (Subtype_Mark (Typ)); | |
4526 | else | |
4527 | Etyp := Etype (Typ); | |
4528 | end if; | |
4529 | ||
4530 | if (Out_Present (Current_Parameter) | |
4531 | or else Nkind (Typ) = N_Access_Definition) | |
4532 | and then Etyp /= Stub_Type | |
4533 | then | |
4534 | Append_To (Non_Asynchronous_Statements, | |
4535 | Make_Attribute_Reference (Loc, | |
4536 | Prefix => | |
4537 | New_Occurrence_Of (Etyp, Loc), | |
4538 | ||
4539 | Attribute_Name => Name_Read, | |
4540 | ||
4541 | Expressions => New_List ( | |
4542 | Make_Attribute_Reference (Loc, | |
4543 | Prefix => | |
4544 | New_Occurrence_Of (Result_Parameter, Loc), | |
d693e39d | 4545 | Attribute_Name => Name_Access), |
bd7f7a65 AC |
4546 | Value))); |
4547 | end if; | |
4548 | end; | |
4549 | ||
4550 | Next (Current_Parameter); | |
4551 | end loop; | |
4552 | end if; | |
4553 | end if; | |
4554 | ||
4555 | if Is_Known_Asynchronous then | |
4556 | Append_List_To (Statements, Asynchronous_Statements); | |
4557 | ||
4558 | elsif Is_Known_Non_Asynchronous then | |
4559 | Append_List_To (Statements, Non_Asynchronous_Statements); | |
4560 | ||
4561 | else | |
4562 | pragma Assert (Present (Asynchronous)); | |
4563 | Prepend_To (Asynchronous_Statements, | |
4564 | Make_Attribute_Reference (Loc, | |
4565 | Prefix => New_Occurrence_Of (Standard_Boolean, Loc), | |
4566 | Attribute_Name => Name_Write, | |
4567 | Expressions => New_List ( | |
4568 | Make_Attribute_Reference (Loc, | |
4569 | Prefix => | |
4570 | New_Occurrence_Of (Stream_Parameter, Loc), | |
4571 | Attribute_Name => Name_Access), | |
4572 | New_Occurrence_Of (Standard_True, Loc)))); | |
4573 | ||
4574 | Prepend_To (Non_Asynchronous_Statements, | |
4575 | Make_Attribute_Reference (Loc, | |
4576 | Prefix => New_Occurrence_Of (Standard_Boolean, Loc), | |
4577 | Attribute_Name => Name_Write, | |
4578 | Expressions => New_List ( | |
4579 | Make_Attribute_Reference (Loc, | |
4580 | Prefix => | |
4581 | New_Occurrence_Of (Stream_Parameter, Loc), | |
4582 | Attribute_Name => Name_Access), | |
4583 | New_Occurrence_Of (Standard_False, Loc)))); | |
4584 | ||
4585 | Append_To (Statements, | |
4586 | Make_Implicit_If_Statement (Nod, | |
4587 | Condition => Asynchronous, | |
4588 | Then_Statements => Asynchronous_Statements, | |
4589 | Else_Statements => Non_Asynchronous_Statements)); | |
4590 | end if; | |
4591 | end Build_General_Calling_Stubs; | |
4592 | ||
16db96c5 AC |
4593 | ----------------------------- |
4594 | -- Build_RPC_Receiver_Body -- | |
4595 | ----------------------------- | |
4596 | ||
4597 | procedure Build_RPC_Receiver_Body | |
4598 | (RPC_Receiver : Entity_Id; | |
4599 | Request : out Entity_Id; | |
4600 | Subp_Id : out Entity_Id; | |
4601 | Subp_Index : out Entity_Id; | |
4602 | Stmts : out List_Id; | |
4603 | Decl : out Node_Id) | |
4604 | is | |
4605 | Loc : constant Source_Ptr := Sloc (RPC_Receiver); | |
4606 | ||
4607 | RPC_Receiver_Spec : Node_Id; | |
4608 | RPC_Receiver_Decls : List_Id; | |
4609 | ||
4610 | begin | |
4611 | Request := Make_Defining_Identifier (Loc, Name_R); | |
4612 | ||
4613 | RPC_Receiver_Spec := | |
4614 | Build_RPC_Receiver_Specification | |
4615 | (RPC_Receiver => RPC_Receiver, | |
4616 | Request_Parameter => Request); | |
4617 | ||
2287a75d | 4618 | Subp_Id := Make_Temporary (Loc, 'P'); |
16db96c5 AC |
4619 | Subp_Index := Subp_Id; |
4620 | ||
4621 | -- Subp_Id may not be a constant, because in the case of the RPC | |
4622 | -- receiver for an RCI package, when a call is received from a RAS | |
4623 | -- dereference, it will be assigned during subsequent processing. | |
4624 | ||
4625 | RPC_Receiver_Decls := New_List ( | |
4626 | Make_Object_Declaration (Loc, | |
4627 | Defining_Identifier => Subp_Id, | |
4628 | Object_Definition => | |
4629 | New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), | |
4630 | Expression => | |
4631 | Make_Attribute_Reference (Loc, | |
4632 | Prefix => | |
4633 | New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), | |
4634 | Attribute_Name => Name_Input, | |
4635 | Expressions => New_List ( | |
d693e39d TQ |
4636 | Make_Selected_Component (Loc, |
4637 | Prefix => Request, | |
4638 | Selector_Name => Name_Params))))); | |
16db96c5 AC |
4639 | |
4640 | Stmts := New_List; | |
4641 | ||
4642 | Decl := | |
4643 | Make_Subprogram_Body (Loc, | |
4644 | Specification => RPC_Receiver_Spec, | |
4645 | Declarations => RPC_Receiver_Decls, | |
4646 | Handled_Statement_Sequence => | |
4647 | Make_Handled_Sequence_Of_Statements (Loc, | |
4648 | Statements => Stmts)); | |
4649 | end Build_RPC_Receiver_Body; | |
4650 | ||
bd7f7a65 AC |
4651 | ----------------------- |
4652 | -- Build_Stub_Target -- | |
4653 | ----------------------- | |
4654 | ||
4655 | function Build_Stub_Target | |
4656 | (Loc : Source_Ptr; | |
4657 | Decls : List_Id; | |
4658 | RCI_Locator : Entity_Id; | |
4659 | Controlling_Parameter : Entity_Id) return RPC_Target | |
4660 | is | |
4661 | Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA); | |
2287a75d | 4662 | |
bd7f7a65 | 4663 | begin |
2287a75d AC |
4664 | Target_Info.Partition := Make_Temporary (Loc, 'P'); |
4665 | ||
bd7f7a65 AC |
4666 | if Present (Controlling_Parameter) then |
4667 | Append_To (Decls, | |
4668 | Make_Object_Declaration (Loc, | |
4669 | Defining_Identifier => Target_Info.Partition, | |
4670 | Constant_Present => True, | |
4671 | Object_Definition => | |
4672 | New_Occurrence_Of (RTE (RE_Partition_ID), Loc), | |
4673 | ||
4674 | Expression => | |
4675 | Make_Selected_Component (Loc, | |
16db96c5 AC |
4676 | Prefix => Controlling_Parameter, |
4677 | Selector_Name => Name_Origin))); | |
bd7f7a65 AC |
4678 | |
4679 | Target_Info.RPC_Receiver := | |
4680 | Make_Selected_Component (Loc, | |
16db96c5 AC |
4681 | Prefix => Controlling_Parameter, |
4682 | Selector_Name => Name_Receiver); | |
bd7f7a65 AC |
4683 | |
4684 | else | |
4685 | Append_To (Decls, | |
4686 | Make_Object_Declaration (Loc, | |
4687 | Defining_Identifier => Target_Info.Partition, | |
4688 | Constant_Present => True, | |
4689 | Object_Definition => | |
4690 | New_Occurrence_Of (RTE (RE_Partition_ID), Loc), | |
4691 | ||
4692 | Expression => | |
4693 | Make_Function_Call (Loc, | |
4694 | Name => Make_Selected_Component (Loc, | |
4695 | Prefix => | |
4696 | Make_Identifier (Loc, Chars (RCI_Locator)), | |
4697 | Selector_Name => | |
4698 | Make_Identifier (Loc, | |
4699 | Name_Get_Active_Partition_ID))))); | |
4700 | ||
4701 | Target_Info.RPC_Receiver := | |
4702 | Make_Selected_Component (Loc, | |
4703 | Prefix => | |
4704 | Make_Identifier (Loc, Chars (RCI_Locator)), | |
4705 | Selector_Name => | |
4706 | Make_Identifier (Loc, Name_Get_RCI_Package_Receiver)); | |
4707 | end if; | |
4708 | return Target_Info; | |
4709 | end Build_Stub_Target; | |
4710 | ||
bd7f7a65 | 4711 | -------------------------------------- |
16db96c5 | 4712 | -- Build_Subprogram_Receiving_Stubs -- |
bd7f7a65 AC |
4713 | -------------------------------------- |
4714 | ||
16db96c5 AC |
4715 | function Build_Subprogram_Receiving_Stubs |
4716 | (Vis_Decl : Node_Id; | |
4717 | Asynchronous : Boolean; | |
4718 | Dynamically_Asynchronous : Boolean := False; | |
4719 | Stub_Type : Entity_Id := Empty; | |
4720 | RACW_Type : Entity_Id := Empty; | |
4721 | Parent_Primitive : Entity_Id := Empty) return Node_Id | |
bd7f7a65 | 4722 | is |
16db96c5 | 4723 | Loc : constant Source_Ptr := Sloc (Vis_Decl); |
bd7f7a65 | 4724 | |
2287a75d | 4725 | Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); |
8aa23fe3 TQ |
4726 | -- Formal parameter for receiving stubs: a descriptor for an incoming |
4727 | -- request. | |
bd7f7a65 | 4728 | |
16db96c5 AC |
4729 | Decls : constant List_Id := New_List; |
4730 | -- All the parameters will get declared before calling the real | |
4731 | -- subprograms. Also the out parameters will be declared. | |
bd7f7a65 | 4732 | |
16db96c5 | 4733 | Statements : constant List_Id := New_List; |
bd7f7a65 | 4734 | |
16db96c5 AC |
4735 | Extra_Formal_Statements : constant List_Id := New_List; |
4736 | -- Statements concerning extra formal parameters | |
bd7f7a65 | 4737 | |
16db96c5 AC |
4738 | After_Statements : constant List_Id := New_List; |
4739 | -- Statements to be executed after the subprogram call | |
bd7f7a65 | 4740 | |
16db96c5 AC |
4741 | Inner_Decls : List_Id := No_List; |
4742 | -- In case of a function, the inner declarations are needed since | |
4743 | -- the result may be unconstrained. | |
bd7f7a65 | 4744 | |
16db96c5 AC |
4745 | Excep_Handlers : List_Id := No_List; |
4746 | Excep_Choice : Entity_Id; | |
4747 | Excep_Code : List_Id; | |
bd7f7a65 | 4748 | |
16db96c5 AC |
4749 | Parameter_List : constant List_Id := New_List; |
4750 | -- List of parameters to be passed to the subprogram | |
bd7f7a65 | 4751 | |
16db96c5 | 4752 | Current_Parameter : Node_Id; |
bd7f7a65 | 4753 | |
16db96c5 AC |
4754 | Ordered_Parameters_List : constant List_Id := |
4755 | Build_Ordered_Parameters_List | |
4756 | (Specification (Vis_Decl)); | |
bd7f7a65 | 4757 | |
16db96c5 AC |
4758 | Subp_Spec : Node_Id; |
4759 | -- Subprogram specification | |
bd7f7a65 | 4760 | |
16db96c5 AC |
4761 | Called_Subprogram : Node_Id; |
4762 | -- The subprogram to call | |
bd7f7a65 | 4763 | |
16db96c5 | 4764 | Null_Raise_Statement : Node_Id; |
bd7f7a65 | 4765 | |
16db96c5 | 4766 | Dynamic_Async : Entity_Id; |
bd7f7a65 | 4767 | |
16db96c5 AC |
4768 | begin |
4769 | if Present (RACW_Type) then | |
8aa23fe3 | 4770 | Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc); |
16db96c5 AC |
4771 | else |
4772 | Called_Subprogram := | |
8aa23fe3 TQ |
4773 | New_Occurrence_Of |
4774 | (Defining_Unit_Name (Specification (Vis_Decl)), Loc); | |
16db96c5 | 4775 | end if; |
bd7f7a65 | 4776 | |
16db96c5 | 4777 | if Dynamically_Asynchronous then |
2287a75d | 4778 | Dynamic_Async := Make_Temporary (Loc, 'S'); |
16db96c5 AC |
4779 | else |
4780 | Dynamic_Async := Empty; | |
4781 | end if; | |
bd7f7a65 | 4782 | |
16db96c5 | 4783 | if not Asynchronous or Dynamically_Asynchronous then |
bd7f7a65 | 4784 | |
16db96c5 | 4785 | -- The first statement after the subprogram call is a statement to |
8aa23fe3 | 4786 | -- write a Null_Occurrence into the result stream. |
16db96c5 AC |
4787 | |
4788 | Null_Raise_Statement := | |
4789 | Make_Attribute_Reference (Loc, | |
4790 | Prefix => | |
4791 | New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), | |
4792 | Attribute_Name => Name_Write, | |
4793 | Expressions => New_List ( | |
d693e39d TQ |
4794 | Make_Selected_Component (Loc, |
4795 | Prefix => Request_Parameter, | |
4796 | Selector_Name => Name_Result), | |
16db96c5 AC |
4797 | New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); |
4798 | ||
4799 | if Dynamically_Asynchronous then | |
4800 | Null_Raise_Statement := | |
4801 | Make_Implicit_If_Statement (Vis_Decl, | |
4802 | Condition => | |
4803 | Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)), | |
4804 | Then_Statements => New_List (Null_Raise_Statement)); | |
4805 | end if; | |
4806 | ||
4807 | Append_To (After_Statements, Null_Raise_Statement); | |
4808 | end if; | |
4809 | ||
4810 | -- Loop through every parameter and get its value from the stream. If | |
4811 | -- the parameter is unconstrained, then the parameter is read using | |
4812 | -- 'Input at the point of declaration. | |
4813 | ||
4814 | Current_Parameter := First (Ordered_Parameters_List); | |
4815 | while Present (Current_Parameter) loop | |
4816 | declare | |
4817 | Etyp : Entity_Id; | |
4818 | Constrained : Boolean; | |
4819 | ||
8aa23fe3 TQ |
4820 | Need_Extra_Constrained : Boolean; |
4821 | -- True when an Extra_Constrained actual is required | |
4822 | ||
2287a75d | 4823 | Object : constant Entity_Id := Make_Temporary (Loc, 'P'); |
16db96c5 | 4824 | |
8aa23fe3 | 4825 | Expr : Node_Id := Empty; |
16db96c5 AC |
4826 | |
4827 | Is_Controlling_Formal : constant Boolean := | |
4828 | Is_RACW_Controlling_Formal | |
4829 | (Current_Parameter, Stub_Type); | |
4830 | ||
4831 | begin | |
16db96c5 AC |
4832 | if Is_Controlling_Formal then |
4833 | ||
4834 | -- We have a controlling formal parameter. Read its address | |
4835 | -- rather than a real object. The address is in Unsigned_64 | |
4836 | -- form. | |
4837 | ||
4838 | Etyp := RTE (RE_Unsigned_64); | |
4839 | else | |
4840 | Etyp := Etype (Parameter_Type (Current_Parameter)); | |
4841 | end if; | |
4842 | ||
7f0b5314 | 4843 | Constrained := not Transmit_As_Unconstrained (Etyp); |
16db96c5 AC |
4844 | |
4845 | if In_Present (Current_Parameter) | |
4846 | or else not Out_Present (Current_Parameter) | |
4847 | or else not Constrained | |
4848 | or else Is_Controlling_Formal | |
4849 | then | |
92869a7b TQ |
4850 | -- If an input parameter is constrained, then the read of |
4851 | -- the parameter is deferred until the beginning of the | |
4852 | -- subprogram body. If it is unconstrained, then an | |
4853 | -- expression is built for the object declaration and the | |
4854 | -- variable is set using 'Input instead of 'Read. Note that | |
4855 | -- this deferral does not change the order in which the | |
4856 | -- actuals are read because Build_Ordered_Parameter_List | |
4857 | -- puts them unconstrained first. | |
16db96c5 | 4858 | |
92869a7b | 4859 | if Constrained then |
16db96c5 AC |
4860 | Append_To (Statements, |
4861 | Make_Attribute_Reference (Loc, | |
4862 | Prefix => New_Occurrence_Of (Etyp, Loc), | |
4863 | Attribute_Name => Name_Read, | |
4864 | Expressions => New_List ( | |
4865 | Make_Selected_Component (Loc, | |
4866 | Prefix => Request_Parameter, | |
4867 | Selector_Name => Name_Params), | |
4868 | New_Occurrence_Of (Object, Loc)))); | |
4869 | ||
4870 | else | |
8aa23fe3 TQ |
4871 | |
4872 | -- Build and append Input_With_Tag_Check function | |
4873 | ||
4874 | Append_To (Decls, | |
4875 | Input_With_Tag_Check (Loc, | |
4876 | Var_Type => Etyp, | |
d693e39d TQ |
4877 | Stream => |
4878 | Make_Selected_Component (Loc, | |
4879 | Prefix => Request_Parameter, | |
4880 | Selector_Name => Name_Params))); | |
8aa23fe3 TQ |
4881 | |
4882 | -- Prepare function call expression | |
4883 | ||
d693e39d TQ |
4884 | Expr := |
4885 | Make_Function_Call (Loc, | |
4886 | Name => | |
4887 | New_Occurrence_Of | |
4888 | (Defining_Unit_Name | |
4889 | (Specification (Last (Decls))), Loc)); | |
16db96c5 AC |
4890 | end if; |
4891 | end if; | |
4892 | ||
8aa23fe3 TQ |
4893 | Need_Extra_Constrained := |
4894 | Nkind (Parameter_Type (Current_Parameter)) /= | |
4895 | N_Access_Definition | |
4896 | and then | |
4897 | Ekind (Defining_Identifier (Current_Parameter)) /= E_Void | |
4898 | and then | |
4899 | Present (Extra_Constrained | |
4900 | (Defining_Identifier (Current_Parameter))); | |
4901 | ||
4902 | -- We may not associate an extra constrained actual to a | |
4903 | -- constant object, so if one is needed, declare the actual | |
4904 | -- as a variable even if it won't be modified. | |
4905 | ||
4906 | Build_Actual_Object_Declaration | |
4907 | (Object => Object, | |
4908 | Etyp => Etyp, | |
4909 | Variable => Need_Extra_Constrained | |
4910 | or else Out_Present (Current_Parameter), | |
4911 | Expr => Expr, | |
4912 | Decls => Decls); | |
16db96c5 AC |
4913 | |
4914 | -- An out parameter may be written back using a 'Write | |
4915 | -- attribute instead of a 'Output because it has been | |
4916 | -- constrained by the parameter given to the caller. Note that | |
4917 | -- out controlling arguments in the case of a RACW are not put | |
4918 | -- back in the stream because the pointer on them has not | |
4919 | -- changed. | |
4920 | ||
4921 | if Out_Present (Current_Parameter) | |
4922 | and then | |
4923 | Etype (Parameter_Type (Current_Parameter)) /= Stub_Type | |
4924 | then | |
4925 | Append_To (After_Statements, | |
4926 | Make_Attribute_Reference (Loc, | |
4927 | Prefix => New_Occurrence_Of (Etyp, Loc), | |
4928 | Attribute_Name => Name_Write, | |
4929 | Expressions => New_List ( | |
4930 | Make_Selected_Component (Loc, | |
4931 | Prefix => Request_Parameter, | |
4932 | Selector_Name => Name_Result), | |
4933 | New_Occurrence_Of (Object, Loc)))); | |
4934 | end if; | |
4935 | ||
4936 | -- For RACW controlling formals, the Etyp of Object is always | |
4937 | -- an RACW, even if the parameter is not of an anonymous access | |
4938 | -- type. In such case, we need to dereference it at call time. | |
4939 | ||
4940 | if Is_Controlling_Formal then | |
4941 | if Nkind (Parameter_Type (Current_Parameter)) /= | |
4942 | N_Access_Definition | |
4943 | then | |
4944 | Append_To (Parameter_List, | |
4945 | Make_Parameter_Association (Loc, | |
4946 | Selector_Name => | |
4947 | New_Occurrence_Of ( | |
4948 | Defining_Identifier (Current_Parameter), Loc), | |
4949 | Explicit_Actual_Parameter => | |
4950 | Make_Explicit_Dereference (Loc, | |
4951 | Unchecked_Convert_To (RACW_Type, | |
4952 | OK_Convert_To (RTE (RE_Address), | |
4953 | New_Occurrence_Of (Object, Loc)))))); | |
4954 | ||
4955 | else | |
4956 | Append_To (Parameter_List, | |
4957 | Make_Parameter_Association (Loc, | |
4958 | Selector_Name => | |
4959 | New_Occurrence_Of ( | |
4960 | Defining_Identifier (Current_Parameter), Loc), | |
4961 | Explicit_Actual_Parameter => | |
4962 | Unchecked_Convert_To (RACW_Type, | |
4963 | OK_Convert_To (RTE (RE_Address), | |
4964 | New_Occurrence_Of (Object, Loc))))); | |
4965 | end if; | |
4966 | ||
4967 | else | |
4968 | Append_To (Parameter_List, | |
4969 | Make_Parameter_Association (Loc, | |
4970 | Selector_Name => | |
4971 | New_Occurrence_Of ( | |
4972 | Defining_Identifier (Current_Parameter), Loc), | |
4973 | Explicit_Actual_Parameter => | |
4974 | New_Occurrence_Of (Object, Loc))); | |
4975 | end if; | |
4976 | ||
4977 | -- If the current parameter needs an extra formal, then read it | |
4978 | -- from the stream and set the corresponding semantic field in | |
4979 | -- the variable. If the kind of the parameter identifier is | |
4980 | -- E_Void, then this is a compiler generated parameter that | |
4981 | -- doesn't need an extra constrained status. | |
4982 | ||
4983 | -- The case of Extra_Accessibility should also be handled ??? | |
4984 | ||
8aa23fe3 | 4985 | if Need_Extra_Constrained then |
16db96c5 AC |
4986 | declare |
4987 | Extra_Parameter : constant Entity_Id := | |
4988 | Extra_Constrained | |
4989 | (Defining_Identifier | |
4990 | (Current_Parameter)); | |
4991 | ||
4992 | Formal_Entity : constant Entity_Id := | |
4993 | Make_Defining_Identifier | |
4994 | (Loc, Chars (Extra_Parameter)); | |
4995 | ||
4996 | Formal_Type : constant Entity_Id := | |
4997 | Etype (Extra_Parameter); | |
4998 | ||
4999 | begin | |
5000 | Append_To (Decls, | |
5001 | Make_Object_Declaration (Loc, | |
5002 | Defining_Identifier => Formal_Entity, | |
5003 | Object_Definition => | |
5004 | New_Occurrence_Of (Formal_Type, Loc))); | |
5005 | ||
5006 | Append_To (Extra_Formal_Statements, | |
5007 | Make_Attribute_Reference (Loc, | |
5008 | Prefix => New_Occurrence_Of ( | |
5009 | Formal_Type, Loc), | |
5010 | Attribute_Name => Name_Read, | |
5011 | Expressions => New_List ( | |
5012 | Make_Selected_Component (Loc, | |
5013 | Prefix => Request_Parameter, | |
5014 | Selector_Name => Name_Params), | |
5015 | New_Occurrence_Of (Formal_Entity, Loc)))); | |
8aa23fe3 TQ |
5016 | |
5017 | -- Note: the call to Set_Extra_Constrained below relies | |
5018 | -- on the fact that Object's Ekind has been set by | |
5019 | -- Build_Actual_Object_Declaration. | |
5020 | ||
16db96c5 AC |
5021 | Set_Extra_Constrained (Object, Formal_Entity); |
5022 | end; | |
5023 | end if; | |
5024 | end; | |
5025 | ||
5026 | Next (Current_Parameter); | |
5027 | end loop; | |
5028 | ||
5029 | -- Append the formal statements list at the end of regular statements | |
5030 | ||
5031 | Append_List_To (Statements, Extra_Formal_Statements); | |
5032 | ||
5033 | if Nkind (Specification (Vis_Decl)) = N_Function_Specification then | |
5034 | ||
5035 | -- The remote subprogram is a function. We build an inner block to | |
5036 | -- be able to hold a potentially unconstrained result in a | |
5037 | -- variable. | |
5038 | ||
5039 | declare | |
5040 | Etyp : constant Entity_Id := | |
3eb8fddc | 5041 | Etype (Result_Definition (Specification (Vis_Decl))); |
2287a75d AC |
5042 | Result : constant Node_Id := Make_Temporary (Loc, 'R'); |
5043 | ||
16db96c5 AC |
5044 | begin |
5045 | Inner_Decls := New_List ( | |
5046 | Make_Object_Declaration (Loc, | |
5047 | Defining_Identifier => Result, | |
5048 | Constant_Present => True, | |
5049 | Object_Definition => New_Occurrence_Of (Etyp, Loc), | |
5050 | Expression => | |
5051 | Make_Function_Call (Loc, | |
5052 | Name => Called_Subprogram, | |
5053 | Parameter_Associations => Parameter_List))); | |
5054 | ||
c3d593c9 TQ |
5055 | if Is_Class_Wide_Type (Etyp) then |
5056 | ||
5057 | -- For a remote call to a function with a class-wide type, | |
5058 | -- check that the returned value satisfies the requirements | |
5059 | -- of E.4(18). | |
5060 | ||
5061 | Append_To (Inner_Decls, | |
5062 | Make_Transportable_Check (Loc, | |
5063 | New_Occurrence_Of (Result, Loc))); | |
5064 | ||
5065 | end if; | |
5066 | ||
16db96c5 AC |
5067 | Append_To (After_Statements, |
5068 | Make_Attribute_Reference (Loc, | |
5069 | Prefix => New_Occurrence_Of (Etyp, Loc), | |
5070 | Attribute_Name => Name_Output, | |
5071 | Expressions => New_List ( | |
5072 | Make_Selected_Component (Loc, | |
5073 | Prefix => Request_Parameter, | |
5074 | Selector_Name => Name_Result), | |
5075 | New_Occurrence_Of (Result, Loc)))); | |
5076 | end; | |
5077 | ||
5078 | Append_To (Statements, | |
5079 | Make_Block_Statement (Loc, | |
5080 | Declarations => Inner_Decls, | |
5081 | Handled_Statement_Sequence => | |
5082 | Make_Handled_Sequence_Of_Statements (Loc, | |
5083 | Statements => After_Statements))); | |
5084 | ||
5085 | else | |
5086 | -- The remote subprogram is a procedure. We do not need any inner | |
5087 | -- block in this case. | |
5088 | ||
5089 | if Dynamically_Asynchronous then | |
5090 | Append_To (Decls, | |
5091 | Make_Object_Declaration (Loc, | |
5092 | Defining_Identifier => Dynamic_Async, | |
5093 | Object_Definition => | |
5094 | New_Occurrence_Of (Standard_Boolean, Loc))); | |
5095 | ||
5096 | Append_To (Statements, | |
5097 | Make_Attribute_Reference (Loc, | |
5098 | Prefix => New_Occurrence_Of (Standard_Boolean, Loc), | |
5099 | Attribute_Name => Name_Read, | |
5100 | Expressions => New_List ( | |
5101 | Make_Selected_Component (Loc, | |
5102 | Prefix => Request_Parameter, | |
5103 | Selector_Name => Name_Params), | |
5104 | New_Occurrence_Of (Dynamic_Async, Loc)))); | |
5105 | end if; | |
5106 | ||
5107 | Append_To (Statements, | |
5108 | Make_Procedure_Call_Statement (Loc, | |
5109 | Name => Called_Subprogram, | |
5110 | Parameter_Associations => Parameter_List)); | |
5111 | ||
5112 | Append_List_To (Statements, After_Statements); | |
5113 | end if; | |
5114 | ||
5115 | if Asynchronous and then not Dynamically_Asynchronous then | |
5116 | ||
5117 | -- For an asynchronous procedure, add a null exception handler | |
5118 | ||
5119 | Excep_Handlers := New_List ( | |
8aa23fe3 | 5120 | Make_Implicit_Exception_Handler (Loc, |
16db96c5 AC |
5121 | Exception_Choices => New_List (Make_Others_Choice (Loc)), |
5122 | Statements => New_List (Make_Null_Statement (Loc)))); | |
5123 | ||
5124 | else | |
5125 | -- In the other cases, if an exception is raised, then the | |
5126 | -- exception occurrence is copied into the output stream and | |
5127 | -- no other output parameter is written. | |
5128 | ||
2287a75d | 5129 | Excep_Choice := Make_Temporary (Loc, 'E'); |
16db96c5 AC |
5130 | |
5131 | Excep_Code := New_List ( | |
5132 | Make_Attribute_Reference (Loc, | |
5133 | Prefix => | |
5134 | New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), | |
5135 | Attribute_Name => Name_Write, | |
5136 | Expressions => New_List ( | |
5137 | Make_Selected_Component (Loc, | |
5138 | Prefix => Request_Parameter, | |
5139 | Selector_Name => Name_Result), | |
5140 | New_Occurrence_Of (Excep_Choice, Loc)))); | |
5141 | ||
5142 | if Dynamically_Asynchronous then | |
5143 | Excep_Code := New_List ( | |
5144 | Make_Implicit_If_Statement (Vis_Decl, | |
5145 | Condition => Make_Op_Not (Loc, | |
5146 | New_Occurrence_Of (Dynamic_Async, Loc)), | |
5147 | Then_Statements => Excep_Code)); | |
5148 | end if; | |
5149 | ||
5150 | Excep_Handlers := New_List ( | |
8aa23fe3 | 5151 | Make_Implicit_Exception_Handler (Loc, |
16db96c5 AC |
5152 | Choice_Parameter => Excep_Choice, |
5153 | Exception_Choices => New_List (Make_Others_Choice (Loc)), | |
5154 | Statements => Excep_Code)); | |
5155 | ||
5156 | end if; | |
5157 | ||
5158 | Subp_Spec := | |
5159 | Make_Procedure_Specification (Loc, | |
2287a75d | 5160 | Defining_Unit_Name => Make_Temporary (Loc, 'F'), |
16db96c5 AC |
5161 | |
5162 | Parameter_Specifications => New_List ( | |
5163 | Make_Parameter_Specification (Loc, | |
5164 | Defining_Identifier => Request_Parameter, | |
5165 | Parameter_Type => | |
5166 | New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); | |
5167 | ||
5168 | return | |
5169 | Make_Subprogram_Body (Loc, | |
5170 | Specification => Subp_Spec, | |
5171 | Declarations => Decls, | |
5172 | Handled_Statement_Sequence => | |
5173 | Make_Handled_Sequence_Of_Statements (Loc, | |
5174 | Statements => Statements, | |
5175 | Exception_Handlers => Excep_Handlers)); | |
5176 | end Build_Subprogram_Receiving_Stubs; | |
5177 | ||
5178 | ------------ | |
5179 | -- Result -- | |
5180 | ------------ | |
5181 | ||
5182 | function Result return Node_Id is | |
5183 | begin | |
5184 | return Make_Identifier (Loc, Name_V); | |
5185 | end Result; | |
5186 | ||
a3068ca6 AC |
5187 | ----------------------- |
5188 | -- RPC_Receiver_Decl -- | |
5189 | ----------------------- | |
5190 | ||
5191 | function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is | |
5192 | Loc : constant Source_Ptr := Sloc (RACW_Type); | |
5193 | Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); | |
5194 | ||
5195 | begin | |
5196 | -- No RPC receiver for remote access-to-subprogram | |
5197 | ||
5198 | if Is_RAS then | |
5199 | return Empty; | |
5200 | end if; | |
5201 | ||
5202 | return | |
5203 | Make_Subprogram_Declaration (Loc, | |
5204 | Build_RPC_Receiver_Specification | |
5205 | (RPC_Receiver => Make_Temporary (Loc, 'R'), | |
5206 | Request_Parameter => Make_Defining_Identifier (Loc, Name_R))); | |
5207 | end RPC_Receiver_Decl; | |
5208 | ||
16db96c5 AC |
5209 | ---------------------- |
5210 | -- Stream_Parameter -- | |
5211 | ---------------------- | |
5212 | ||
5213 | function Stream_Parameter return Node_Id is | |
5214 | begin | |
5215 | return Make_Identifier (Loc, Name_S); | |
5216 | end Stream_Parameter; | |
5217 | ||
5218 | end GARLIC_Support; | |
5219 | ||
8aa23fe3 TQ |
5220 | ------------------------------- |
5221 | -- Get_And_Reset_RACW_Bodies -- | |
5222 | ------------------------------- | |
5223 | ||
5224 | function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is | |
c6f39437 AC |
5225 | Desig : constant Entity_Id := |
5226 | Etype (Designated_Type (RACW_Type)); | |
5227 | ||
8aa23fe3 TQ |
5228 | Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig); |
5229 | ||
5230 | Body_Decls : List_Id; | |
5231 | -- Returned list of declarations | |
16db96c5 | 5232 | |
16db96c5 | 5233 | begin |
8aa23fe3 TQ |
5234 | if Stub_Elements = Empty_Stub_Structure then |
5235 | ||
5236 | -- Stub elements may be missing as a consequence of a previously | |
5237 | -- detected error. | |
5238 | ||
5239 | return No_List; | |
5240 | end if; | |
5241 | ||
5242 | Body_Decls := Stub_Elements.Body_Decls; | |
5243 | Stub_Elements.Body_Decls := No_List; | |
5244 | Stubs_Table.Set (Desig, Stub_Elements); | |
5245 | return Body_Decls; | |
5246 | end Get_And_Reset_RACW_Bodies; | |
16db96c5 | 5247 | |
d693e39d TQ |
5248 | ----------------------- |
5249 | -- Get_Stub_Elements -- | |
5250 | ----------------------- | |
5251 | ||
5252 | function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is | |
5253 | Desig : constant Entity_Id := | |
5254 | Etype (Designated_Type (RACW_Type)); | |
5255 | Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); | |
5256 | begin | |
5257 | pragma Assert (Stub_Elements /= Empty_Stub_Structure); | |
5258 | return Stub_Elements; | |
5259 | end Get_Stub_Elements; | |
5260 | ||
16db96c5 AC |
5261 | ----------------------- |
5262 | -- Get_Subprogram_Id -- | |
5263 | ----------------------- | |
5264 | ||
5265 | function Get_Subprogram_Id (Def : Entity_Id) return String_Id is | |
92869a7b | 5266 | Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier; |
16db96c5 | 5267 | begin |
92869a7b TQ |
5268 | pragma Assert (Result /= No_String); |
5269 | return Result; | |
16db96c5 AC |
5270 | end Get_Subprogram_Id; |
5271 | ||
5272 | ----------------------- | |
5273 | -- Get_Subprogram_Id -- | |
5274 | ----------------------- | |
5275 | ||
5276 | function Get_Subprogram_Id (Def : Entity_Id) return Int is | |
5277 | begin | |
5278 | return Get_Subprogram_Ids (Def).Int_Identifier; | |
5279 | end Get_Subprogram_Id; | |
5280 | ||
5281 | ------------------------ | |
5282 | -- Get_Subprogram_Ids -- | |
5283 | ------------------------ | |
5284 | ||
5285 | function Get_Subprogram_Ids | |
5286 | (Def : Entity_Id) return Subprogram_Identifiers | |
5287 | is | |
16db96c5 | 5288 | begin |
92869a7b | 5289 | return Subprogram_Identifier_Table.Get (Def); |
bd7f7a65 AC |
5290 | end Get_Subprogram_Ids; |
5291 | ||
5292 | ---------- | |
5293 | -- Hash -- | |
5294 | ---------- | |
5295 | ||
5296 | function Hash (F : Entity_Id) return Hash_Index is | |
5297 | begin | |
5298 | return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); | |
5299 | end Hash; | |
5300 | ||
5301 | function Hash (F : Name_Id) return Hash_Index is | |
5302 | begin | |
83dcc2bd | 5303 | return Hash_Index (Integer (F) mod Positive (Hash_Index'Last + 1)); |
bd7f7a65 AC |
5304 | end Hash; |
5305 | ||
5306 | -------------------------- | |
5307 | -- Input_With_Tag_Check -- | |
5308 | -------------------------- | |
5309 | ||
5310 | function Input_With_Tag_Check | |
5311 | (Loc : Source_Ptr; | |
5312 | Var_Type : Entity_Id; | |
16db96c5 | 5313 | Stream : Node_Id) return Node_Id |
bd7f7a65 AC |
5314 | is |
5315 | begin | |
5316 | return | |
5317 | Make_Subprogram_Body (Loc, | |
2287a75d AC |
5318 | Specification => |
5319 | Make_Function_Specification (Loc, | |
5320 | Defining_Unit_Name => Make_Temporary (Loc, 'S'), | |
5321 | Result_Definition => New_Occurrence_Of (Var_Type, Loc)), | |
bd7f7a65 AC |
5322 | Declarations => No_List, |
5323 | Handled_Statement_Sequence => | |
5324 | Make_Handled_Sequence_Of_Statements (Loc, New_List ( | |
5325 | Make_Tag_Check (Loc, | |
bfc2cdb1 | 5326 | Make_Simple_Return_Statement (Loc, |
bd7f7a65 AC |
5327 | Make_Attribute_Reference (Loc, |
5328 | Prefix => New_Occurrence_Of (Var_Type, Loc), | |
5329 | Attribute_Name => Name_Input, | |
5330 | Expressions => | |
16db96c5 | 5331 | New_List (Stream))))))); |
bd7f7a65 AC |
5332 | end Input_With_Tag_Check; |
5333 | ||
5334 | -------------------------------- | |
5335 | -- Is_RACW_Controlling_Formal -- | |
5336 | -------------------------------- | |
5337 | ||
5338 | function Is_RACW_Controlling_Formal | |
5339 | (Parameter : Node_Id; | |
5340 | Stub_Type : Entity_Id) return Boolean | |
5341 | is | |
5342 | Typ : Entity_Id; | |
5343 | ||
5344 | begin | |
c6f39437 AC |
5345 | -- If the kind of the parameter is E_Void, then it is not a controlling |
5346 | -- formal (this can happen in the context of RAS). | |
bd7f7a65 AC |
5347 | |
5348 | if Ekind (Defining_Identifier (Parameter)) = E_Void then | |
5349 | return False; | |
5350 | end if; | |
5351 | ||
c6f39437 AC |
5352 | -- If the parameter is not a controlling formal, then it cannot be |
5353 | -- possibly a RACW_Controlling_Formal. | |
bd7f7a65 AC |
5354 | |
5355 | if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then | |
5356 | return False; | |
5357 | end if; | |
5358 | ||
5359 | Typ := Parameter_Type (Parameter); | |
5360 | return (Nkind (Typ) = N_Access_Definition | |
5361 | and then Etype (Subtype_Mark (Typ)) = Stub_Type) | |
5362 | or else Etype (Typ) = Stub_Type; | |
5363 | end Is_RACW_Controlling_Formal; | |
5364 | ||
c3d593c9 TQ |
5365 | ------------------------------ |
5366 | -- Make_Transportable_Check -- | |
5367 | ------------------------------ | |
5368 | ||
5369 | function Make_Transportable_Check | |
5370 | (Loc : Source_Ptr; | |
5371 | Expr : Node_Id) return Node_Id is | |
5372 | begin | |
5373 | return | |
5374 | Make_Raise_Program_Error (Loc, | |
5375 | Condition => | |
5376 | Make_Op_Not (Loc, | |
5377 | Build_Get_Transportable (Loc, | |
5378 | Make_Selected_Component (Loc, | |
5379 | Prefix => Expr, | |
5380 | Selector_Name => Make_Identifier (Loc, Name_uTag)))), | |
5381 | Reason => PE_Non_Transportable_Actual); | |
5382 | end Make_Transportable_Check; | |
5383 | ||
8aa23fe3 TQ |
5384 | ----------------------------- |
5385 | -- Make_Selected_Component -- | |
5386 | ----------------------------- | |
5387 | ||
5388 | function Make_Selected_Component | |
5389 | (Loc : Source_Ptr; | |
5390 | Prefix : Entity_Id; | |
5391 | Selector_Name : Name_Id) return Node_Id | |
5392 | is | |
5393 | begin | |
5394 | return Make_Selected_Component (Loc, | |
5395 | Prefix => New_Occurrence_Of (Prefix, Loc), | |
5396 | Selector_Name => Make_Identifier (Loc, Selector_Name)); | |
5397 | end Make_Selected_Component; | |
5398 | ||
bd7f7a65 AC |
5399 | -------------------- |
5400 | -- Make_Tag_Check -- | |
5401 | -------------------- | |
5402 | ||
5403 | function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is | |
2287a75d | 5404 | Occ : constant Entity_Id := Make_Temporary (Loc, 'E'); |
bd7f7a65 AC |
5405 | |
5406 | begin | |
5407 | return Make_Block_Statement (Loc, | |
5408 | Handled_Statement_Sequence => | |
5409 | Make_Handled_Sequence_Of_Statements (Loc, | |
5410 | Statements => New_List (N), | |
5411 | ||
5412 | Exception_Handlers => New_List ( | |
8aa23fe3 | 5413 | Make_Implicit_Exception_Handler (Loc, |
bd7f7a65 AC |
5414 | Choice_Parameter => Occ, |
5415 | ||
5416 | Exception_Choices => | |
5417 | New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)), | |
5418 | ||
5419 | Statements => | |
5420 | New_List (Make_Procedure_Call_Statement (Loc, | |
5421 | New_Occurrence_Of | |
5422 | (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc), | |
5423 | New_List (New_Occurrence_Of (Occ, Loc)))))))); | |
5424 | end Make_Tag_Check; | |
5425 | ||
5426 | ---------------------------- | |
5427 | -- Need_Extra_Constrained -- | |
5428 | ---------------------------- | |
5429 | ||
5430 | function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is | |
5431 | Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter)); | |
5432 | begin | |
5433 | return Out_Present (Parameter) | |
5434 | and then Has_Discriminants (Etyp) | |
5435 | and then not Is_Constrained (Etyp) | |
83496138 | 5436 | and then Is_Definite_Subtype (Etyp); |
bd7f7a65 AC |
5437 | end Need_Extra_Constrained; |
5438 | ||
5439 | ------------------------------------ | |
5440 | -- Pack_Entity_Into_Stream_Access -- | |
5441 | ------------------------------------ | |
5442 | ||
5443 | function Pack_Entity_Into_Stream_Access | |
5444 | (Loc : Source_Ptr; | |
5445 | Stream : Node_Id; | |
5446 | Object : Entity_Id; | |
5447 | Etyp : Entity_Id := Empty) return Node_Id | |
5448 | is | |
5449 | Typ : Entity_Id; | |
5450 | ||
5451 | begin | |
5452 | if Present (Etyp) then | |
5453 | Typ := Etyp; | |
5454 | else | |
5455 | Typ := Etype (Object); | |
5456 | end if; | |
5457 | ||
5458 | return | |
5459 | Pack_Node_Into_Stream_Access (Loc, | |
5460 | Stream => Stream, | |
5461 | Object => New_Occurrence_Of (Object, Loc), | |
5462 | Etyp => Typ); | |
5463 | end Pack_Entity_Into_Stream_Access; | |
5464 | ||
5465 | --------------------------- | |
5466 | -- Pack_Node_Into_Stream -- | |
5467 | --------------------------- | |
5468 | ||
5469 | function Pack_Node_Into_Stream | |
5470 | (Loc : Source_Ptr; | |
5471 | Stream : Entity_Id; | |
5472 | Object : Node_Id; | |
5473 | Etyp : Entity_Id) return Node_Id | |
5474 | is | |
5475 | Write_Attribute : Name_Id := Name_Write; | |
5476 | ||
5477 | begin | |
5478 | if not Is_Constrained (Etyp) then | |
5479 | Write_Attribute := Name_Output; | |
5480 | end if; | |
5481 | ||
5482 | return | |
5483 | Make_Attribute_Reference (Loc, | |
5484 | Prefix => New_Occurrence_Of (Etyp, Loc), | |
5485 | Attribute_Name => Write_Attribute, | |
5486 | Expressions => New_List ( | |
5487 | Make_Attribute_Reference (Loc, | |
5488 | Prefix => New_Occurrence_Of (Stream, Loc), | |
5489 | Attribute_Name => Name_Access), | |
5490 | Object)); | |
5491 | end Pack_Node_Into_Stream; | |
5492 | ||
5493 | ---------------------------------- | |
5494 | -- Pack_Node_Into_Stream_Access -- | |
5495 | ---------------------------------- | |
5496 | ||
5497 | function Pack_Node_Into_Stream_Access | |
5498 | (Loc : Source_Ptr; | |
5499 | Stream : Node_Id; | |
5500 | Object : Node_Id; | |
5501 | Etyp : Entity_Id) return Node_Id | |
5502 | is | |
5503 | Write_Attribute : Name_Id := Name_Write; | |
5504 | ||
5505 | begin | |
5506 | if not Is_Constrained (Etyp) then | |
5507 | Write_Attribute := Name_Output; | |
5508 | end if; | |
5509 | ||
5510 | return | |
5511 | Make_Attribute_Reference (Loc, | |
5512 | Prefix => New_Occurrence_Of (Etyp, Loc), | |
5513 | Attribute_Name => Write_Attribute, | |
5514 | Expressions => New_List ( | |
5515 | Stream, | |
5516 | Object)); | |
5517 | end Pack_Node_Into_Stream_Access; | |
5518 | ||
5519 | --------------------- | |
5520 | -- PolyORB_Support -- | |
5521 | --------------------- | |
5522 | ||
5523 | package body PolyORB_Support is | |
5524 | ||
5525 | -- Local subprograms | |
5526 | ||
5527 | procedure Add_RACW_Read_Attribute | |
5528 | (RACW_Type : Entity_Id; | |
5529 | Stub_Type : Entity_Id; | |
5530 | Stub_Type_Access : Entity_Id; | |
8aa23fe3 TQ |
5531 | Body_Decls : List_Id); |
5532 | -- Add Read attribute for the RACW type. The declaration and attribute | |
5533 | -- definition clauses are inserted right after the declaration of | |
7f0b5314 TQ |
5534 | -- RACW_Type. If Body_Decls is not No_List, the subprogram body is |
5535 | -- appended to it (case where the RACW declaration is in the main unit). | |
bd7f7a65 AC |
5536 | |
5537 | procedure Add_RACW_Write_Attribute | |
5538 | (RACW_Type : Entity_Id; | |
5539 | Stub_Type : Entity_Id; | |
5540 | Stub_Type_Access : Entity_Id; | |
8aa23fe3 TQ |
5541 | Body_Decls : List_Id); |
5542 | -- Same as above for the Write attribute | |
bd7f7a65 AC |
5543 | |
5544 | procedure Add_RACW_From_Any | |
5545 | (RACW_Type : Entity_Id; | |
8aa23fe3 | 5546 | Body_Decls : List_Id); |
bd7f7a65 AC |
5547 | -- Add the From_Any TSS for this RACW type |
5548 | ||
5549 | procedure Add_RACW_To_Any | |
d693e39d | 5550 | (RACW_Type : Entity_Id; |
8aa23fe3 | 5551 | Body_Decls : List_Id); |
bd7f7a65 AC |
5552 | -- Add the To_Any TSS for this RACW type |
5553 | ||
5554 | procedure Add_RACW_TypeCode | |
5555 | (Designated_Type : Entity_Id; | |
5556 | RACW_Type : Entity_Id; | |
8aa23fe3 | 5557 | Body_Decls : List_Id); |
bd7f7a65 AC |
5558 | -- Add the TypeCode TSS for this RACW type |
5559 | ||
c857f5ed | 5560 | procedure Add_RAS_From_Any (RAS_Type : Entity_Id); |
bd7f7a65 AC |
5561 | -- Add the From_Any TSS for this RAS type |
5562 | ||
c857f5ed | 5563 | procedure Add_RAS_To_Any (RAS_Type : Entity_Id); |
bd7f7a65 AC |
5564 | -- Add the To_Any TSS for this RAS type |
5565 | ||
c857f5ed | 5566 | procedure Add_RAS_TypeCode (RAS_Type : Entity_Id); |
bd7f7a65 AC |
5567 | -- Add the TypeCode TSS for this RAS type |
5568 | ||
5569 | procedure Add_RAS_Access_TSS (N : Node_Id); | |
5570 | -- Add a subprogram body for RAS Access TSS | |
5571 | ||
82c80734 RD |
5572 | ------------------------------------- |
5573 | -- Add_Obj_RPC_Receiver_Completion -- | |
5574 | ------------------------------------- | |
5575 | ||
5576 | procedure Add_Obj_RPC_Receiver_Completion | |
5577 | (Loc : Source_Ptr; | |
5578 | Decls : List_Id; | |
5579 | RPC_Receiver : Entity_Id; | |
5580 | Stub_Elements : Stub_Structure) | |
5581 | is | |
5582 | Desig : constant Entity_Id := | |
5583 | Etype (Designated_Type (Stub_Elements.RACW_Type)); | |
5584 | begin | |
5585 | Append_To (Decls, | |
5586 | Make_Procedure_Call_Statement (Loc, | |
5587 | Name => | |
5588 | New_Occurrence_Of ( | |
5589 | RTE (RE_Register_Obj_Receiving_Stub), Loc), | |
5590 | ||
5591 | Parameter_Associations => New_List ( | |
5592 | ||
5593 | -- Name | |
5594 | ||
5595 | Make_String_Literal (Loc, | |
72267417 | 5596 | Fully_Qualified_Name_String (Desig, Append_NUL => False)), |
82c80734 RD |
5597 | |
5598 | -- Handler | |
5599 | ||
5600 | Make_Attribute_Reference (Loc, | |
5601 | Prefix => | |
5602 | New_Occurrence_Of ( | |
5603 | Defining_Unit_Name (Parent (RPC_Receiver)), Loc), | |
5604 | Attribute_Name => | |
5605 | Name_Access), | |
5606 | ||
5607 | -- Receiver | |
5608 | ||
5609 | Make_Attribute_Reference (Loc, | |
5610 | Prefix => | |
5611 | New_Occurrence_Of ( | |
5612 | Defining_Identifier ( | |
5613 | Stub_Elements.RPC_Receiver_Decl), Loc), | |
5614 | Attribute_Name => | |
5615 | Name_Access)))); | |
5616 | end Add_Obj_RPC_Receiver_Completion; | |
5617 | ||
bd7f7a65 AC |
5618 | ----------------------- |
5619 | -- Add_RACW_Features -- | |
5620 | ----------------------- | |
5621 | ||
5622 | procedure Add_RACW_Features | |
5623 | (RACW_Type : Entity_Id; | |
5624 | Desig : Entity_Id; | |
5625 | Stub_Type : Entity_Id; | |
5626 | Stub_Type_Access : Entity_Id; | |
5627 | RPC_Receiver_Decl : Node_Id; | |
8aa23fe3 | 5628 | Body_Decls : List_Id) |
bd7f7a65 | 5629 | is |
bd7f7a65 | 5630 | pragma Unreferenced (RPC_Receiver_Decl); |
bd7f7a65 AC |
5631 | |
5632 | begin | |
5633 | Add_RACW_From_Any | |
5634 | (RACW_Type => RACW_Type, | |
8aa23fe3 | 5635 | Body_Decls => Body_Decls); |
bd7f7a65 AC |
5636 | |
5637 | Add_RACW_To_Any | |
d693e39d | 5638 | (RACW_Type => RACW_Type, |
8aa23fe3 | 5639 | Body_Decls => Body_Decls); |
bd7f7a65 | 5640 | |
bd7f7a65 AC |
5641 | Add_RACW_Write_Attribute |
5642 | (RACW_Type => RACW_Type, | |
5643 | Stub_Type => Stub_Type, | |
5644 | Stub_Type_Access => Stub_Type_Access, | |
8aa23fe3 | 5645 | Body_Decls => Body_Decls); |
bd7f7a65 AC |
5646 | |
5647 | Add_RACW_Read_Attribute | |
5648 | (RACW_Type => RACW_Type, | |
5649 | Stub_Type => Stub_Type, | |
5650 | Stub_Type_Access => Stub_Type_Access, | |
8aa23fe3 | 5651 | Body_Decls => Body_Decls); |
bd7f7a65 AC |
5652 | |
5653 | Add_RACW_TypeCode | |
5654 | (Designated_Type => Desig, | |
5655 | RACW_Type => RACW_Type, | |
8aa23fe3 | 5656 | Body_Decls => Body_Decls); |
bd7f7a65 AC |
5657 | end Add_RACW_Features; |
5658 | ||
5659 | ----------------------- | |
5660 | -- Add_RACW_From_Any -- | |
5661 | ----------------------- | |
5662 | ||
5663 | procedure Add_RACW_From_Any | |
5664 | (RACW_Type : Entity_Id; | |
8aa23fe3 | 5665 | Body_Decls : List_Id) |
bd7f7a65 AC |
5666 | is |
5667 | Loc : constant Source_Ptr := Sloc (RACW_Type); | |
5668 | Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); | |
bd7f7a65 | 5669 | Fnam : constant Entity_Id := |
7f0b5314 TQ |
5670 | Make_Defining_Identifier (Loc, |
5671 | Chars => New_External_Name (Chars (RACW_Type), 'F')); | |
bd7f7a65 AC |
5672 | |
5673 | Func_Spec : Node_Id; | |
5674 | Func_Decl : Node_Id; | |
5675 | Func_Body : Node_Id; | |
5676 | ||
bd7f7a65 | 5677 | Statements : List_Id; |
bd7f7a65 AC |
5678 | -- Various parts of the subprogram |
5679 | ||
c6f39437 AC |
5680 | Any_Parameter : constant Entity_Id := |
5681 | Make_Defining_Identifier (Loc, Name_A); | |
7f0b5314 | 5682 | |
bd7f7a65 AC |
5683 | Asynchronous_Flag : constant Entity_Id := |
5684 | Asynchronous_Flags_Table.Get (RACW_Type); | |
5685 | -- The flag object declared in Add_RACW_Asynchronous_Flag | |
5686 | ||
5687 | begin | |
7f0b5314 TQ |
5688 | Func_Spec := |
5689 | Make_Function_Specification (Loc, | |
5690 | Defining_Unit_Name => | |
5691 | Fnam, | |
5692 | Parameter_Specifications => New_List ( | |
5693 | Make_Parameter_Specification (Loc, | |
5694 | Defining_Identifier => | |
5695 | Any_Parameter, | |
5696 | Parameter_Type => | |
5697 | New_Occurrence_Of (RTE (RE_Any), Loc))), | |
5698 | Result_Definition => New_Occurrence_Of (RACW_Type, Loc)); | |
5699 | ||
5700 | -- NOTE: The usage occurrences of RACW_Parameter must refer to the | |
5701 | -- entity in the declaration spec, not those of the body spec. | |
5702 | ||
5703 | Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); | |
5704 | Insert_After (Declaration_Node (RACW_Type), Func_Decl); | |
5705 | Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any); | |
5706 | ||
5707 | if No (Body_Decls) then | |
5708 | return; | |
5709 | end if; | |
8aa23fe3 | 5710 | |
8aa23fe3 TQ |
5711 | -- ??? Issue with asynchronous calls here: the Asynchronous flag is |
5712 | -- set on the stub type if, and only if, the RACW type has a pragma | |
5713 | -- Asynchronous. This is incorrect for RACWs that implement RAS | |
5714 | -- types, because in that case the /designated subprogram/ (not the | |
5715 | -- type) might be asynchronous, and that causes the stub to need to | |
5716 | -- be asynchronous too. A solution is to transport a RAS as a struct | |
5717 | -- containing a RACW and an asynchronous flag, and to properly alter | |
5718 | -- the Asynchronous component in the stub type in the RAS's _From_Any | |
5719 | -- TSS. | |
bd7f7a65 | 5720 | |
d693e39d | 5721 | Statements := New_List ( |
bfc2cdb1 | 5722 | Make_Simple_Return_Statement (Loc, |
bd7f7a65 | 5723 | Expression => Unchecked_Convert_To (RACW_Type, |
d693e39d TQ |
5724 | Make_Function_Call (Loc, |
5725 | Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc), | |
5726 | Parameter_Associations => New_List ( | |
5727 | Make_Function_Call (Loc, | |
5728 | Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), | |
5729 | Parameter_Associations => New_List ( | |
5730 | New_Occurrence_Of (Any_Parameter, Loc))), | |
5731 | Build_Stub_Tag (Loc, RACW_Type), | |
5732 | New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), | |
5733 | New_Occurrence_Of (Asynchronous_Flag, Loc)))))); | |
bd7f7a65 | 5734 | |
bd7f7a65 AC |
5735 | Func_Body := |
5736 | Make_Subprogram_Body (Loc, | |
d693e39d TQ |
5737 | Specification => Copy_Specification (Loc, Func_Spec), |
5738 | Declarations => No_List, | |
bd7f7a65 AC |
5739 | Handled_Statement_Sequence => |
5740 | Make_Handled_Sequence_Of_Statements (Loc, | |
5741 | Statements => Statements)); | |
5742 | ||
8aa23fe3 | 5743 | Append_To (Body_Decls, Func_Body); |
bd7f7a65 AC |
5744 | end Add_RACW_From_Any; |
5745 | ||
5746 | ----------------------------- | |
5747 | -- Add_RACW_Read_Attribute -- | |
5748 | ----------------------------- | |
5749 | ||
5750 | procedure Add_RACW_Read_Attribute | |
5751 | (RACW_Type : Entity_Id; | |
5752 | Stub_Type : Entity_Id; | |
5753 | Stub_Type_Access : Entity_Id; | |
8aa23fe3 | 5754 | Body_Decls : List_Id) |
bd7f7a65 | 5755 | is |
bd7f7a65 | 5756 | pragma Unreferenced (Stub_Type, Stub_Type_Access); |
8c64de1e | 5757 | |
bd7f7a65 AC |
5758 | Loc : constant Source_Ptr := Sloc (RACW_Type); |
5759 | ||
5760 | Proc_Decl : Node_Id; | |
5761 | Attr_Decl : Node_Id; | |
5762 | ||
5763 | Body_Node : Node_Id; | |
5764 | ||
d693e39d TQ |
5765 | Decls : constant List_Id := New_List; |
5766 | Statements : constant List_Id := New_List; | |
5767 | Reference : constant Entity_Id := | |
5768 | Make_Defining_Identifier (Loc, Name_R); | |
bd7f7a65 AC |
5769 | -- Various parts of the procedure |
5770 | ||
2287a75d | 5771 | Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); |
d693e39d TQ |
5772 | |
5773 | Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); | |
7f0b5314 | 5774 | |
bd7f7a65 AC |
5775 | Asynchronous_Flag : constant Entity_Id := |
5776 | Asynchronous_Flags_Table.Get (RACW_Type); | |
5777 | pragma Assert (Present (Asynchronous_Flag)); | |
5778 | ||
5779 | function Stream_Parameter return Node_Id; | |
5780 | function Result return Node_Id; | |
d693e39d | 5781 | |
bd7f7a65 AC |
5782 | -- Functions to create occurrences of the formal parameter names |
5783 | ||
5784 | ------------ | |
5785 | -- Result -- | |
5786 | ------------ | |
5787 | ||
5788 | function Result return Node_Id is | |
5789 | begin | |
5790 | return Make_Identifier (Loc, Name_V); | |
5791 | end Result; | |
5792 | ||
5793 | ---------------------- | |
5794 | -- Stream_Parameter -- | |
5795 | ---------------------- | |
5796 | ||
5797 | function Stream_Parameter return Node_Id is | |
5798 | begin | |
5799 | return Make_Identifier (Loc, Name_S); | |
5800 | end Stream_Parameter; | |
5801 | ||
5802 | -- Start of processing for Add_RACW_Read_Attribute | |
5803 | ||
5804 | begin | |
7f0b5314 TQ |
5805 | Build_Stream_Procedure |
5806 | (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True); | |
5807 | ||
5808 | Proc_Decl := Make_Subprogram_Declaration (Loc, | |
5809 | Copy_Specification (Loc, Specification (Body_Node))); | |
5810 | ||
5811 | Attr_Decl := | |
5812 | Make_Attribute_Definition_Clause (Loc, | |
5813 | Name => New_Occurrence_Of (RACW_Type, Loc), | |
5814 | Chars => Name_Read, | |
5815 | Expression => | |
5816 | New_Occurrence_Of ( | |
5817 | Defining_Unit_Name (Specification (Proc_Decl)), Loc)); | |
5818 | ||
5819 | Insert_After (Declaration_Node (RACW_Type), Proc_Decl); | |
5820 | Insert_After (Proc_Decl, Attr_Decl); | |
5821 | ||
5822 | if No (Body_Decls) then | |
5823 | return; | |
5824 | end if; | |
5825 | ||
d693e39d | 5826 | Append_To (Decls, |
bd7f7a65 | 5827 | Make_Object_Declaration (Loc, |
d693e39d TQ |
5828 | Defining_Identifier => |
5829 | Reference, | |
5830 | Object_Definition => | |
bd7f7a65 AC |
5831 | New_Occurrence_Of (RTE (RE_Object_Ref), Loc))); |
5832 | ||
7f0b5314 | 5833 | Append_List_To (Statements, New_List ( |
bd7f7a65 AC |
5834 | Make_Attribute_Reference (Loc, |
5835 | Prefix => | |
5836 | New_Occurrence_Of (RTE (RE_Object_Ref), Loc), | |
5837 | Attribute_Name => Name_Read, | |
5838 | Expressions => New_List ( | |
5839 | Stream_Parameter, | |
d693e39d TQ |
5840 | New_Occurrence_Of (Reference, Loc))), |
5841 | ||
bd7f7a65 | 5842 | Make_Assignment_Statement (Loc, |
d693e39d | 5843 | Name => |
bd7f7a65 AC |
5844 | Result, |
5845 | Expression => | |
d693e39d | 5846 | Unchecked_Convert_To (RACW_Type, |
bd7f7a65 | 5847 | Make_Function_Call (Loc, |
d693e39d TQ |
5848 | Name => |
5849 | New_Occurrence_Of (RTE (RE_Get_RACW), Loc), | |
bd7f7a65 | 5850 | Parameter_Associations => New_List ( |
d693e39d TQ |
5851 | New_Occurrence_Of (Reference, Loc), |
5852 | Build_Stub_Tag (Loc, RACW_Type), | |
5853 | New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), | |
5854 | New_Occurrence_Of (Asynchronous_Flag, Loc))))))); | |
bd7f7a65 | 5855 | |
bd7f7a65 | 5856 | Set_Declarations (Body_Node, Decls); |
8aa23fe3 | 5857 | Append_To (Body_Decls, Body_Node); |
bd7f7a65 AC |
5858 | end Add_RACW_Read_Attribute; |
5859 | ||
5860 | --------------------- | |
5861 | -- Add_RACW_To_Any -- | |
5862 | --------------------- | |
5863 | ||
5864 | procedure Add_RACW_To_Any | |
d693e39d | 5865 | (RACW_Type : Entity_Id; |
8aa23fe3 | 5866 | Body_Decls : List_Id) |
bd7f7a65 AC |
5867 | is |
5868 | Loc : constant Source_Ptr := Sloc (RACW_Type); | |
5869 | ||
7f0b5314 TQ |
5870 | Fnam : constant Entity_Id := |
5871 | Make_Defining_Identifier (Loc, | |
5872 | Chars => New_External_Name (Chars (RACW_Type), 'T')); | |
bd7f7a65 | 5873 | |
d693e39d TQ |
5874 | Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); |
5875 | ||
bd7f7a65 | 5876 | Stub_Elements : constant Stub_Structure := |
d693e39d | 5877 | Get_Stub_Elements (RACW_Type); |
bd7f7a65 AC |
5878 | |
5879 | Func_Spec : Node_Id; | |
5880 | Func_Decl : Node_Id; | |
5881 | Func_Body : Node_Id; | |
5882 | ||
c6f39437 AC |
5883 | Decls : List_Id; |
5884 | Statements : List_Id; | |
bd7f7a65 AC |
5885 | -- Various parts of the subprogram |
5886 | ||
7f0b5314 TQ |
5887 | RACW_Parameter : constant Entity_Id := |
5888 | Make_Defining_Identifier (Loc, Name_R); | |
bd7f7a65 | 5889 | |
2287a75d AC |
5890 | Reference : constant Entity_Id := Make_Temporary (Loc, 'R'); |
5891 | Any : constant Entity_Id := Make_Temporary (Loc, 'A'); | |
bd7f7a65 AC |
5892 | |
5893 | begin | |
7f0b5314 TQ |
5894 | Func_Spec := |
5895 | Make_Function_Specification (Loc, | |
5896 | Defining_Unit_Name => | |
5897 | Fnam, | |
5898 | Parameter_Specifications => New_List ( | |
5899 | Make_Parameter_Specification (Loc, | |
5900 | Defining_Identifier => | |
5901 | RACW_Parameter, | |
5902 | Parameter_Type => | |
5903 | New_Occurrence_Of (RACW_Type, Loc))), | |
5904 | Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); | |
5905 | ||
5906 | -- NOTE: The usage occurrences of RACW_Parameter must refer to the | |
5907 | -- entity in the declaration spec, not in the body spec. | |
5908 | ||
5909 | Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); | |
5910 | ||
5911 | Insert_After (Declaration_Node (RACW_Type), Func_Decl); | |
5912 | Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any); | |
5913 | ||
5914 | if No (Body_Decls) then | |
5915 | return; | |
5916 | end if; | |
8aa23fe3 | 5917 | |
d693e39d TQ |
5918 | -- Generate: |
5919 | ||
5920 | -- R : constant Object_Ref := | |
5921 | -- Get_Reference | |
5922 | -- (Address!(RACW), | |
5923 | -- "typ", | |
5924 | -- Stub_Type'Tag, | |
5925 | -- Is_RAS, | |
5926 | -- RPC_Receiver'Access); | |
5927 | -- A : Any; | |
bd7f7a65 AC |
5928 | |
5929 | Decls := New_List ( | |
5930 | Make_Object_Declaration (Loc, | |
d693e39d TQ |
5931 | Defining_Identifier => Reference, |
5932 | Constant_Present => True, | |
5933 | Object_Definition => | |
5934 | New_Occurrence_Of (RTE (RE_Object_Ref), Loc), | |
5935 | Expression => | |
5936 | Make_Function_Call (Loc, | |
5937 | Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), | |
5938 | Parameter_Associations => New_List ( | |
5939 | Unchecked_Convert_To (RTE (RE_Address), | |
5940 | New_Occurrence_Of (RACW_Parameter, Loc)), | |
5941 | Make_String_Literal (Loc, | |
afbcdf5e | 5942 | Strval => Fully_Qualified_Name_String |
72267417 AC |
5943 | (Etype (Designated_Type (RACW_Type)), |
5944 | Append_NUL => False)), | |
d693e39d TQ |
5945 | Build_Stub_Tag (Loc, RACW_Type), |
5946 | New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), | |
5947 | Make_Attribute_Reference (Loc, | |
5948 | Prefix => | |
5949 | New_Occurrence_Of | |
5950 | (Defining_Identifier | |
5951 | (Stub_Elements.RPC_Receiver_Decl), Loc), | |
5952 | Attribute_Name => Name_Access)))), | |
bd7f7a65 | 5953 | |
d693e39d TQ |
5954 | Make_Object_Declaration (Loc, |
5955 | Defining_Identifier => Any, | |
5956 | Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc))); | |
bd7f7a65 | 5957 | |
d693e39d | 5958 | -- Generate: |
bd7f7a65 | 5959 | |
d693e39d TQ |
5960 | -- Any := TA_ObjRef (Reference); |
5961 | -- Set_TC (Any, RPC_Receiver.Obj_TypeCode); | |
5962 | -- return Any; | |
bd7f7a65 AC |
5963 | |
5964 | Statements := New_List ( | |
bd7f7a65 | 5965 | Make_Assignment_Statement (Loc, |
d693e39d | 5966 | Name => New_Occurrence_Of (Any, Loc), |
bd7f7a65 AC |
5967 | Expression => |
5968 | Make_Function_Call (Loc, | |
5969 | Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc), | |
5970 | Parameter_Associations => New_List ( | |
5971 | New_Occurrence_Of (Reference, Loc)))), | |
d693e39d | 5972 | |
bd7f7a65 | 5973 | Make_Procedure_Call_Statement (Loc, |
d693e39d | 5974 | Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), |
bd7f7a65 AC |
5975 | Parameter_Associations => New_List ( |
5976 | New_Occurrence_Of (Any, Loc), | |
5977 | Make_Selected_Component (Loc, | |
5978 | Prefix => | |
bd7f7a65 | 5979 | Defining_Identifier ( |
16db96c5 AC |
5980 | Stub_Elements.RPC_Receiver_Decl), |
5981 | Selector_Name => Name_Obj_TypeCode))), | |
d693e39d | 5982 | |
bfc2cdb1 | 5983 | Make_Simple_Return_Statement (Loc, |
d693e39d | 5984 | Expression => New_Occurrence_Of (Any, Loc))); |
bd7f7a65 | 5985 | |
bd7f7a65 AC |
5986 | Func_Body := |
5987 | Make_Subprogram_Body (Loc, | |
d693e39d | 5988 | Specification => Copy_Specification (Loc, Func_Spec), |
bd7f7a65 AC |
5989 | Declarations => Decls, |
5990 | Handled_Statement_Sequence => | |
5991 | Make_Handled_Sequence_Of_Statements (Loc, | |
5992 | Statements => Statements)); | |
8aa23fe3 | 5993 | Append_To (Body_Decls, Func_Body); |
bd7f7a65 AC |
5994 | end Add_RACW_To_Any; |
5995 | ||
5996 | ----------------------- | |
5997 | -- Add_RACW_TypeCode -- | |
5998 | ----------------------- | |
5999 | ||
6000 | procedure Add_RACW_TypeCode | |
6001 | (Designated_Type : Entity_Id; | |
6002 | RACW_Type : Entity_Id; | |
8aa23fe3 | 6003 | Body_Decls : List_Id) |
bd7f7a65 AC |
6004 | is |
6005 | Loc : constant Source_Ptr := Sloc (RACW_Type); | |
6006 | ||
7f0b5314 TQ |
6007 | Fnam : constant Entity_Id := |
6008 | Make_Defining_Identifier (Loc, | |
6009 | Chars => New_External_Name (Chars (RACW_Type), 'Y')); | |
bd7f7a65 AC |
6010 | |
6011 | Stub_Elements : constant Stub_Structure := | |
6012 | Stubs_Table.Get (Designated_Type); | |
6013 | pragma Assert (Stub_Elements /= Empty_Stub_Structure); | |
6014 | ||
6015 | Func_Spec : Node_Id; | |
6016 | Func_Decl : Node_Id; | |
6017 | Func_Body : Node_Id; | |
6018 | ||
bd7f7a65 | 6019 | begin |
8aa23fe3 TQ |
6020 | -- The spec for this subprogram has a dummy 'access RACW' argument, |
6021 | -- which serves only for overloading purposes. | |
bd7f7a65 AC |
6022 | |
6023 | Func_Spec := | |
6024 | Make_Function_Specification (Loc, | |
d693e39d TQ |
6025 | Defining_Unit_Name => Fnam, |
6026 | Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); | |
bd7f7a65 | 6027 | |
8aa23fe3 TQ |
6028 | -- NOTE: The usage occurrences of RACW_Parameter must refer to the |
6029 | -- entity in the declaration spec, not those of the body spec. | |
bd7f7a65 AC |
6030 | |
6031 | Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); | |
7f0b5314 TQ |
6032 | Insert_After (Declaration_Node (RACW_Type), Func_Decl); |
6033 | Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode); | |
6034 | ||
6035 | if No (Body_Decls) then | |
6036 | return; | |
6037 | end if; | |
bd7f7a65 AC |
6038 | |
6039 | Func_Body := | |
6040 | Make_Subprogram_Body (Loc, | |
d693e39d | 6041 | Specification => Copy_Specification (Loc, Func_Spec), |
bd7f7a65 AC |
6042 | Declarations => Empty_List, |
6043 | Handled_Statement_Sequence => | |
6044 | Make_Handled_Sequence_Of_Statements (Loc, | |
6045 | Statements => New_List ( | |
bfc2cdb1 | 6046 | Make_Simple_Return_Statement (Loc, |
bd7f7a65 AC |
6047 | Expression => |
6048 | Make_Selected_Component (Loc, | |
6049 | Prefix => | |
d693e39d TQ |
6050 | Defining_Identifier |
6051 | (Stub_Elements.RPC_Receiver_Decl), | |
16db96c5 | 6052 | Selector_Name => Name_Obj_TypeCode))))); |
bd7f7a65 | 6053 | |
8aa23fe3 | 6054 | Append_To (Body_Decls, Func_Body); |
bd7f7a65 AC |
6055 | end Add_RACW_TypeCode; |
6056 | ||
6057 | ------------------------------ | |
6058 | -- Add_RACW_Write_Attribute -- | |
6059 | ------------------------------ | |
6060 | ||
6061 | procedure Add_RACW_Write_Attribute | |
6062 | (RACW_Type : Entity_Id; | |
6063 | Stub_Type : Entity_Id; | |
6064 | Stub_Type_Access : Entity_Id; | |
8aa23fe3 | 6065 | Body_Decls : List_Id) |
bd7f7a65 | 6066 | is |
8aa23fe3 | 6067 | pragma Unreferenced (Stub_Type, Stub_Type_Access); |
bd7f7a65 | 6068 | |
8aa23fe3 TQ |
6069 | Loc : constant Source_Ptr := Sloc (RACW_Type); |
6070 | ||
d693e39d TQ |
6071 | Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); |
6072 | ||
6073 | Stub_Elements : constant Stub_Structure := | |
6074 | Get_Stub_Elements (RACW_Type); | |
6075 | ||
bd7f7a65 AC |
6076 | Body_Node : Node_Id; |
6077 | Proc_Decl : Node_Id; | |
6078 | Attr_Decl : Node_Id; | |
6079 | ||
d693e39d | 6080 | Statements : constant List_Id := New_List; |
2287a75d | 6081 | Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); |
bd7f7a65 AC |
6082 | |
6083 | function Stream_Parameter return Node_Id; | |
6084 | function Object return Node_Id; | |
6085 | -- Functions to create occurrences of the formal parameter names | |
6086 | ||
6087 | ------------ | |
6088 | -- Object -- | |
6089 | ------------ | |
6090 | ||
6091 | function Object return Node_Id is | |
bd7f7a65 | 6092 | begin |
d693e39d | 6093 | return Make_Identifier (Loc, Name_V); |
bd7f7a65 AC |
6094 | end Object; |
6095 | ||
6096 | ---------------------- | |
6097 | -- Stream_Parameter -- | |
6098 | ---------------------- | |
6099 | ||
6100 | function Stream_Parameter return Node_Id is | |
6101 | begin | |
6102 | return Make_Identifier (Loc, Name_S); | |
6103 | end Stream_Parameter; | |
6104 | ||
6105 | -- Start of processing for Add_RACW_Write_Attribute | |
6106 | ||
6107 | begin | |
bd7f7a65 | 6108 | Build_Stream_Procedure |
7f0b5314 | 6109 | (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); |
bd7f7a65 AC |
6110 | |
6111 | Proc_Decl := | |
6112 | Make_Subprogram_Declaration (Loc, | |
6113 | Copy_Specification (Loc, Specification (Body_Node))); | |
6114 | ||
6115 | Attr_Decl := | |
6116 | Make_Attribute_Definition_Clause (Loc, | |
6117 | Name => New_Occurrence_Of (RACW_Type, Loc), | |
6118 | Chars => Name_Write, | |
6119 | Expression => | |
6120 | New_Occurrence_Of ( | |
6121 | Defining_Unit_Name (Specification (Proc_Decl)), Loc)); | |
6122 | ||
6123 | Insert_After (Declaration_Node (RACW_Type), Proc_Decl); | |
6124 | Insert_After (Proc_Decl, Attr_Decl); | |
7f0b5314 TQ |
6125 | |
6126 | if No (Body_Decls) then | |
6127 | return; | |
6128 | end if; | |
6129 | ||
6130 | Append_To (Statements, | |
6131 | Pack_Node_Into_Stream_Access (Loc, | |
6132 | Stream => Stream_Parameter, | |
6133 | Object => | |
6134 | Make_Function_Call (Loc, | |
d693e39d | 6135 | Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), |
7f0b5314 | 6136 | Parameter_Associations => New_List ( |
d693e39d TQ |
6137 | Unchecked_Convert_To (RTE (RE_Address), Object), |
6138 | Make_String_Literal (Loc, | |
afbcdf5e | 6139 | Strval => Fully_Qualified_Name_String |
72267417 AC |
6140 | (Etype (Designated_Type (RACW_Type)), |
6141 | Append_NUL => False)), | |
d693e39d TQ |
6142 | Build_Stub_Tag (Loc, RACW_Type), |
6143 | New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), | |
6144 | Make_Attribute_Reference (Loc, | |
6145 | Prefix => | |
6146 | New_Occurrence_Of | |
6147 | (Defining_Identifier | |
6148 | (Stub_Elements.RPC_Receiver_Decl), Loc), | |
6149 | Attribute_Name => Name_Access))), | |
6150 | ||
7f0b5314 TQ |
6151 | Etyp => RTE (RE_Object_Ref))); |
6152 | ||
8aa23fe3 | 6153 | Append_To (Body_Decls, Body_Node); |
bd7f7a65 AC |
6154 | end Add_RACW_Write_Attribute; |
6155 | ||
6156 | ----------------------- | |
6157 | -- Add_RAST_Features -- | |
6158 | ----------------------- | |
6159 | ||
6160 | procedure Add_RAST_Features | |
6161 | (Vis_Decl : Node_Id; | |
c857f5ed | 6162 | RAS_Type : Entity_Id) |
bd7f7a65 AC |
6163 | is |
6164 | begin | |
6165 | Add_RAS_Access_TSS (Vis_Decl); | |
6166 | ||
c857f5ed TQ |
6167 | Add_RAS_From_Any (RAS_Type); |
6168 | Add_RAS_TypeCode (RAS_Type); | |
bd7f7a65 AC |
6169 | |
6170 | -- To_Any uses TypeCode, and therefore needs to be generated last | |
6171 | ||
c857f5ed | 6172 | Add_RAS_To_Any (RAS_Type); |
bd7f7a65 AC |
6173 | end Add_RAST_Features; |
6174 | ||
6175 | ------------------------ | |
6176 | -- Add_RAS_Access_TSS -- | |
6177 | ------------------------ | |
6178 | ||
6179 | procedure Add_RAS_Access_TSS (N : Node_Id) is | |
6180 | Loc : constant Source_Ptr := Sloc (N); | |
6181 | ||
6182 | Ras_Type : constant Entity_Id := Defining_Identifier (N); | |
6183 | Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); | |
6184 | -- Ras_Type is the access to subprogram type; Fat_Type is the | |
6185 | -- corresponding record type. | |
6186 | ||
6187 | RACW_Type : constant Entity_Id := | |
d693e39d | 6188 | Underlying_RACW_Type (Ras_Type); |
bd7f7a65 AC |
6189 | |
6190 | Stub_Elements : constant Stub_Structure := | |
d693e39d | 6191 | Get_Stub_Elements (RACW_Type); |
bd7f7a65 AC |
6192 | |
6193 | Proc : constant Entity_Id := | |
6194 | Make_Defining_Identifier (Loc, | |
6195 | Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); | |
6196 | ||
6197 | Proc_Spec : Node_Id; | |
6198 | ||
6199 | -- Formal parameters | |
6200 | ||
6201 | Package_Name : constant Entity_Id := | |
6202 | Make_Defining_Identifier (Loc, | |
6203 | Chars => Name_P); | |
6204 | ||
6205 | -- Target package | |
6206 | ||
6207 | Subp_Id : constant Entity_Id := | |
6208 | Make_Defining_Identifier (Loc, | |
6209 | Chars => Name_S); | |
6210 | ||
6211 | -- Target subprogram | |
6212 | ||
6213 | Asynch_P : constant Entity_Id := | |
6214 | Make_Defining_Identifier (Loc, | |
6215 | Chars => Name_Asynchronous); | |
6216 | -- Is the procedure to which the 'Access applies asynchronous? | |
6217 | ||
6218 | All_Calls_Remote : constant Entity_Id := | |
6219 | Make_Defining_Identifier (Loc, | |
6220 | Chars => Name_All_Calls_Remote); | |
6221 | -- True if an All_Calls_Remote pragma applies to the RCI unit | |
6222 | -- that contains the subprogram. | |
6223 | ||
6224 | -- Common local variables | |
6225 | ||
6226 | Proc_Decls : List_Id; | |
6227 | Proc_Statements : List_Id; | |
6228 | ||
6229 | Subp_Ref : constant Entity_Id := | |
6230 | Make_Defining_Identifier (Loc, Name_R); | |
6231 | -- Reference that designates the target subprogram (returned | |
6232 | -- by Get_RAS_Info). | |
6233 | ||
6234 | Is_Local : constant Entity_Id := | |
6235 | Make_Defining_Identifier (Loc, Name_L); | |
6236 | Local_Addr : constant Entity_Id := | |
6237 | Make_Defining_Identifier (Loc, Name_A); | |
6238 | -- For the call to Get_Local_Address | |
6239 | ||
2287a75d AC |
6240 | Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L'); |
6241 | Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S'); | |
bd7f7a65 AC |
6242 | -- Additional local variables for the remote case |
6243 | ||
bd7f7a65 AC |
6244 | function Set_Field |
6245 | (Field_Name : Name_Id; | |
6246 | Value : Node_Id) return Node_Id; | |
6247 | -- Construct an assignment that sets the named component in the | |
6248 | -- returned record | |
6249 | ||
6250 | --------------- | |
6251 | -- Set_Field -- | |
6252 | --------------- | |
6253 | ||
6254 | function Set_Field | |
6255 | (Field_Name : Name_Id; | |
6256 | Value : Node_Id) return Node_Id | |
6257 | is | |
6258 | begin | |
6259 | return | |
6260 | Make_Assignment_Statement (Loc, | |
6261 | Name => | |
6262 | Make_Selected_Component (Loc, | |
16db96c5 AC |
6263 | Prefix => Stub_Ptr, |
6264 | Selector_Name => Field_Name), | |
bd7f7a65 AC |
6265 | Expression => Value); |
6266 | end Set_Field; | |
6267 | ||
6268 | -- Start of processing for Add_RAS_Access_TSS | |
6269 | ||
6270 | begin | |
6271 | Proc_Decls := New_List ( | |
6272 | ||
6273 | -- Common declarations | |
6274 | ||
6275 | Make_Object_Declaration (Loc, | |
6276 | Defining_Identifier => Subp_Ref, | |
6277 | Object_Definition => | |
6278 | New_Occurrence_Of (RTE (RE_Object_Ref), Loc)), | |
6279 | ||
6280 | Make_Object_Declaration (Loc, | |
6281 | Defining_Identifier => Is_Local, | |
6282 | Object_Definition => | |
6283 | New_Occurrence_Of (Standard_Boolean, Loc)), | |
6284 | ||
6285 | Make_Object_Declaration (Loc, | |
6286 | Defining_Identifier => Local_Addr, | |
6287 | Object_Definition => | |
6288 | New_Occurrence_Of (RTE (RE_Address), Loc)), | |
6289 | ||
6290 | Make_Object_Declaration (Loc, | |
6291 | Defining_Identifier => Local_Stub, | |
6292 | Aliased_Present => True, | |
6293 | Object_Definition => | |
6294 | New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), | |
6295 | ||
6296 | Make_Object_Declaration (Loc, | |
d693e39d | 6297 | Defining_Identifier => Stub_Ptr, |
bd7f7a65 AC |
6298 | Object_Definition => |
6299 | New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), | |
6300 | Expression => | |
6301 | Make_Attribute_Reference (Loc, | |
6302 | Prefix => New_Occurrence_Of (Local_Stub, Loc), | |
6303 | Attribute_Name => Name_Unchecked_Access))); | |
6304 | ||
6305 | Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); | |
6306 | -- Build_Get_Unique_RP_Call needs this information | |
6307 | ||
6308 | -- Get_RAS_Info (Pkg, Subp, R); | |
6309 | -- Obtain a reference to the target subprogram | |
6310 | ||
6311 | Proc_Statements := New_List ( | |
6312 | Make_Procedure_Call_Statement (Loc, | |
d693e39d | 6313 | Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), |
bd7f7a65 AC |
6314 | Parameter_Associations => New_List ( |
6315 | New_Occurrence_Of (Package_Name, Loc), | |
6316 | New_Occurrence_Of (Subp_Id, Loc), | |
6317 | New_Occurrence_Of (Subp_Ref, Loc))), | |
6318 | ||
6319 | -- Get_Local_Address (R, L, A); | |
6320 | -- Determine whether the subprogram is local (L), and if so | |
6321 | -- obtain the local address of its proxy (A). | |
6322 | ||
6323 | Make_Procedure_Call_Statement (Loc, | |
d693e39d | 6324 | Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), |
bd7f7a65 AC |
6325 | Parameter_Associations => New_List ( |
6326 | New_Occurrence_Of (Subp_Ref, Loc), | |
6327 | New_Occurrence_Of (Is_Local, Loc), | |
6328 | New_Occurrence_Of (Local_Addr, Loc)))); | |
6329 | ||
6330 | -- Note: Here we assume that the Fat_Type is a record containing just | |
6331 | -- an access to a proxy or stub object. | |
6332 | ||
6333 | Append_To (Proc_Statements, | |
6334 | ||
c6f39437 | 6335 | -- if L then |
bd7f7a65 AC |
6336 | |
6337 | Make_Implicit_If_Statement (N, | |
d693e39d | 6338 | Condition => New_Occurrence_Of (Is_Local, Loc), |
bd7f7a65 AC |
6339 | |
6340 | Then_Statements => New_List ( | |
6341 | ||
c6f39437 | 6342 | -- if A.Target = null then |
bd7f7a65 AC |
6343 | |
6344 | Make_Implicit_If_Statement (N, | |
6345 | Condition => | |
6346 | Make_Op_Eq (Loc, | |
6347 | Make_Selected_Component (Loc, | |
d693e39d TQ |
6348 | Prefix => |
6349 | Unchecked_Convert_To | |
6350 | (RTE (RE_RAS_Proxy_Type_Access), | |
6351 | New_Occurrence_Of (Local_Addr, Loc)), | |
6352 | Selector_Name => Make_Identifier (Loc, Name_Target)), | |
bd7f7a65 AC |
6353 | Make_Null (Loc)), |
6354 | ||
6355 | Then_Statements => New_List ( | |
6356 | ||
c6f39437 | 6357 | -- A.Target := Entity_Of (Ref); |
bd7f7a65 AC |
6358 | |
6359 | Make_Assignment_Statement (Loc, | |
6360 | Name => | |
6361 | Make_Selected_Component (Loc, | |
d693e39d TQ |
6362 | Prefix => |
6363 | Unchecked_Convert_To | |
6364 | (RTE (RE_RAS_Proxy_Type_Access), | |
6365 | New_Occurrence_Of (Local_Addr, Loc)), | |
6366 | Selector_Name => Make_Identifier (Loc, Name_Target)), | |
bd7f7a65 AC |
6367 | Expression => |
6368 | Make_Function_Call (Loc, | |
d693e39d | 6369 | Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc), |
bd7f7a65 AC |
6370 | Parameter_Associations => New_List ( |
6371 | New_Occurrence_Of (Subp_Ref, Loc)))), | |
6372 | ||
c6f39437 AC |
6373 | -- Inc_Usage (A.Target); |
6374 | -- end if; | |
bd7f7a65 AC |
6375 | |
6376 | Make_Procedure_Call_Statement (Loc, | |
d693e39d | 6377 | Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), |
bd7f7a65 AC |
6378 | Parameter_Associations => New_List ( |
6379 | Make_Selected_Component (Loc, | |
6380 | Prefix => | |
d693e39d TQ |
6381 | Unchecked_Convert_To |
6382 | (RTE (RE_RAS_Proxy_Type_Access), | |
6383 | New_Occurrence_Of (Local_Addr, Loc)), | |
6384 | Selector_Name => | |
6385 | Make_Identifier (Loc, Name_Target)))))), | |
bd7f7a65 | 6386 | |
c6f39437 AC |
6387 | -- if not All_Calls_Remote then |
6388 | -- return Fat_Type!(A); | |
6389 | -- end if; | |
bd7f7a65 AC |
6390 | |
6391 | Make_Implicit_If_Statement (N, | |
6392 | Condition => | |
6393 | Make_Op_Not (Loc, | |
d693e39d TQ |
6394 | Right_Opnd => |
6395 | New_Occurrence_Of (All_Calls_Remote, Loc)), | |
bd7f7a65 AC |
6396 | |
6397 | Then_Statements => New_List ( | |
bfc2cdb1 | 6398 | Make_Simple_Return_Statement (Loc, |
d693e39d TQ |
6399 | Expression => |
6400 | Unchecked_Convert_To | |
6401 | (Fat_Type, New_Occurrence_Of (Local_Addr, Loc)))))))); | |
bd7f7a65 AC |
6402 | |
6403 | Append_List_To (Proc_Statements, New_List ( | |
6404 | ||
c6f39437 | 6405 | -- Stub.Target := Entity_Of (Ref); |
bd7f7a65 AC |
6406 | |
6407 | Set_Field (Name_Target, | |
6408 | Make_Function_Call (Loc, | |
d693e39d | 6409 | Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc), |
bd7f7a65 AC |
6410 | Parameter_Associations => New_List ( |
6411 | New_Occurrence_Of (Subp_Ref, Loc)))), | |
6412 | ||
c6f39437 | 6413 | -- Inc_Usage (Stub.Target); |
70482933 | 6414 | |
bd7f7a65 | 6415 | Make_Procedure_Call_Statement (Loc, |
d693e39d | 6416 | Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), |
bd7f7a65 AC |
6417 | Parameter_Associations => New_List ( |
6418 | Make_Selected_Component (Loc, | |
16db96c5 AC |
6419 | Prefix => Stub_Ptr, |
6420 | Selector_Name => Name_Target))), | |
70482933 | 6421 | |
c6f39437 AC |
6422 | -- E.4.1(9) A remote call is asynchronous if it is a call to |
6423 | -- a procedure, or a call through a value of an access-to-procedure | |
6424 | -- type, to which a pragma Asynchronous applies. | |
70482933 | 6425 | |
c6f39437 AC |
6426 | -- Parameter Asynch_P is true when the procedure is asynchronous; |
6427 | -- Expression Asynch_T is true when the type is asynchronous. | |
70482933 | 6428 | |
bd7f7a65 AC |
6429 | Set_Field (Name_Asynchronous, |
6430 | Make_Or_Else (Loc, | |
d693e39d TQ |
6431 | Left_Opnd => New_Occurrence_Of (Asynch_P, Loc), |
6432 | Right_Opnd => | |
6433 | New_Occurrence_Of | |
6434 | (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc))))); | |
70482933 | 6435 | |
bd7f7a65 | 6436 | Append_List_To (Proc_Statements, |
d693e39d | 6437 | Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); |
70482933 | 6438 | |
bd7f7a65 | 6439 | Append_To (Proc_Statements, |
bfc2cdb1 | 6440 | Make_Simple_Return_Statement (Loc, |
bd7f7a65 AC |
6441 | Expression => |
6442 | Unchecked_Convert_To (Fat_Type, | |
6443 | New_Occurrence_Of (Stub_Ptr, Loc)))); | |
70482933 | 6444 | |
bd7f7a65 AC |
6445 | Proc_Spec := |
6446 | Make_Function_Specification (Loc, | |
6447 | Defining_Unit_Name => Proc, | |
6448 | Parameter_Specifications => New_List ( | |
6449 | Make_Parameter_Specification (Loc, | |
6450 | Defining_Identifier => Package_Name, | |
6451 | Parameter_Type => | |
6452 | New_Occurrence_Of (Standard_String, Loc)), | |
70482933 | 6453 | |
bd7f7a65 AC |
6454 | Make_Parameter_Specification (Loc, |
6455 | Defining_Identifier => Subp_Id, | |
6456 | Parameter_Type => | |
6457 | New_Occurrence_Of (Standard_String, Loc)), | |
6458 | ||
6459 | Make_Parameter_Specification (Loc, | |
6460 | Defining_Identifier => Asynch_P, | |
6461 | Parameter_Type => | |
6462 | New_Occurrence_Of (Standard_Boolean, Loc)), | |
70482933 | 6463 | |
bd7f7a65 AC |
6464 | Make_Parameter_Specification (Loc, |
6465 | Defining_Identifier => All_Calls_Remote, | |
6466 | Parameter_Type => | |
6467 | New_Occurrence_Of (Standard_Boolean, Loc))), | |
48ab1182 | 6468 | |
3eb8fddc | 6469 | Result_Definition => |
bd7f7a65 | 6470 | New_Occurrence_Of (Fat_Type, Loc)); |
70482933 | 6471 | |
bd7f7a65 AC |
6472 | -- Set the kind and return type of the function to prevent |
6473 | -- ambiguities between Ras_Type and Fat_Type in subsequent analysis. | |
70482933 | 6474 | |
bd7f7a65 AC |
6475 | Set_Ekind (Proc, E_Function); |
6476 | Set_Etype (Proc, Fat_Type); | |
70482933 | 6477 | |
bd7f7a65 AC |
6478 | Discard_Node ( |
6479 | Make_Subprogram_Body (Loc, | |
6480 | Specification => Proc_Spec, | |
6481 | Declarations => Proc_Decls, | |
6482 | Handled_Statement_Sequence => | |
6483 | Make_Handled_Sequence_Of_Statements (Loc, | |
6484 | Statements => Proc_Statements))); | |
70482933 | 6485 | |
bd7f7a65 AC |
6486 | Set_TSS (Fat_Type, Proc); |
6487 | end Add_RAS_Access_TSS; | |
70482933 | 6488 | |
bd7f7a65 AC |
6489 | ---------------------- |
6490 | -- Add_RAS_From_Any -- | |
6491 | ---------------------- | |
70482933 | 6492 | |
c857f5ed | 6493 | procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is |
bd7f7a65 | 6494 | Loc : constant Source_Ptr := Sloc (RAS_Type); |
70482933 | 6495 | |
c857f5ed TQ |
6496 | Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, |
6497 | Make_TSS_Name (RAS_Type, TSS_From_Any)); | |
70482933 | 6498 | |
bd7f7a65 | 6499 | Func_Spec : Node_Id; |
bd7f7a65 AC |
6500 | |
6501 | Statements : List_Id; | |
70482933 | 6502 | |
bd7f7a65 AC |
6503 | Any_Parameter : constant Entity_Id := |
6504 | Make_Defining_Identifier (Loc, Name_A); | |
70482933 | 6505 | |
1735e55d | 6506 | begin |
bd7f7a65 | 6507 | Statements := New_List ( |
bfc2cdb1 | 6508 | Make_Simple_Return_Statement (Loc, |
bd7f7a65 AC |
6509 | Expression => |
6510 | Make_Aggregate (Loc, | |
6511 | Component_Associations => New_List ( | |
6512 | Make_Component_Association (Loc, | |
98c99a5a | 6513 | Choices => New_List (Make_Identifier (Loc, Name_Ras)), |
bd7f7a65 | 6514 | Expression => |
2c1b72d7 AC |
6515 | PolyORB_Support.Helpers.Build_From_Any_Call |
6516 | (Underlying_RACW_Type (RAS_Type), | |
6517 | New_Occurrence_Of (Any_Parameter, Loc), | |
6518 | No_List)))))); | |
bd7f7a65 AC |
6519 | |
6520 | Func_Spec := | |
6521 | Make_Function_Specification (Loc, | |
d693e39d | 6522 | Defining_Unit_Name => Fnam, |
bd7f7a65 AC |
6523 | Parameter_Specifications => New_List ( |
6524 | Make_Parameter_Specification (Loc, | |
d693e39d TQ |
6525 | Defining_Identifier => Any_Parameter, |
6526 | Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), | |
3eb8fddc | 6527 | Result_Definition => New_Occurrence_Of (RAS_Type, Loc)); |
70482933 | 6528 | |
c857f5ed | 6529 | Discard_Node ( |
bd7f7a65 | 6530 | Make_Subprogram_Body (Loc, |
c857f5ed | 6531 | Specification => Func_Spec, |
bd7f7a65 AC |
6532 | Declarations => No_List, |
6533 | Handled_Statement_Sequence => | |
6534 | Make_Handled_Sequence_Of_Statements (Loc, | |
c857f5ed TQ |
6535 | Statements => Statements))); |
6536 | Set_TSS (RAS_Type, Fnam); | |
bd7f7a65 | 6537 | end Add_RAS_From_Any; |
fbf5a39b | 6538 | |
bd7f7a65 AC |
6539 | -------------------- |
6540 | -- Add_RAS_To_Any -- | |
6541 | -------------------- | |
fbf5a39b | 6542 | |
c857f5ed | 6543 | procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is |
bd7f7a65 | 6544 | Loc : constant Source_Ptr := Sloc (RAS_Type); |
fbf5a39b | 6545 | |
c857f5ed TQ |
6546 | Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, |
6547 | Make_TSS_Name (RAS_Type, TSS_To_Any)); | |
fbf5a39b | 6548 | |
c857f5ed | 6549 | Decls : List_Id; |
bd7f7a65 | 6550 | Statements : List_Id; |
70482933 | 6551 | |
bd7f7a65 | 6552 | Func_Spec : Node_Id; |
70482933 | 6553 | |
2287a75d AC |
6554 | Any : constant Entity_Id := Make_Temporary (Loc, 'A'); |
6555 | RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); | |
bd7f7a65 AC |
6556 | RACW_Parameter : constant Node_Id := |
6557 | Make_Selected_Component (Loc, | |
16db96c5 AC |
6558 | Prefix => RAS_Parameter, |
6559 | Selector_Name => Name_Ras); | |
70482933 | 6560 | |
bd7f7a65 AC |
6561 | begin |
6562 | -- Object declarations | |
70482933 | 6563 | |
bd7f7a65 AC |
6564 | Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type)); |
6565 | Decls := New_List ( | |
1735e55d | 6566 | Make_Object_Declaration (Loc, |
d693e39d TQ |
6567 | Defining_Identifier => Any, |
6568 | Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), | |
6569 | Expression => | |
bd7f7a65 | 6570 | PolyORB_Support.Helpers.Build_To_Any_Call |
30ebb114 | 6571 | (Loc, RACW_Parameter, No_List))); |
70482933 | 6572 | |
bd7f7a65 AC |
6573 | Statements := New_List ( |
6574 | Make_Procedure_Call_Statement (Loc, | |
d693e39d | 6575 | Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), |
bd7f7a65 AC |
6576 | Parameter_Associations => New_List ( |
6577 | New_Occurrence_Of (Any, Loc), | |
6578 | PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, | |
6579 | RAS_Type, Decls))), | |
d693e39d | 6580 | |
bfc2cdb1 | 6581 | Make_Simple_Return_Statement (Loc, |
d693e39d | 6582 | Expression => New_Occurrence_Of (Any, Loc))); |
70482933 | 6583 | |
bd7f7a65 AC |
6584 | Func_Spec := |
6585 | Make_Function_Specification (Loc, | |
d693e39d | 6586 | Defining_Unit_Name => Fnam, |
bd7f7a65 AC |
6587 | Parameter_Specifications => New_List ( |
6588 | Make_Parameter_Specification (Loc, | |
d693e39d TQ |
6589 | Defining_Identifier => RAS_Parameter, |
6590 | Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))), | |
3eb8fddc | 6591 | Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); |
70482933 | 6592 | |
c857f5ed | 6593 | Discard_Node ( |
bd7f7a65 | 6594 | Make_Subprogram_Body (Loc, |
c857f5ed | 6595 | Specification => Func_Spec, |
bd7f7a65 AC |
6596 | Declarations => Decls, |
6597 | Handled_Statement_Sequence => | |
6598 | Make_Handled_Sequence_Of_Statements (Loc, | |
c857f5ed TQ |
6599 | Statements => Statements))); |
6600 | Set_TSS (RAS_Type, Fnam); | |
bd7f7a65 | 6601 | end Add_RAS_To_Any; |
70482933 | 6602 | |
bd7f7a65 AC |
6603 | ---------------------- |
6604 | -- Add_RAS_TypeCode -- | |
6605 | ---------------------- | |
70482933 | 6606 | |
c857f5ed | 6607 | procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is |
bd7f7a65 | 6608 | Loc : constant Source_Ptr := Sloc (RAS_Type); |
70482933 | 6609 | |
c857f5ed TQ |
6610 | Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, |
6611 | Make_TSS_Name (RAS_Type, TSS_TypeCode)); | |
bd7f7a65 | 6612 | |
d693e39d TQ |
6613 | Func_Spec : Node_Id; |
6614 | Decls : constant List_Id := New_List; | |
6615 | Name_String : String_Id; | |
6616 | Repo_Id_String : String_Id; | |
bd7f7a65 | 6617 | |
bd7f7a65 | 6618 | begin |
bd7f7a65 AC |
6619 | Func_Spec := |
6620 | Make_Function_Specification (Loc, | |
d693e39d TQ |
6621 | Defining_Unit_Name => Fnam, |
6622 | Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); | |
70482933 | 6623 | |
bd7f7a65 AC |
6624 | PolyORB_Support.Helpers.Build_Name_And_Repository_Id |
6625 | (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String); | |
70482933 | 6626 | |
c857f5ed | 6627 | Discard_Node ( |
bd7f7a65 | 6628 | Make_Subprogram_Body (Loc, |
c857f5ed | 6629 | Specification => Func_Spec, |
bd7f7a65 AC |
6630 | Declarations => Decls, |
6631 | Handled_Statement_Sequence => | |
6632 | Make_Handled_Sequence_Of_Statements (Loc, | |
6633 | Statements => New_List ( | |
bfc2cdb1 | 6634 | Make_Simple_Return_Statement (Loc, |
bd7f7a65 AC |
6635 | Expression => |
6636 | Make_Function_Call (Loc, | |
5b75bf57 AC |
6637 | Name => |
6638 | New_Occurrence_Of (RTE (RE_Build_Complex_TC), Loc), | |
bd7f7a65 | 6639 | Parameter_Associations => New_List ( |
5b75bf57 | 6640 | New_Occurrence_Of (RTE (RE_Tk_Objref), Loc), |
bd7f7a65 AC |
6641 | Make_Aggregate (Loc, |
6642 | Expressions => | |
6643 | New_List ( | |
6644 | Make_Function_Call (Loc, | |
d693e39d TQ |
6645 | Name => |
6646 | New_Occurrence_Of | |
6bde3eb5 | 6647 | (RTE (RE_TA_Std_String), Loc), |
bd7f7a65 AC |
6648 | Parameter_Associations => New_List ( |
6649 | Make_String_Literal (Loc, Name_String))), | |
6650 | Make_Function_Call (Loc, | |
d693e39d TQ |
6651 | Name => |
6652 | New_Occurrence_Of | |
6bde3eb5 | 6653 | (RTE (RE_TA_Std_String), Loc), |
bd7f7a65 AC |
6654 | Parameter_Associations => New_List ( |
6655 | Make_String_Literal (Loc, | |
d693e39d | 6656 | Strval => Repo_Id_String)))))))))))); |
c857f5ed | 6657 | Set_TSS (RAS_Type, Fnam); |
bd7f7a65 AC |
6658 | end Add_RAS_TypeCode; |
6659 | ||
16db96c5 AC |
6660 | ----------------------------------------- |
6661 | -- Add_Receiving_Stubs_To_Declarations -- | |
6662 | ----------------------------------------- | |
6663 | ||
6664 | procedure Add_Receiving_Stubs_To_Declarations | |
6665 | (Pkg_Spec : Node_Id; | |
8aa23fe3 TQ |
6666 | Decls : List_Id; |
6667 | Stmts : List_Id) | |
16db96c5 AC |
6668 | is |
6669 | Loc : constant Source_Ptr := Sloc (Pkg_Spec); | |
6670 | ||
6671 | Pkg_RPC_Receiver : constant Entity_Id := | |
2287a75d | 6672 | Make_Temporary (Loc, 'H'); |
16db96c5 | 6673 | Pkg_RPC_Receiver_Object : Node_Id; |
16db96c5 AC |
6674 | Pkg_RPC_Receiver_Body : Node_Id; |
6675 | Pkg_RPC_Receiver_Decls : List_Id; | |
6676 | Pkg_RPC_Receiver_Statements : List_Id; | |
d693e39d TQ |
6677 | |
6678 | Pkg_RPC_Receiver_Cases : constant List_Id := New_List; | |
16db96c5 AC |
6679 | -- A Pkg_RPC_Receiver is built to decode the request |
6680 | ||
d693e39d | 6681 | Request : Node_Id; |
16db96c5 AC |
6682 | -- Request object received from neutral layer |
6683 | ||
6684 | Subp_Id : Entity_Id; | |
c6f39437 AC |
6685 | -- Subprogram identifier as received from the neutral distribution |
6686 | -- core. | |
16db96c5 AC |
6687 | |
6688 | Subp_Index : Entity_Id; | |
d693e39d TQ |
6689 | -- Internal index as determined by matching either the method name |
6690 | -- from the request structure, or the local subprogram address (in | |
6691 | -- case of a RAS). | |
16db96c5 | 6692 | |
2287a75d | 6693 | Is_Local : constant Entity_Id := Make_Temporary (Loc, 'L'); |
d693e39d | 6694 | |
2287a75d | 6695 | Local_Address : constant Entity_Id := Make_Temporary (Loc, 'A'); |
d693e39d TQ |
6696 | -- Address of a local subprogram designated by a reference |
6697 | -- corresponding to a RAS. | |
16db96c5 AC |
6698 | |
6699 | Dispatch_On_Address : constant List_Id := New_List; | |
6700 | Dispatch_On_Name : constant List_Id := New_List; | |
6701 | ||
ff2efe85 | 6702 | Current_Subp_Number : Int := First_RCI_Subprogram_Id; |
16db96c5 | 6703 | |
2287a75d | 6704 | Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); |
ff2efe85 | 6705 | Subp_Info_List : constant List_Id := New_List; |
16db96c5 AC |
6706 | |
6707 | Register_Pkg_Actuals : constant List_Id := New_List; | |
6708 | ||
6709 | All_Calls_Remote_E : Entity_Id; | |
6710 | ||
6711 | procedure Append_Stubs_To | |
6712 | (RPC_Receiver_Cases : List_Id; | |
6713 | Declaration : Node_Id; | |
6714 | Stubs : Node_Id; | |
6715 | Subp_Number : Int; | |
6716 | Subp_Dist_Name : Entity_Id; | |
6717 | Subp_Proxy_Addr : Entity_Id); | |
6718 | -- Add one case to the specified RPC receiver case list associating | |
6719 | -- Subprogram_Number with the subprogram declared by Declaration, for | |
6720 | -- which we have receiving stubs in Stubs. Subp_Number is an internal | |
6721 | -- subprogram index. Subp_Dist_Name is the string used to call the | |
6722 | -- subprogram by name, and Subp_Dist_Addr is the address of the proxy | |
6723 | -- object, used in the context of calls through remote | |
6724 | -- access-to-subprogram types. | |
6725 | ||
ff2efe85 AC |
6726 | procedure Visit_Subprogram (Decl : Node_Id); |
6727 | -- Generate receiving stub for one remote subprogram | |
6728 | ||
16db96c5 AC |
6729 | --------------------- |
6730 | -- Append_Stubs_To -- | |
6731 | --------------------- | |
6732 | ||
6733 | procedure Append_Stubs_To | |
6734 | (RPC_Receiver_Cases : List_Id; | |
6735 | Declaration : Node_Id; | |
6736 | Stubs : Node_Id; | |
6737 | Subp_Number : Int; | |
6738 | Subp_Dist_Name : Entity_Id; | |
6739 | Subp_Proxy_Addr : Entity_Id) | |
6740 | is | |
6741 | Case_Stmts : List_Id; | |
6742 | begin | |
6743 | Case_Stmts := New_List ( | |
6744 | Make_Procedure_Call_Statement (Loc, | |
6745 | Name => | |
6746 | New_Occurrence_Of ( | |
6747 | Defining_Entity (Stubs), Loc), | |
6748 | Parameter_Associations => | |
6749 | New_List (New_Occurrence_Of (Request, Loc)))); | |
d693e39d TQ |
6750 | |
6751 | if Nkind (Specification (Declaration)) = N_Function_Specification | |
16db96c5 AC |
6752 | or else not |
6753 | Is_Asynchronous (Defining_Entity (Specification (Declaration))) | |
6754 | then | |
bfc2cdb1 | 6755 | Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc)); |
16db96c5 AC |
6756 | end if; |
6757 | ||
6758 | Append_To (RPC_Receiver_Cases, | |
6759 | Make_Case_Statement_Alternative (Loc, | |
6760 | Discrete_Choices => | |
6761 | New_List (Make_Integer_Literal (Loc, Subp_Number)), | |
d693e39d | 6762 | Statements => Case_Stmts)); |
16db96c5 AC |
6763 | |
6764 | Append_To (Dispatch_On_Name, | |
6765 | Make_Elsif_Part (Loc, | |
6766 | Condition => | |
6767 | Make_Function_Call (Loc, | |
6768 | Name => | |
6769 | New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc), | |
6770 | Parameter_Associations => New_List ( | |
6771 | New_Occurrence_Of (Subp_Id, Loc), | |
6772 | New_Occurrence_Of (Subp_Dist_Name, Loc))), | |
d693e39d | 6773 | |
16db96c5 AC |
6774 | Then_Statements => New_List ( |
6775 | Make_Assignment_Statement (Loc, | |
6776 | New_Occurrence_Of (Subp_Index, Loc), | |
d693e39d | 6777 | Make_Integer_Literal (Loc, Subp_Number))))); |
16db96c5 AC |
6778 | |
6779 | Append_To (Dispatch_On_Address, | |
6780 | Make_Elsif_Part (Loc, | |
6781 | Condition => | |
6782 | Make_Op_Eq (Loc, | |
d693e39d TQ |
6783 | Left_Opnd => New_Occurrence_Of (Local_Address, Loc), |
6784 | Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)), | |
6785 | ||
16db96c5 AC |
6786 | Then_Statements => New_List ( |
6787 | Make_Assignment_Statement (Loc, | |
6788 | New_Occurrence_Of (Subp_Index, Loc), | |
d693e39d | 6789 | Make_Integer_Literal (Loc, Subp_Number))))); |
16db96c5 AC |
6790 | end Append_Stubs_To; |
6791 | ||
ff2efe85 AC |
6792 | ---------------------- |
6793 | -- Visit_Subprogram -- | |
6794 | ---------------------- | |
6795 | ||
6796 | procedure Visit_Subprogram (Decl : Node_Id) is | |
6797 | Loc : constant Source_Ptr := Sloc (Decl); | |
6798 | Spec : constant Node_Id := Specification (Decl); | |
6799 | Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec); | |
6800 | ||
6801 | Subp_Val : String_Id; | |
6802 | ||
6803 | Subp_Dist_Name : constant Entity_Id := | |
f2acf80c AC |
6804 | Make_Defining_Identifier (Loc, |
6805 | Chars => | |
6806 | New_External_Name | |
6807 | (Related_Id => Chars (Subp_Def), | |
6808 | Suffix => 'D', | |
6809 | Suffix_Index => -1)); | |
ff2efe85 AC |
6810 | |
6811 | Current_Stubs : Node_Id; | |
6812 | Proxy_Obj_Addr : Entity_Id; | |
6813 | ||
6814 | begin | |
9fde638d RD |
6815 | -- Disable expansion of stubs if serious errors have been |
6816 | -- diagnosed, because otherwise some illegal remote subprogram | |
6817 | -- declarations could cause cascaded errors in stubs. | |
6818 | ||
170b2989 AC |
6819 | if Serious_Errors_Detected /= 0 then |
6820 | return; | |
6821 | end if; | |
6822 | ||
ff2efe85 AC |
6823 | -- Build receiving stub |
6824 | ||
6825 | Current_Stubs := | |
6826 | Build_Subprogram_Receiving_Stubs | |
6827 | (Vis_Decl => Decl, | |
f2acf80c AC |
6828 | Asynchronous => Nkind (Spec) = N_Procedure_Specification |
6829 | and then Is_Asynchronous (Subp_Def)); | |
ff2efe85 AC |
6830 | |
6831 | Append_To (Decls, Current_Stubs); | |
6832 | Analyze (Current_Stubs); | |
6833 | ||
6834 | -- Build RAS proxy | |
6835 | ||
6836 | Add_RAS_Proxy_And_Analyze (Decls, | |
6837 | Vis_Decl => Decl, | |
6838 | All_Calls_Remote_E => All_Calls_Remote_E, | |
6839 | Proxy_Object_Addr => Proxy_Obj_Addr); | |
6840 | ||
6841 | -- Compute distribution identifier | |
6842 | ||
6843 | Assign_Subprogram_Identifier | |
6844 | (Subp_Def, Current_Subp_Number, Subp_Val); | |
6845 | ||
6846 | pragma Assert | |
6847 | (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); | |
6848 | ||
6849 | Append_To (Decls, | |
6850 | Make_Object_Declaration (Loc, | |
6851 | Defining_Identifier => Subp_Dist_Name, | |
6852 | Constant_Present => True, | |
6853 | Object_Definition => | |
6854 | New_Occurrence_Of (Standard_String, Loc), | |
6855 | Expression => | |
6856 | Make_String_Literal (Loc, Subp_Val))); | |
6857 | Analyze (Last (Decls)); | |
6858 | ||
6859 | -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms | |
6860 | -- table for this receiver. The aggregate below must be kept | |
6861 | -- consistent with the declaration of RCI_Subp_Info in | |
6862 | -- System.Partition_Interface. | |
6863 | ||
6864 | Append_To (Subp_Info_List, | |
6865 | Make_Component_Association (Loc, | |
6866 | Choices => | |
6867 | New_List (Make_Integer_Literal (Loc, Current_Subp_Number)), | |
6868 | ||
6869 | Expression => | |
6870 | Make_Aggregate (Loc, | |
6871 | Expressions => New_List ( | |
6872 | ||
6873 | -- Name => | |
6874 | ||
6875 | Make_Attribute_Reference (Loc, | |
6876 | Prefix => | |
6877 | New_Occurrence_Of (Subp_Dist_Name, Loc), | |
6878 | Attribute_Name => Name_Address), | |
6879 | ||
6880 | -- Name_Length => | |
6881 | ||
6882 | Make_Attribute_Reference (Loc, | |
6883 | Prefix => | |
6884 | New_Occurrence_Of (Subp_Dist_Name, Loc), | |
6885 | Attribute_Name => Name_Length), | |
6886 | ||
6887 | -- Addr => | |
6888 | ||
6889 | New_Occurrence_Of (Proxy_Obj_Addr, Loc))))); | |
6890 | ||
6891 | Append_Stubs_To (Pkg_RPC_Receiver_Cases, | |
6892 | Declaration => Decl, | |
6893 | Stubs => Current_Stubs, | |
6894 | Subp_Number => Current_Subp_Number, | |
6895 | Subp_Dist_Name => Subp_Dist_Name, | |
6896 | Subp_Proxy_Addr => Proxy_Obj_Addr); | |
6897 | ||
6898 | Current_Subp_Number := Current_Subp_Number + 1; | |
6899 | end Visit_Subprogram; | |
6900 | ||
6901 | procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); | |
6902 | ||
16db96c5 AC |
6903 | -- Start of processing for Add_Receiving_Stubs_To_Declarations |
6904 | ||
6905 | begin | |
6906 | -- Building receiving stubs consist in several operations: | |
6907 | ||
c6f39437 AC |
6908 | -- - a package RPC receiver must be built. This subprogram will get |
6909 | -- a Subprogram_Id from the incoming stream and will dispatch the | |
6910 | -- call to the right subprogram; | |
16db96c5 | 6911 | |
c3d593c9 | 6912 | -- - a receiving stub for each subprogram visible in the package |
16db96c5 AC |
6913 | -- spec. This stub will read all the parameters from the stream, |
6914 | -- and put the result as well as the exception occurrence in the | |
c3d593c9 | 6915 | -- output stream; |
16db96c5 | 6916 | |
16db96c5 AC |
6917 | Build_RPC_Receiver_Body ( |
6918 | RPC_Receiver => Pkg_RPC_Receiver, | |
6919 | Request => Request, | |
6920 | Subp_Id => Subp_Id, | |
6921 | Subp_Index => Subp_Index, | |
6922 | Stmts => Pkg_RPC_Receiver_Statements, | |
6923 | Decl => Pkg_RPC_Receiver_Body); | |
6924 | Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body); | |
6925 | ||
6926 | -- Extract local address information from the target reference: | |
6927 | -- if non-null, that means that this is a reference that denotes | |
6928 | -- one particular operation, and hence that the operation name | |
6929 | -- must not be taken into account for dispatching. | |
6930 | ||
6931 | Append_To (Pkg_RPC_Receiver_Decls, | |
6932 | Make_Object_Declaration (Loc, | |
d693e39d | 6933 | Defining_Identifier => Is_Local, |
16db96c5 AC |
6934 | Object_Definition => |
6935 | New_Occurrence_Of (Standard_Boolean, Loc))); | |
d693e39d | 6936 | |
16db96c5 AC |
6937 | Append_To (Pkg_RPC_Receiver_Decls, |
6938 | Make_Object_Declaration (Loc, | |
d693e39d | 6939 | Defining_Identifier => Local_Address, |
16db96c5 AC |
6940 | Object_Definition => |
6941 | New_Occurrence_Of (RTE (RE_Address), Loc))); | |
d693e39d | 6942 | |
16db96c5 AC |
6943 | Append_To (Pkg_RPC_Receiver_Statements, |
6944 | Make_Procedure_Call_Statement (Loc, | |
d693e39d | 6945 | Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), |
16db96c5 AC |
6946 | Parameter_Associations => New_List ( |
6947 | Make_Selected_Component (Loc, | |
6948 | Prefix => Request, | |
6949 | Selector_Name => Name_Target), | |
6950 | New_Occurrence_Of (Is_Local, Loc), | |
6951 | New_Occurrence_Of (Local_Address, Loc)))); | |
6952 | ||
c6f39437 AC |
6953 | -- For each subprogram, the receiving stub will be built and a case |
6954 | -- statement will be made on the Subprogram_Id to dispatch to the | |
6955 | -- right subprogram. | |
16db96c5 AC |
6956 | |
6957 | All_Calls_Remote_E := Boolean_Literals ( | |
6958 | Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); | |
6959 | ||
6960 | Overload_Counter_Table.Reset; | |
6961 | Reserve_NamingContext_Methods; | |
6962 | ||
ff2efe85 | 6963 | Visit_Spec (Pkg_Spec); |
16db96c5 | 6964 | |
c3d593c9 TQ |
6965 | Append_To (Decls, |
6966 | Make_Object_Declaration (Loc, | |
6967 | Defining_Identifier => Subp_Info_Array, | |
6968 | Constant_Present => True, | |
6969 | Aliased_Present => True, | |
6970 | Object_Definition => | |
6971 | Make_Subtype_Indication (Loc, | |
6972 | Subtype_Mark => | |
6973 | New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), | |
6974 | Constraint => | |
6975 | Make_Index_Or_Discriminant_Constraint (Loc, | |
6976 | New_List ( | |
6977 | Make_Range (Loc, | |
d693e39d TQ |
6978 | Low_Bound => |
6979 | Make_Integer_Literal (Loc, | |
6980 | Intval => First_RCI_Subprogram_Id), | |
c3d593c9 TQ |
6981 | High_Bound => |
6982 | Make_Integer_Literal (Loc, | |
d693e39d TQ |
6983 | Intval => |
6984 | First_RCI_Subprogram_Id | |
6985 | + List_Length (Subp_Info_List) - 1))))))); | |
c3d593c9 TQ |
6986 | |
6987 | if Present (First (Subp_Info_List)) then | |
6988 | Set_Expression (Last (Decls), | |
6989 | Make_Aggregate (Loc, | |
6990 | Component_Associations => Subp_Info_List)); | |
6991 | ||
6992 | -- Generate the dispatch statement to determine the subprogram id | |
6993 | -- of the called subprogram. | |
6994 | ||
6995 | -- We first test whether the reference that was used to make the | |
6996 | -- call was the base RCI reference (in which case Local_Address is | |
6997 | -- zero, and the method identifier from the request must be used | |
6998 | -- to determine which subprogram is called) or a reference | |
6999 | -- identifying one particular subprogram (in which case | |
7000 | -- Local_Address is the address of that subprogram, and the | |
7001 | -- method name from the request is ignored). The latter occurs | |
7002 | -- for the case of a call through a remote access-to-subprogram. | |
7003 | ||
7004 | -- In each case, cascaded elsifs are used to determine the proper | |
7005 | -- subprogram index. Using hash tables might be more efficient. | |
7006 | ||
7007 | Append_To (Pkg_RPC_Receiver_Statements, | |
7008 | Make_Implicit_If_Statement (Pkg_Spec, | |
7009 | Condition => | |
7010 | Make_Op_Ne (Loc, | |
d693e39d | 7011 | Left_Opnd => New_Occurrence_Of (Local_Address, Loc), |
c3d593c9 TQ |
7012 | Right_Opnd => New_Occurrence_Of |
7013 | (RTE (RE_Null_Address), Loc)), | |
d693e39d | 7014 | |
c3d593c9 TQ |
7015 | Then_Statements => New_List ( |
7016 | Make_Implicit_If_Statement (Pkg_Spec, | |
d693e39d | 7017 | Condition => New_Occurrence_Of (Standard_False, Loc), |
c3d593c9 TQ |
7018 | Then_Statements => New_List ( |
7019 | Make_Null_Statement (Loc)), | |
d693e39d | 7020 | Elsif_Parts => Dispatch_On_Address)), |
c3d593c9 TQ |
7021 | |
7022 | Else_Statements => New_List ( | |
7023 | Make_Implicit_If_Statement (Pkg_Spec, | |
d693e39d TQ |
7024 | Condition => New_Occurrence_Of (Standard_False, Loc), |
7025 | Then_Statements => New_List (Make_Null_Statement (Loc)), | |
7026 | Elsif_Parts => Dispatch_On_Name)))); | |
c3d593c9 TQ |
7027 | |
7028 | else | |
7029 | -- For a degenerate RCI with no visible subprograms, | |
7030 | -- Subp_Info_List has zero length, and the declaration is for an | |
7031 | -- empty array, in which case no initialization aggregate must be | |
7032 | -- generated. We do not generate a Dispatch_Statement either. | |
7033 | ||
7034 | -- No initialization provided: remove CONSTANT so that the | |
7035 | -- declaration is not an incomplete deferred constant. | |
7036 | ||
7037 | Set_Constant_Present (Last (Decls), False); | |
7038 | end if; | |
7039 | ||
7040 | -- Analyze Subp_Info_Array declaration | |
7041 | ||
7042 | Analyze (Last (Decls)); | |
7043 | ||
16db96c5 AC |
7044 | -- If we receive an invalid Subprogram_Id, it is best to do nothing |
7045 | -- rather than raising an exception since we do not want someone | |
7046 | -- to crash a remote partition by sending invalid subprogram ids. | |
7047 | -- This is consistent with the other parts of the case statement | |
7048 | -- since even in presence of incorrect parameters in the stream, | |
7049 | -- every exception will be caught and (if the subprogram is not an | |
7050 | -- APC) put into the result stream and sent away. | |
7051 | ||
7052 | Append_To (Pkg_RPC_Receiver_Cases, | |
7053 | Make_Case_Statement_Alternative (Loc, | |
d693e39d TQ |
7054 | Discrete_Choices => New_List (Make_Others_Choice (Loc)), |
7055 | Statements => New_List (Make_Null_Statement (Loc)))); | |
16db96c5 AC |
7056 | |
7057 | Append_To (Pkg_RPC_Receiver_Statements, | |
7058 | Make_Case_Statement (Loc, | |
d693e39d | 7059 | Expression => New_Occurrence_Of (Subp_Index, Loc), |
16db96c5 AC |
7060 | Alternatives => Pkg_RPC_Receiver_Cases)); |
7061 | ||
c3d593c9 TQ |
7062 | -- Pkg_RPC_Receiver body is now complete: insert it into the tree and |
7063 | -- analyze it. | |
16db96c5 AC |
7064 | |
7065 | Append_To (Decls, Pkg_RPC_Receiver_Body); | |
7066 | Analyze (Last (Decls)); | |
7067 | ||
7068 | Pkg_RPC_Receiver_Object := | |
7069 | Make_Object_Declaration (Loc, | |
2287a75d | 7070 | Defining_Identifier => Make_Temporary (Loc, 'R'), |
16db96c5 | 7071 | Aliased_Present => True, |
d693e39d | 7072 | Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); |
16db96c5 AC |
7073 | Append_To (Decls, Pkg_RPC_Receiver_Object); |
7074 | Analyze (Last (Decls)); | |
7075 | ||
d693e39d TQ |
7076 | -- Name |
7077 | ||
16db96c5 | 7078 | Append_To (Register_Pkg_Actuals, |
16db96c5 | 7079 | Make_String_Literal (Loc, |
72267417 AC |
7080 | Strval => |
7081 | Fully_Qualified_Name_String | |
7082 | (Defining_Entity (Pkg_Spec), Append_NUL => False))); | |
16db96c5 | 7083 | |
d693e39d TQ |
7084 | -- Version |
7085 | ||
16db96c5 | 7086 | Append_To (Register_Pkg_Actuals, |
16db96c5 AC |
7087 | Make_Attribute_Reference (Loc, |
7088 | Prefix => | |
7089 | New_Occurrence_Of | |
7090 | (Defining_Entity (Pkg_Spec), Loc), | |
d693e39d TQ |
7091 | Attribute_Name => Name_Version)); |
7092 | ||
7093 | -- Handler | |
16db96c5 AC |
7094 | |
7095 | Append_To (Register_Pkg_Actuals, | |
16db96c5 AC |
7096 | Make_Attribute_Reference (Loc, |
7097 | Prefix => | |
7098 | New_Occurrence_Of (Pkg_RPC_Receiver, Loc), | |
7099 | Attribute_Name => Name_Access)); | |
7100 | ||
d693e39d TQ |
7101 | -- Receiver |
7102 | ||
16db96c5 | 7103 | Append_To (Register_Pkg_Actuals, |
16db96c5 AC |
7104 | Make_Attribute_Reference (Loc, |
7105 | Prefix => | |
7106 | New_Occurrence_Of ( | |
d693e39d TQ |
7107 | Defining_Identifier (Pkg_RPC_Receiver_Object), Loc), |
7108 | Attribute_Name => Name_Access)); | |
7109 | ||
7110 | -- Subp_Info | |
16db96c5 AC |
7111 | |
7112 | Append_To (Register_Pkg_Actuals, | |
16db96c5 | 7113 | Make_Attribute_Reference (Loc, |
d693e39d TQ |
7114 | Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), |
7115 | Attribute_Name => Name_Address)); | |
7116 | ||
7117 | -- Subp_Info_Len | |
16db96c5 AC |
7118 | |
7119 | Append_To (Register_Pkg_Actuals, | |
16db96c5 | 7120 | Make_Attribute_Reference (Loc, |
d693e39d TQ |
7121 | Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), |
7122 | Attribute_Name => Name_Length)); | |
7123 | ||
7124 | -- Is_All_Calls_Remote | |
16db96c5 AC |
7125 | |
7126 | Append_To (Register_Pkg_Actuals, | |
16db96c5 AC |
7127 | New_Occurrence_Of (All_Calls_Remote_E, Loc)); |
7128 | ||
1be9633f | 7129 | -- Finally call Register_Pkg_Receiving_Stub with the above parameters |
d693e39d | 7130 | |
8aa23fe3 | 7131 | Append_To (Stmts, |
16db96c5 AC |
7132 | Make_Procedure_Call_Statement (Loc, |
7133 | Name => | |
7134 | New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc), | |
7135 | Parameter_Associations => Register_Pkg_Actuals)); | |
8aa23fe3 | 7136 | Analyze (Last (Stmts)); |
16db96c5 AC |
7137 | end Add_Receiving_Stubs_To_Declarations; |
7138 | ||
7139 | --------------------------------- | |
7140 | -- Build_General_Calling_Stubs -- | |
7141 | --------------------------------- | |
bd7f7a65 AC |
7142 | |
7143 | procedure Build_General_Calling_Stubs | |
7144 | (Decls : List_Id; | |
7145 | Statements : List_Id; | |
7146 | Target_Object : Node_Id; | |
7147 | Subprogram_Id : Node_Id; | |
7148 | Asynchronous : Node_Id := Empty; | |
7149 | Is_Known_Asynchronous : Boolean := False; | |
7150 | Is_Known_Non_Asynchronous : Boolean := False; | |
7151 | Is_Function : Boolean; | |
7152 | Spec : Node_Id; | |
7153 | Stub_Type : Entity_Id := Empty; | |
7154 | RACW_Type : Entity_Id := Empty; | |
7155 | Nod : Node_Id) | |
7156 | is | |
7157 | Loc : constant Source_Ptr := Sloc (Nod); | |
c885d7a1 | 7158 | |
2287a75d | 7159 | Request : constant Entity_Id := Make_Temporary (Loc, 'R'); |
93bcda23 AC |
7160 | -- The request object constructed by these stubs |
7161 | -- Could we use Name_R instead??? (see GLADE client stubs) | |
7162 | ||
7163 | function Make_Request_RTE_Call | |
7164 | (RE : RE_Id; | |
7165 | Actuals : List_Id := New_List) return Node_Id; | |
7166 | -- Generate a procedure call statement calling RE with the given | |
d80ee77c | 7167 | -- actuals. Request'Access is appended to the list. |
93bcda23 AC |
7168 | |
7169 | --------------------------- | |
7170 | -- Make_Request_RTE_Call -- | |
7171 | --------------------------- | |
7172 | ||
7173 | function Make_Request_RTE_Call | |
7174 | (RE : RE_Id; | |
7175 | Actuals : List_Id := New_List) return Node_Id | |
7176 | is | |
7177 | begin | |
d80ee77c AC |
7178 | Append_To (Actuals, |
7179 | Make_Attribute_Reference (Loc, | |
7180 | Prefix => New_Occurrence_Of (Request, Loc), | |
7181 | Attribute_Name => Name_Access)); | |
93bcda23 AC |
7182 | return Make_Procedure_Call_Statement (Loc, |
7183 | Name => | |
7184 | New_Occurrence_Of (RTE (RE), Loc), | |
7185 | Parameter_Associations => Actuals); | |
7186 | end Make_Request_RTE_Call; | |
7187 | ||
bd7f7a65 AC |
7188 | Arguments : Node_Id; |
7189 | -- Name of the named values list used to transmit parameters | |
7190 | -- to the remote package | |
70482933 | 7191 | |
bd7f7a65 AC |
7192 | Result : Node_Id; |
7193 | -- Name of the result named value (in non-APC cases) which get the | |
7194 | -- result of the remote subprogram. | |
fbf5a39b | 7195 | |
bd7f7a65 AC |
7196 | Result_TC : Node_Id; |
7197 | -- Typecode expression for the result of the request (void | |
7198 | -- typecode for procedures). | |
fbf5a39b | 7199 | |
bd7f7a65 AC |
7200 | Exception_Return_Parameter : Node_Id; |
7201 | -- Name of the parameter which will hold the exception sent by the | |
7202 | -- remote subprogram. | |
70482933 | 7203 | |
bd7f7a65 AC |
7204 | Current_Parameter : Node_Id; |
7205 | -- Current parameter being handled | |
70482933 | 7206 | |
bd7f7a65 AC |
7207 | Ordered_Parameters_List : constant List_Id := |
7208 | Build_Ordered_Parameters_List (Spec); | |
70482933 | 7209 | |
bd7f7a65 AC |
7210 | Asynchronous_P : Node_Id; |
7211 | -- A Boolean expression indicating whether this call is asynchronous | |
70482933 | 7212 | |
bd7f7a65 AC |
7213 | Asynchronous_Statements : List_Id := No_List; |
7214 | Non_Asynchronous_Statements : List_Id := No_List; | |
7215 | -- Statements specifics to the Asynchronous/Non-Asynchronous cases | |
c885d7a1 | 7216 | |
bd7f7a65 AC |
7217 | Extra_Formal_Statements : constant List_Id := New_List; |
7218 | -- List of statements for extra formal parameters. It will appear | |
7219 | -- after the regular statements for writing out parameters. | |
c885d7a1 | 7220 | |
bd7f7a65 | 7221 | After_Statements : constant List_Id := New_List; |
93bcda23 AC |
7222 | -- Statements to be executed after call returns (to assign IN OUT or |
7223 | -- OUT parameter values). | |
70482933 | 7224 | |
bd7f7a65 | 7225 | Etyp : Entity_Id; |
16db96c5 | 7226 | -- The type of the formal parameter being processed |
c885d7a1 | 7227 | |
bd7f7a65 AC |
7228 | Is_Controlling_Formal : Boolean; |
7229 | Is_First_Controlling_Formal : Boolean; | |
7230 | First_Controlling_Formal_Seen : Boolean := False; | |
92869a7b TQ |
7231 | -- Controlling formal parameters of distributed object primitives |
7232 | -- require special handling, and the first such parameter needs even | |
7233 | -- more special handling. | |
c885d7a1 | 7234 | |
bd7f7a65 AC |
7235 | begin |
7236 | -- ??? document general form of stub subprograms for the PolyORB case | |
c885d7a1 | 7237 | |
bd7f7a65 AC |
7238 | Append_To (Decls, |
7239 | Make_Object_Declaration (Loc, | |
7240 | Defining_Identifier => Request, | |
d80ee77c | 7241 | Aliased_Present => True, |
bd7f7a65 | 7242 | Object_Definition => |
d80ee77c | 7243 | New_Occurrence_Of (RTE (RE_Request), Loc))); |
bd7f7a65 | 7244 | |
2287a75d | 7245 | Result := Make_Temporary (Loc, 'R'); |
bd7f7a65 AC |
7246 | |
7247 | if Is_Function then | |
d693e39d TQ |
7248 | Result_TC := |
7249 | PolyORB_Support.Helpers.Build_TypeCode_Call | |
7250 | (Loc, Etype (Result_Definition (Spec)), Decls); | |
bd7f7a65 AC |
7251 | else |
7252 | Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc); | |
1735e55d | 7253 | end if; |
c885d7a1 | 7254 | |
bd7f7a65 AC |
7255 | Append_To (Decls, |
7256 | Make_Object_Declaration (Loc, | |
7257 | Defining_Identifier => Result, | |
7258 | Aliased_Present => False, | |
7259 | Object_Definition => | |
7260 | New_Occurrence_Of (RTE (RE_NamedValue), Loc), | |
7261 | Expression => | |
7262 | Make_Aggregate (Loc, | |
7263 | Component_Associations => New_List ( | |
7264 | Make_Component_Association (Loc, | |
d693e39d | 7265 | Choices => New_List (Make_Identifier (Loc, Name_Name)), |
bd7f7a65 AC |
7266 | Expression => |
7267 | New_Occurrence_Of (RTE (RE_Result_Name), Loc)), | |
7268 | Make_Component_Association (Loc, | |
7269 | Choices => New_List ( | |
7270 | Make_Identifier (Loc, Name_Argument)), | |
7271 | Expression => | |
7272 | Make_Function_Call (Loc, | |
d693e39d TQ |
7273 | Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), |
7274 | Parameter_Associations => New_List (Result_TC))), | |
bd7f7a65 | 7275 | Make_Component_Association (Loc, |
d693e39d | 7276 | Choices => New_List ( |
bd7f7a65 | 7277 | Make_Identifier (Loc, Name_Arg_Modes)), |
d693e39d | 7278 | Expression => Make_Integer_Literal (Loc, 0)))))); |
bd7f7a65 AC |
7279 | |
7280 | if not Is_Known_Asynchronous then | |
2287a75d | 7281 | Exception_Return_Parameter := Make_Temporary (Loc, 'E'); |
c885d7a1 | 7282 | |
bd7f7a65 AC |
7283 | Append_To (Decls, |
7284 | Make_Object_Declaration (Loc, | |
7285 | Defining_Identifier => Exception_Return_Parameter, | |
7286 | Object_Definition => | |
7287 | New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); | |
c885d7a1 | 7288 | |
bd7f7a65 AC |
7289 | else |
7290 | Exception_Return_Parameter := Empty; | |
7291 | end if; | |
c885d7a1 | 7292 | |
bd7f7a65 | 7293 | -- Initialize and fill in arguments list |
c885d7a1 | 7294 | |
2287a75d | 7295 | Arguments := Make_Temporary (Loc, 'A'); |
bd7f7a65 | 7296 | Declare_Create_NVList (Loc, Arguments, Decls, Statements); |
c885d7a1 | 7297 | |
bd7f7a65 AC |
7298 | Current_Parameter := First (Ordered_Parameters_List); |
7299 | while Present (Current_Parameter) loop | |
bd7f7a65 AC |
7300 | if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then |
7301 | Is_Controlling_Formal := True; | |
7302 | Is_First_Controlling_Formal := | |
7303 | not First_Controlling_Formal_Seen; | |
7304 | First_Controlling_Formal_Seen := True; | |
d693e39d | 7305 | |
bd7f7a65 AC |
7306 | else |
7307 | Is_Controlling_Formal := False; | |
7308 | Is_First_Controlling_Formal := False; | |
7309 | end if; | |
70482933 | 7310 | |
bd7f7a65 AC |
7311 | if Is_Controlling_Formal then |
7312 | ||
d693e39d | 7313 | -- For a controlling formal argument, we send its reference |
bd7f7a65 AC |
7314 | |
7315 | Etyp := RACW_Type; | |
70482933 | 7316 | |
1735e55d AC |
7317 | else |
7318 | Etyp := Etype (Parameter_Type (Current_Parameter)); | |
7319 | end if; | |
c885d7a1 | 7320 | |
d693e39d TQ |
7321 | -- The first controlling formal parameter is treated specially: |
7322 | -- it is used to set the target object of the call. | |
70482933 | 7323 | |
bd7f7a65 | 7324 | if not Is_First_Controlling_Formal then |
bd7f7a65 AC |
7325 | declare |
7326 | Constrained : constant Boolean := | |
7327 | Is_Constrained (Etyp) | |
7328 | or else Is_Elementary_Type (Etyp); | |
70482933 | 7329 | |
2287a75d | 7330 | Any : constant Entity_Id := Make_Temporary (Loc, 'A'); |
70482933 | 7331 | |
bd7f7a65 AC |
7332 | Actual_Parameter : Node_Id := |
7333 | New_Occurrence_Of ( | |
7334 | Defining_Identifier ( | |
7335 | Current_Parameter), Loc); | |
70482933 | 7336 | |
bd7f7a65 | 7337 | Expr : Node_Id; |
70482933 | 7338 | |
bd7f7a65 AC |
7339 | begin |
7340 | if Is_Controlling_Formal then | |
7341 | ||
92869a7b TQ |
7342 | -- For a controlling formal parameter (other than the |
7343 | -- first one), use the corresponding RACW. If the | |
7344 | -- parameter is not an anonymous access parameter, that | |
7345 | -- involves taking its 'Unrestricted_Access. | |
bd7f7a65 AC |
7346 | |
7347 | if Nkind (Parameter_Type (Current_Parameter)) | |
7348 | = N_Access_Definition | |
7349 | then | |
7350 | Actual_Parameter := OK_Convert_To | |
7351 | (Etyp, Actual_Parameter); | |
7352 | else | |
7353 | Actual_Parameter := OK_Convert_To (Etyp, | |
7354 | Make_Attribute_Reference (Loc, | |
d693e39d TQ |
7355 | Prefix => Actual_Parameter, |
7356 | Attribute_Name => Name_Unrestricted_Access)); | |
bd7f7a65 | 7357 | end if; |
70482933 | 7358 | |
bd7f7a65 | 7359 | end if; |
70482933 | 7360 | |
bd7f7a65 AC |
7361 | if In_Present (Current_Parameter) |
7362 | or else not Out_Present (Current_Parameter) | |
7363 | or else not Constrained | |
7364 | or else Is_Controlling_Formal | |
7365 | then | |
92869a7b TQ |
7366 | -- The parameter has an input value, is constrained at |
7367 | -- runtime by an input value, or is a controlling formal | |
7368 | -- parameter (always passed as a reference) other than | |
7369 | -- the first one. | |
70482933 | 7370 | |
d693e39d | 7371 | Expr := PolyORB_Support.Helpers.Build_To_Any_Call |
30ebb114 | 7372 | (Loc, Actual_Parameter, Decls); |
d693e39d | 7373 | |
bd7f7a65 AC |
7374 | else |
7375 | Expr := Make_Function_Call (Loc, | |
d693e39d | 7376 | Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), |
bd7f7a65 | 7377 | Parameter_Associations => New_List ( |
d693e39d TQ |
7378 | PolyORB_Support.Helpers.Build_TypeCode_Call |
7379 | (Loc, Etyp, Decls))); | |
bd7f7a65 | 7380 | end if; |
70482933 | 7381 | |
bd7f7a65 AC |
7382 | Append_To (Decls, |
7383 | Make_Object_Declaration (Loc, | |
d693e39d | 7384 | Defining_Identifier => Any, |
bd7f7a65 AC |
7385 | Aliased_Present => False, |
7386 | Object_Definition => | |
7387 | New_Occurrence_Of (RTE (RE_Any), Loc), | |
d693e39d | 7388 | Expression => Expr)); |
70482933 | 7389 | |
bd7f7a65 AC |
7390 | Append_To (Statements, |
7391 | Add_Parameter_To_NVList (Loc, | |
7392 | Parameter => Current_Parameter, | |
7393 | NVList => Arguments, | |
7394 | Constrained => Constrained, | |
7395 | Any => Any)); | |
7396 | ||
7397 | if Out_Present (Current_Parameter) | |
7398 | and then not Is_Controlling_Formal | |
7399 | then | |
72a3d7c7 AC |
7400 | if Is_Limited_Type (Etyp) then |
7401 | Helpers.Assign_Opaque_From_Any (Loc, | |
8b64ed4c TQ |
7402 | Stms => After_Statements, |
7403 | Typ => Etyp, | |
7404 | N => New_Occurrence_Of (Any, Loc), | |
7405 | Target => | |
7406 | Defining_Identifier (Current_Parameter), | |
7407 | Constrained => True); | |
7408 | ||
72a3d7c7 AC |
7409 | else |
7410 | Append_To (After_Statements, | |
7411 | Make_Assignment_Statement (Loc, | |
7412 | Name => | |
7413 | New_Occurrence_Of ( | |
7414 | Defining_Identifier (Current_Parameter), Loc), | |
7415 | Expression => | |
7416 | PolyORB_Support.Helpers.Build_From_Any_Call | |
7417 | (Etyp, | |
7418 | New_Occurrence_Of (Any, Loc), | |
7419 | Decls))); | |
7420 | end if; | |
bd7f7a65 AC |
7421 | end if; |
7422 | end; | |
7423 | end if; | |
70482933 | 7424 | |
92869a7b TQ |
7425 | -- If the current parameter has a dynamic constrained status, then |
7426 | -- this status is transmitted as well. | |
685bc70f | 7427 | |
bd7f7a65 | 7428 | -- This should be done for accessibility as well ??? |
70482933 | 7429 | |
d693e39d TQ |
7430 | if Nkind (Parameter_Type (Current_Parameter)) /= |
7431 | N_Access_Definition | |
bd7f7a65 | 7432 | and then Need_Extra_Constrained (Current_Parameter) |
1735e55d | 7433 | then |
bd7f7a65 AC |
7434 | -- In this block, we do not use the extra formal that has been |
7435 | -- created because it does not exist at the time of expansion | |
7436 | -- when building calling stubs for remote access to subprogram | |
7437 | -- types. We create an extra variable of this type and push it | |
7438 | -- in the stream after the regular parameters. | |
70482933 | 7439 | |
bd7f7a65 AC |
7440 | declare |
7441 | Extra_Any_Parameter : constant Entity_Id := | |
2287a75d | 7442 | Make_Temporary (Loc, 'P'); |
70482933 | 7443 | |
8aa23fe3 TQ |
7444 | Parameter_Exp : constant Node_Id := |
7445 | Make_Attribute_Reference (Loc, | |
7446 | Prefix => New_Occurrence_Of ( | |
7447 | Defining_Identifier (Current_Parameter), Loc), | |
7448 | Attribute_Name => Name_Constrained); | |
d693e39d | 7449 | |
1735e55d | 7450 | begin |
8aa23fe3 TQ |
7451 | Set_Etype (Parameter_Exp, Etype (Standard_Boolean)); |
7452 | ||
1735e55d AC |
7453 | Append_To (Decls, |
7454 | Make_Object_Declaration (Loc, | |
d693e39d | 7455 | Defining_Identifier => Extra_Any_Parameter, |
bd7f7a65 | 7456 | Aliased_Present => False, |
1735e55d | 7457 | Object_Definition => |
bd7f7a65 AC |
7458 | New_Occurrence_Of (RTE (RE_Any), Loc), |
7459 | Expression => | |
d693e39d | 7460 | PolyORB_Support.Helpers.Build_To_Any_Call |
30ebb114 | 7461 | (Loc, Parameter_Exp, Decls))); |
8aa23fe3 | 7462 | |
1735e55d | 7463 | Append_To (Extra_Formal_Statements, |
bd7f7a65 AC |
7464 | Add_Parameter_To_NVList (Loc, |
7465 | Parameter => Extra_Any_Parameter, | |
7466 | NVList => Arguments, | |
7467 | Constrained => True, | |
7468 | Any => Extra_Any_Parameter)); | |
1735e55d AC |
7469 | end; |
7470 | end if; | |
fbf5a39b | 7471 | |
bd7f7a65 AC |
7472 | Next (Current_Parameter); |
7473 | end loop; | |
fbf5a39b | 7474 | |
16db96c5 AC |
7475 | -- Append the formal statements list to the statements |
7476 | ||
7477 | Append_List_To (Statements, Extra_Formal_Statements); | |
7478 | ||
7479 | Append_To (Statements, | |
d80ee77c AC |
7480 | Make_Procedure_Call_Statement (Loc, |
7481 | Name => | |
7482 | New_Occurrence_Of (RTE (RE_Request_Setup), Loc), | |
7483 | Parameter_Associations => New_List ( | |
7484 | New_Occurrence_Of (Request, Loc), | |
7485 | Target_Object, | |
7486 | Subprogram_Id, | |
7487 | New_Occurrence_Of (Arguments, Loc), | |
7488 | New_Occurrence_Of (Result, Loc), | |
7489 | New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc)))); | |
16db96c5 | 7490 | |
d693e39d TQ |
7491 | pragma Assert |
7492 | (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous)); | |
7493 | ||
16db96c5 | 7494 | if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then |
d693e39d TQ |
7495 | Asynchronous_P := |
7496 | New_Occurrence_Of | |
7497 | (Boolean_Literals (Is_Known_Asynchronous), Loc); | |
7498 | ||
16db96c5 AC |
7499 | else |
7500 | pragma Assert (Present (Asynchronous)); | |
7501 | Asynchronous_P := New_Copy_Tree (Asynchronous); | |
d693e39d | 7502 | |
92869a7b TQ |
7503 | -- The expression node Asynchronous will be used to build an 'if' |
7504 | -- statement at the end of Build_General_Calling_Stubs: we need to | |
7505 | -- make a copy here. | |
16db96c5 AC |
7506 | end if; |
7507 | ||
7508 | Append_To (Parameter_Associations (Last (Statements)), | |
7509 | Make_Indexed_Component (Loc, | |
7510 | Prefix => | |
7511 | New_Occurrence_Of ( | |
7512 | RTE (RE_Asynchronous_P_To_Sync_Scope), Loc), | |
7513 | Expressions => New_List (Asynchronous_P))); | |
7514 | ||
93bcda23 | 7515 | Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke)); |
16db96c5 | 7516 | |
93bcda23 | 7517 | -- Asynchronous case |
16db96c5 | 7518 | |
93bcda23 | 7519 | if not Is_Known_Non_Asynchronous then |
d80ee77c | 7520 | Asynchronous_Statements := New_List (Make_Null_Statement (Loc)); |
93bcda23 AC |
7521 | end if; |
7522 | ||
7523 | -- Non-asynchronous case | |
16db96c5 | 7524 | |
93bcda23 | 7525 | if not Is_Known_Asynchronous then |
16db96c5 AC |
7526 | -- Reraise an exception occurrence from the completed request. |
7527 | -- If the exception occurrence is empty, this is a no-op. | |
7528 | ||
93bcda23 | 7529 | Non_Asynchronous_Statements := New_List ( |
16db96c5 AC |
7530 | Make_Procedure_Call_Statement (Loc, |
7531 | Name => | |
7532 | New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc), | |
7533 | Parameter_Associations => New_List ( | |
7534 | New_Occurrence_Of (Request, Loc)))); | |
7535 | ||
7536 | if Is_Function then | |
92869a7b | 7537 | -- If this is a function call, read the value and return it |
16db96c5 AC |
7538 | |
7539 | Append_To (Non_Asynchronous_Statements, | |
7540 | Make_Tag_Check (Loc, | |
bfc2cdb1 | 7541 | Make_Simple_Return_Statement (Loc, |
d693e39d TQ |
7542 | PolyORB_Support.Helpers.Build_From_Any_Call |
7543 | (Etype (Result_Definition (Spec)), | |
7544 | Make_Selected_Component (Loc, | |
7545 | Prefix => Result, | |
7546 | Selector_Name => Name_Argument), | |
7547 | Decls)))); | |
93bcda23 AC |
7548 | |
7549 | else | |
7550 | ||
7551 | -- Case of a procedure: deal with IN OUT and OUT formals | |
7552 | ||
7553 | Append_List_To (Non_Asynchronous_Statements, After_Statements); | |
16db96c5 AC |
7554 | end if; |
7555 | end if; | |
7556 | ||
16db96c5 AC |
7557 | if Is_Known_Asynchronous then |
7558 | Append_List_To (Statements, Asynchronous_Statements); | |
7559 | ||
7560 | elsif Is_Known_Non_Asynchronous then | |
7561 | Append_List_To (Statements, Non_Asynchronous_Statements); | |
7562 | ||
7563 | else | |
7564 | pragma Assert (Present (Asynchronous)); | |
7565 | Append_To (Statements, | |
7566 | Make_Implicit_If_Statement (Nod, | |
7567 | Condition => Asynchronous, | |
7568 | Then_Statements => Asynchronous_Statements, | |
7569 | Else_Statements => Non_Asynchronous_Statements)); | |
7570 | end if; | |
7571 | end Build_General_Calling_Stubs; | |
7572 | ||
7573 | ----------------------- | |
7574 | -- Build_Stub_Target -- | |
7575 | ----------------------- | |
7576 | ||
7577 | function Build_Stub_Target | |
7578 | (Loc : Source_Ptr; | |
7579 | Decls : List_Id; | |
7580 | RCI_Locator : Entity_Id; | |
7581 | Controlling_Parameter : Entity_Id) return RPC_Target | |
7582 | is | |
7583 | Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA); | |
2287a75d AC |
7584 | Target_Reference : constant Entity_Id := Make_Temporary (Loc, 'T'); |
7585 | ||
16db96c5 AC |
7586 | begin |
7587 | if Present (Controlling_Parameter) then | |
7588 | Append_To (Decls, | |
7589 | Make_Object_Declaration (Loc, | |
7590 | Defining_Identifier => Target_Reference, | |
d693e39d | 7591 | |
16db96c5 AC |
7592 | Object_Definition => |
7593 | New_Occurrence_Of (RTE (RE_Object_Ref), Loc), | |
d693e39d | 7594 | |
16db96c5 AC |
7595 | Expression => |
7596 | Make_Function_Call (Loc, | |
7597 | Name => | |
7598 | New_Occurrence_Of (RTE (RE_Make_Ref), Loc), | |
7599 | Parameter_Associations => New_List ( | |
7600 | Make_Selected_Component (Loc, | |
7601 | Prefix => Controlling_Parameter, | |
7602 | Selector_Name => Name_Target))))); | |
d693e39d TQ |
7603 | |
7604 | -- Note: Controlling_Parameter has the same components as | |
92869a7b | 7605 | -- System.Partition_Interface.RACW_Stub_Type. |
16db96c5 AC |
7606 | |
7607 | Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc); | |
7608 | ||
7609 | else | |
7610 | Target_Info.Object := | |
7611 | Make_Selected_Component (Loc, | |
7675ad4f AC |
7612 | Prefix => |
7613 | Make_Identifier (Loc, Chars (RCI_Locator)), | |
16db96c5 AC |
7614 | Selector_Name => |
7615 | Make_Identifier (Loc, Name_Get_RCI_Package_Ref)); | |
7616 | end if; | |
d693e39d | 7617 | |
16db96c5 AC |
7618 | return Target_Info; |
7619 | end Build_Stub_Target; | |
7620 | ||
16db96c5 AC |
7621 | ----------------------------- |
7622 | -- Build_RPC_Receiver_Body -- | |
7623 | ----------------------------- | |
7624 | ||
7625 | procedure Build_RPC_Receiver_Body | |
7626 | (RPC_Receiver : Entity_Id; | |
7627 | Request : out Entity_Id; | |
7628 | Subp_Id : out Entity_Id; | |
7629 | Subp_Index : out Entity_Id; | |
7630 | Stmts : out List_Id; | |
7631 | Decl : out Node_Id) | |
7632 | is | |
7633 | Loc : constant Source_Ptr := Sloc (RPC_Receiver); | |
7634 | ||
7635 | RPC_Receiver_Spec : Node_Id; | |
7636 | RPC_Receiver_Decls : List_Id; | |
7637 | ||
7638 | begin | |
7639 | Request := Make_Defining_Identifier (Loc, Name_R); | |
7640 | ||
7641 | RPC_Receiver_Spec := | |
9fbb3ae6 AC |
7642 | Build_RPC_Receiver_Specification |
7643 | (RPC_Receiver => RPC_Receiver, | |
7644 | Request_Parameter => Request); | |
16db96c5 AC |
7645 | |
7646 | Subp_Id := Make_Defining_Identifier (Loc, Name_P); | |
7647 | Subp_Index := Make_Defining_Identifier (Loc, Name_I); | |
7648 | ||
7649 | RPC_Receiver_Decls := New_List ( | |
7650 | Make_Object_Renaming_Declaration (Loc, | |
7651 | Defining_Identifier => Subp_Id, | |
7652 | Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), | |
7653 | Name => | |
7654 | Make_Explicit_Dereference (Loc, | |
7655 | Prefix => | |
7656 | Make_Selected_Component (Loc, | |
7657 | Prefix => Request, | |
7658 | Selector_Name => Name_Operation))), | |
7659 | ||
7660 | Make_Object_Declaration (Loc, | |
7661 | Defining_Identifier => Subp_Index, | |
7662 | Object_Definition => | |
7663 | New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), | |
7664 | Expression => | |
7665 | Make_Attribute_Reference (Loc, | |
7666 | Prefix => | |
7667 | New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), | |
7668 | Attribute_Name => Name_Last))); | |
7669 | ||
7670 | Stmts := New_List; | |
7671 | ||
7672 | Decl := | |
7673 | Make_Subprogram_Body (Loc, | |
7674 | Specification => RPC_Receiver_Spec, | |
7675 | Declarations => RPC_Receiver_Decls, | |
7676 | Handled_Statement_Sequence => | |
7677 | Make_Handled_Sequence_Of_Statements (Loc, | |
7678 | Statements => Stmts)); | |
7679 | end Build_RPC_Receiver_Body; | |
7680 | ||
7681 | -------------------------------------- | |
7682 | -- Build_Subprogram_Receiving_Stubs -- | |
7683 | -------------------------------------- | |
7684 | ||
7685 | function Build_Subprogram_Receiving_Stubs | |
7686 | (Vis_Decl : Node_Id; | |
7687 | Asynchronous : Boolean; | |
7688 | Dynamically_Asynchronous : Boolean := False; | |
7689 | Stub_Type : Entity_Id := Empty; | |
7690 | RACW_Type : Entity_Id := Empty; | |
7691 | Parent_Primitive : Entity_Id := Empty) return Node_Id | |
7692 | is | |
7693 | Loc : constant Source_Ptr := Sloc (Vis_Decl); | |
7694 | ||
2287a75d | 7695 | Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); |
8aa23fe3 TQ |
7696 | -- Formal parameter for receiving stubs: a descriptor for an incoming |
7697 | -- request. | |
16db96c5 AC |
7698 | |
7699 | Outer_Decls : constant List_Id := New_List; | |
92869a7b TQ |
7700 | -- At the outermost level, an NVList and Any's are declared for all |
7701 | -- parameters. The Dynamic_Async flag also needs to be declared there | |
7702 | -- to be visible from the exception handling code. | |
16db96c5 AC |
7703 | |
7704 | Outer_Statements : constant List_Id := New_List; | |
7705 | -- Statements that occur prior to the declaration of the actual | |
7706 | -- parameter variables. | |
7707 | ||
8aa23fe3 TQ |
7708 | Outer_Extra_Formal_Statements : constant List_Id := New_List; |
7709 | -- Statements concerning extra formal parameters, prior to the | |
7710 | -- declaration of the actual parameter variables. | |
7711 | ||
16db96c5 AC |
7712 | Decls : constant List_Id := New_List; |
7713 | -- All the parameters will get declared before calling the real | |
c6f39437 AC |
7714 | -- subprograms. Also the out parameters will be declared. At this |
7715 | -- level, parameters may be unconstrained. | |
16db96c5 AC |
7716 | |
7717 | Statements : constant List_Id := New_List; | |
7718 | ||
16db96c5 AC |
7719 | After_Statements : constant List_Id := New_List; |
7720 | -- Statements to be executed after the subprogram call | |
7721 | ||
7722 | Inner_Decls : List_Id := No_List; | |
7723 | -- In case of a function, the inner declarations are needed since | |
7724 | -- the result may be unconstrained. | |
7725 | ||
7726 | Excep_Handlers : List_Id := No_List; | |
7727 | ||
7728 | Parameter_List : constant List_Id := New_List; | |
7729 | -- List of parameters to be passed to the subprogram | |
7730 | ||
7731 | First_Controlling_Formal_Seen : Boolean := False; | |
7732 | ||
7733 | Current_Parameter : Node_Id; | |
7734 | ||
7735 | Ordered_Parameters_List : constant List_Id := | |
7736 | Build_Ordered_Parameters_List | |
7737 | (Specification (Vis_Decl)); | |
7738 | ||
2287a75d | 7739 | Arguments : constant Entity_Id := Make_Temporary (Loc, 'A'); |
16db96c5 AC |
7740 | -- Name of the named values list used to retrieve parameters |
7741 | ||
7742 | Subp_Spec : Node_Id; | |
7743 | -- Subprogram specification | |
7744 | ||
7745 | Called_Subprogram : Node_Id; | |
7746 | -- The subprogram to call | |
7747 | ||
7748 | begin | |
7749 | if Present (RACW_Type) then | |
7750 | Called_Subprogram := | |
7751 | New_Occurrence_Of (Parent_Primitive, Loc); | |
7752 | else | |
7753 | Called_Subprogram := | |
d693e39d TQ |
7754 | New_Occurrence_Of |
7755 | (Defining_Unit_Name (Specification (Vis_Decl)), Loc); | |
16db96c5 AC |
7756 | end if; |
7757 | ||
16db96c5 AC |
7758 | Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements); |
7759 | ||
7760 | -- Loop through every parameter and get its value from the stream. If | |
7761 | -- the parameter is unconstrained, then the parameter is read using | |
7762 | -- 'Input at the point of declaration. | |
7763 | ||
7764 | Current_Parameter := First (Ordered_Parameters_List); | |
7765 | while Present (Current_Parameter) loop | |
7766 | declare | |
7767 | Etyp : Entity_Id; | |
7768 | Constrained : Boolean; | |
2287a75d AC |
7769 | Any : Entity_Id := Empty; |
7770 | Object : constant Entity_Id := Make_Temporary (Loc, 'P'); | |
7771 | Expr : Node_Id := Empty; | |
16db96c5 | 7772 | |
d693e39d TQ |
7773 | Is_Controlling_Formal : constant Boolean := |
7774 | Is_RACW_Controlling_Formal | |
7775 | (Current_Parameter, Stub_Type); | |
16db96c5 AC |
7776 | |
7777 | Is_First_Controlling_Formal : Boolean := False; | |
16db96c5 | 7778 | |
8aa23fe3 TQ |
7779 | Need_Extra_Constrained : Boolean; |
7780 | -- True when an extra constrained actual is required | |
7781 | ||
7782 | begin | |
16db96c5 AC |
7783 | if Is_Controlling_Formal then |
7784 | ||
7785 | -- Controlling formals in distributed object primitive | |
7786 | -- operations are handled specially: | |
c6f39437 | 7787 | |
16db96c5 AC |
7788 | -- - the first controlling formal is used as the |
7789 | -- target of the call; | |
c6f39437 | 7790 | |
16db96c5 AC |
7791 | -- - the remaining controlling formals are transmitted |
7792 | -- as RACWs. | |
7793 | ||
7794 | Etyp := RACW_Type; | |
7795 | Is_First_Controlling_Formal := | |
7796 | not First_Controlling_Formal_Seen; | |
7797 | First_Controlling_Formal_Seen := True; | |
d693e39d | 7798 | |
16db96c5 AC |
7799 | else |
7800 | Etyp := Etype (Parameter_Type (Current_Parameter)); | |
7801 | end if; | |
7802 | ||
7803 | Constrained := | |
d693e39d | 7804 | Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); |
16db96c5 AC |
7805 | |
7806 | if not Is_First_Controlling_Formal then | |
2287a75d | 7807 | Any := Make_Temporary (Loc, 'A'); |
d693e39d | 7808 | |
16db96c5 AC |
7809 | Append_To (Outer_Decls, |
7810 | Make_Object_Declaration (Loc, | |
d693e39d | 7811 | Defining_Identifier => Any, |
16db96c5 AC |
7812 | Object_Definition => |
7813 | New_Occurrence_Of (RTE (RE_Any), Loc), | |
7814 | Expression => | |
7815 | Make_Function_Call (Loc, | |
d693e39d | 7816 | Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), |
16db96c5 | 7817 | Parameter_Associations => New_List ( |
d693e39d TQ |
7818 | PolyORB_Support.Helpers.Build_TypeCode_Call |
7819 | (Loc, Etyp, Outer_Decls))))); | |
16db96c5 AC |
7820 | |
7821 | Append_To (Outer_Statements, | |
7822 | Add_Parameter_To_NVList (Loc, | |
7823 | Parameter => Current_Parameter, | |
7824 | NVList => Arguments, | |
7825 | Constrained => Constrained, | |
7826 | Any => Any)); | |
7827 | end if; | |
7828 | ||
7829 | if Is_First_Controlling_Formal then | |
7830 | declare | |
2287a75d | 7831 | Addr : constant Entity_Id := Make_Temporary (Loc, 'A'); |
d693e39d | 7832 | |
16db96c5 | 7833 | Is_Local : constant Entity_Id := |
2287a75d | 7834 | Make_Temporary (Loc, 'L'); |
16db96c5 | 7835 | |
d693e39d | 7836 | begin |
8aa23fe3 TQ |
7837 | -- Special case: obtain the first controlling formal |
7838 | -- from the target of the remote call, instead of the | |
7839 | -- argument list. | |
16db96c5 AC |
7840 | |
7841 | Append_To (Outer_Decls, | |
7842 | Make_Object_Declaration (Loc, | |
d693e39d | 7843 | Defining_Identifier => Addr, |
16db96c5 AC |
7844 | Object_Definition => |
7845 | New_Occurrence_Of (RTE (RE_Address), Loc))); | |
d693e39d | 7846 | |
16db96c5 AC |
7847 | Append_To (Outer_Decls, |
7848 | Make_Object_Declaration (Loc, | |
d693e39d | 7849 | Defining_Identifier => Is_Local, |
16db96c5 AC |
7850 | Object_Definition => |
7851 | New_Occurrence_Of (Standard_Boolean, Loc))); | |
d693e39d | 7852 | |
16db96c5 AC |
7853 | Append_To (Outer_Statements, |
7854 | Make_Procedure_Call_Statement (Loc, | |
7855 | Name => | |
d693e39d | 7856 | New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), |
16db96c5 AC |
7857 | Parameter_Associations => New_List ( |
7858 | Make_Selected_Component (Loc, | |
7675ad4f | 7859 | Prefix => |
16db96c5 AC |
7860 | New_Occurrence_Of ( |
7861 | Request_Parameter, Loc), | |
7862 | Selector_Name => | |
7863 | Make_Identifier (Loc, Name_Target)), | |
7864 | New_Occurrence_Of (Is_Local, Loc), | |
7865 | New_Occurrence_Of (Addr, Loc)))); | |
7866 | ||
7867 | Expr := Unchecked_Convert_To (RACW_Type, | |
7868 | New_Occurrence_Of (Addr, Loc)); | |
7869 | end; | |
7870 | ||
7871 | elsif In_Present (Current_Parameter) | |
7872 | or else not Out_Present (Current_Parameter) | |
7873 | or else not Constrained | |
7874 | then | |
92869a7b | 7875 | -- If an input parameter is constrained, then its reading is |
16db96c5 AC |
7876 | -- deferred until the beginning of the subprogram body. If |
7877 | -- it is unconstrained, then an expression is built for | |
7878 | -- the object declaration and the variable is set using | |
7879 | -- 'Input instead of 'Read. | |
7880 | ||
72a3d7c7 AC |
7881 | if Constrained and then Is_Limited_Type (Etyp) then |
7882 | Helpers.Assign_Opaque_From_Any (Loc, | |
7883 | Stms => Statements, | |
7884 | Typ => Etyp, | |
7885 | N => New_Occurrence_Of (Any, Loc), | |
7886 | Target => Object); | |
d693e39d | 7887 | |
c6f39437 | 7888 | else |
72a3d7c7 AC |
7889 | Expr := Helpers.Build_From_Any_Call |
7890 | (Etyp, New_Occurrence_Of (Any, Loc), Decls); | |
7891 | ||
7892 | if Constrained then | |
7893 | Append_To (Statements, | |
7894 | Make_Assignment_Statement (Loc, | |
7895 | Name => New_Occurrence_Of (Object, Loc), | |
7896 | Expression => Expr)); | |
7897 | Expr := Empty; | |
7898 | ||
7899 | else | |
7900 | -- Expr will be used to initialize (and constrain) the | |
7901 | -- parameter when it is declared. | |
7902 | null; | |
7903 | end if; | |
c6f39437 AC |
7904 | |
7905 | null; | |
16db96c5 | 7906 | end if; |
16db96c5 AC |
7907 | end if; |
7908 | ||
8aa23fe3 TQ |
7909 | Need_Extra_Constrained := |
7910 | Nkind (Parameter_Type (Current_Parameter)) /= | |
7911 | N_Access_Definition | |
7912 | and then | |
7913 | Ekind (Defining_Identifier (Current_Parameter)) /= E_Void | |
7914 | and then | |
7915 | Present (Extra_Constrained | |
7916 | (Defining_Identifier (Current_Parameter))); | |
7917 | ||
7918 | -- We may not associate an extra constrained actual to a | |
7919 | -- constant object, so if one is needed, declare the actual | |
7920 | -- as a variable even if it won't be modified. | |
7921 | ||
7922 | Build_Actual_Object_Declaration | |
7923 | (Object => Object, | |
7924 | Etyp => Etyp, | |
7925 | Variable => Need_Extra_Constrained | |
7926 | or else Out_Present (Current_Parameter), | |
7927 | Expr => Expr, | |
7928 | Decls => Decls); | |
16db96c5 AC |
7929 | Set_Etype (Object, Etyp); |
7930 | ||
7931 | -- An out parameter may be written back using a 'Write | |
7932 | -- attribute instead of a 'Output because it has been | |
7933 | -- constrained by the parameter given to the caller. Note that | |
8b64ed4c | 7934 | -- OUT controlling arguments in the case of a RACW are not put |
16db96c5 AC |
7935 | -- back in the stream because the pointer on them has not |
7936 | -- changed. | |
7937 | ||
7938 | if Out_Present (Current_Parameter) | |
7939 | and then not Is_Controlling_Formal | |
7940 | then | |
7941 | Append_To (After_Statements, | |
7942 | Make_Procedure_Call_Statement (Loc, | |
d693e39d | 7943 | Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc), |
16db96c5 AC |
7944 | Parameter_Associations => New_List ( |
7945 | New_Occurrence_Of (Any, Loc), | |
d693e39d | 7946 | PolyORB_Support.Helpers.Build_To_Any_Call |
8b64ed4c TQ |
7947 | (Loc, |
7948 | New_Occurrence_Of (Object, Loc), | |
7949 | Decls, | |
7950 | Constrained => True)))); | |
16db96c5 AC |
7951 | end if; |
7952 | ||
7953 | -- For RACW controlling formals, the Etyp of Object is always | |
7954 | -- an RACW, even if the parameter is not of an anonymous access | |
7955 | -- type. In such case, we need to dereference it at call time. | |
7956 | ||
7957 | if Is_Controlling_Formal then | |
7958 | if Nkind (Parameter_Type (Current_Parameter)) /= | |
d693e39d | 7959 | N_Access_Definition |
16db96c5 AC |
7960 | then |
7961 | Append_To (Parameter_List, | |
7962 | Make_Parameter_Association (Loc, | |
7963 | Selector_Name => | |
d693e39d TQ |
7964 | New_Occurrence_Of |
7965 | (Defining_Identifier (Current_Parameter), Loc), | |
16db96c5 AC |
7966 | Explicit_Actual_Parameter => |
7967 | Make_Explicit_Dereference (Loc, | |
c6f39437 | 7968 | Prefix => New_Occurrence_Of (Object, Loc)))); |
16db96c5 AC |
7969 | |
7970 | else | |
7971 | Append_To (Parameter_List, | |
7972 | Make_Parameter_Association (Loc, | |
7973 | Selector_Name => | |
d693e39d TQ |
7974 | New_Occurrence_Of |
7975 | (Defining_Identifier (Current_Parameter), Loc), | |
7976 | ||
16db96c5 | 7977 | Explicit_Actual_Parameter => |
c6f39437 | 7978 | New_Occurrence_Of (Object, Loc))); |
16db96c5 AC |
7979 | end if; |
7980 | ||
7981 | else | |
7982 | Append_To (Parameter_List, | |
7983 | Make_Parameter_Association (Loc, | |
7984 | Selector_Name => | |
7985 | New_Occurrence_Of ( | |
7986 | Defining_Identifier (Current_Parameter), Loc), | |
7987 | Explicit_Actual_Parameter => | |
7988 | New_Occurrence_Of (Object, Loc))); | |
7989 | end if; | |
7990 | ||
7991 | -- If the current parameter needs an extra formal, then read it | |
7992 | -- from the stream and set the corresponding semantic field in | |
7993 | -- the variable. If the kind of the parameter identifier is | |
7994 | -- E_Void, then this is a compiler generated parameter that | |
7995 | -- doesn't need an extra constrained status. | |
7996 | ||
7997 | -- The case of Extra_Accessibility should also be handled ??? | |
7998 | ||
8aa23fe3 | 7999 | if Need_Extra_Constrained then |
16db96c5 AC |
8000 | declare |
8001 | Extra_Parameter : constant Entity_Id := | |
8002 | Extra_Constrained | |
8003 | (Defining_Identifier | |
8004 | (Current_Parameter)); | |
d693e39d | 8005 | |
16db96c5 | 8006 | Extra_Any : constant Entity_Id := |
2287a75d | 8007 | Make_Temporary (Loc, 'A'); |
8aa23fe3 | 8008 | |
16db96c5 | 8009 | Formal_Entity : constant Entity_Id := |
d693e39d TQ |
8010 | Make_Defining_Identifier (Loc, |
8011 | Chars => Chars (Extra_Parameter)); | |
16db96c5 AC |
8012 | |
8013 | Formal_Type : constant Entity_Id := | |
8014 | Etype (Extra_Parameter); | |
d693e39d | 8015 | |
16db96c5 AC |
8016 | begin |
8017 | Append_To (Outer_Decls, | |
8018 | Make_Object_Declaration (Loc, | |
d693e39d | 8019 | Defining_Identifier => Extra_Any, |
16db96c5 | 8020 | Object_Definition => |
8aa23fe3 TQ |
8021 | New_Occurrence_Of (RTE (RE_Any), Loc), |
8022 | Expression => | |
8023 | Make_Function_Call (Loc, | |
8024 | Name => | |
8025 | New_Occurrence_Of (RTE (RE_Create_Any), Loc), | |
8026 | Parameter_Associations => New_List ( | |
8027 | PolyORB_Support.Helpers.Build_TypeCode_Call | |
8028 | (Loc, Formal_Type, Outer_Decls))))); | |
16db96c5 | 8029 | |
8aa23fe3 | 8030 | Append_To (Outer_Extra_Formal_Statements, |
16db96c5 AC |
8031 | Add_Parameter_To_NVList (Loc, |
8032 | Parameter => Extra_Parameter, | |
8033 | NVList => Arguments, | |
8034 | Constrained => True, | |
8035 | Any => Extra_Any)); | |
8036 | ||
8037 | Append_To (Decls, | |
8038 | Make_Object_Declaration (Loc, | |
8039 | Defining_Identifier => Formal_Entity, | |
8040 | Object_Definition => | |
8041 | New_Occurrence_Of (Formal_Type, Loc))); | |
8042 | ||
8aa23fe3 | 8043 | Append_To (Statements, |
16db96c5 | 8044 | Make_Assignment_Statement (Loc, |
d693e39d | 8045 | Name => New_Occurrence_Of (Formal_Entity, Loc), |
16db96c5 | 8046 | Expression => |
d693e39d TQ |
8047 | PolyORB_Support.Helpers.Build_From_Any_Call |
8048 | (Formal_Type, | |
8049 | New_Occurrence_Of (Extra_Any, Loc), | |
8050 | Decls))); | |
16db96c5 | 8051 | Set_Extra_Constrained (Object, Formal_Entity); |
16db96c5 AC |
8052 | end; |
8053 | end if; | |
8054 | end; | |
8055 | ||
8056 | Next (Current_Parameter); | |
8057 | end loop; | |
8058 | ||
8aa23fe3 TQ |
8059 | -- Extra Formals should go after all the other parameters |
8060 | ||
8061 | Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements); | |
8062 | ||
16db96c5 | 8063 | Append_To (Outer_Statements, |
bd7f7a65 | 8064 | Make_Procedure_Call_Statement (Loc, |
d693e39d | 8065 | Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc), |
bd7f7a65 | 8066 | Parameter_Associations => New_List ( |
16db96c5 AC |
8067 | New_Occurrence_Of (Request_Parameter, Loc), |
8068 | New_Occurrence_Of (Arguments, Loc)))); | |
bd7f7a65 | 8069 | |
16db96c5 | 8070 | if Nkind (Specification (Vis_Decl)) = N_Function_Specification then |
70482933 | 8071 | |
d693e39d TQ |
8072 | -- The remote subprogram is a function: Build an inner block to be |
8073 | -- able to hold a potentially unconstrained result in a variable. | |
70482933 | 8074 | |
16db96c5 AC |
8075 | declare |
8076 | Etyp : constant Entity_Id := | |
3eb8fddc | 8077 | Etype (Result_Definition (Specification (Vis_Decl))); |
2287a75d | 8078 | Result : constant Node_Id := Make_Temporary (Loc, 'R'); |
d693e39d | 8079 | |
16db96c5 AC |
8080 | begin |
8081 | Inner_Decls := New_List ( | |
8082 | Make_Object_Declaration (Loc, | |
8083 | Defining_Identifier => Result, | |
8084 | Constant_Present => True, | |
8085 | Object_Definition => New_Occurrence_Of (Etyp, Loc), | |
8086 | Expression => | |
8087 | Make_Function_Call (Loc, | |
8088 | Name => Called_Subprogram, | |
8089 | Parameter_Associations => Parameter_List))); | |
70482933 | 8090 | |
c3d593c9 TQ |
8091 | if Is_Class_Wide_Type (Etyp) then |
8092 | ||
8093 | -- For a remote call to a function with a class-wide type, | |
8094 | -- check that the returned value satisfies the requirements | |
d693e39d | 8095 | -- of (RM E.4(18)). |
c3d593c9 TQ |
8096 | |
8097 | Append_To (Inner_Decls, | |
8098 | Make_Transportable_Check (Loc, | |
8099 | New_Occurrence_Of (Result, Loc))); | |
8100 | ||
8101 | end if; | |
8102 | ||
16db96c5 AC |
8103 | Set_Etype (Result, Etyp); |
8104 | Append_To (After_Statements, | |
8105 | Make_Procedure_Call_Statement (Loc, | |
d693e39d | 8106 | Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc), |
16db96c5 AC |
8107 | Parameter_Associations => New_List ( |
8108 | New_Occurrence_Of (Request_Parameter, Loc), | |
d693e39d | 8109 | PolyORB_Support.Helpers.Build_To_Any_Call |
30ebb114 | 8110 | (Loc, New_Occurrence_Of (Result, Loc), Decls)))); |
d693e39d | 8111 | |
16db96c5 AC |
8112 | -- A DSA function does not have out or inout arguments |
8113 | end; | |
70482933 | 8114 | |
16db96c5 AC |
8115 | Append_To (Statements, |
8116 | Make_Block_Statement (Loc, | |
8117 | Declarations => Inner_Decls, | |
8118 | Handled_Statement_Sequence => | |
8119 | Make_Handled_Sequence_Of_Statements (Loc, | |
8120 | Statements => After_Statements))); | |
70482933 | 8121 | |
16db96c5 AC |
8122 | else |
8123 | -- The remote subprogram is a procedure. We do not need any inner | |
8124 | -- block in this case. No specific processing is required here for | |
8125 | -- the dynamically asynchronous case: the indication of whether | |
8126 | -- call is asynchronous or not is managed by the Sync_Scope | |
8127 | -- attibute of the request, and is handled entirely in the | |
8128 | -- protocol layer. | |
70482933 | 8129 | |
16db96c5 | 8130 | Append_To (After_Statements, |
bd7f7a65 | 8131 | Make_Procedure_Call_Statement (Loc, |
d693e39d | 8132 | Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc), |
bd7f7a65 | 8133 | Parameter_Associations => New_List ( |
16db96c5 | 8134 | New_Occurrence_Of (Request_Parameter, Loc)))); |
bd7f7a65 | 8135 | |
16db96c5 AC |
8136 | Append_To (Statements, |
8137 | Make_Procedure_Call_Statement (Loc, | |
8138 | Name => Called_Subprogram, | |
8139 | Parameter_Associations => Parameter_List)); | |
bd7f7a65 | 8140 | |
16db96c5 | 8141 | Append_List_To (Statements, After_Statements); |
bd7f7a65 | 8142 | end if; |
70482933 | 8143 | |
16db96c5 AC |
8144 | Subp_Spec := |
8145 | Make_Procedure_Specification (Loc, | |
2287a75d | 8146 | Defining_Unit_Name => Make_Temporary (Loc, 'F'), |
70482933 | 8147 | |
16db96c5 AC |
8148 | Parameter_Specifications => New_List ( |
8149 | Make_Parameter_Specification (Loc, | |
8150 | Defining_Identifier => Request_Parameter, | |
8151 | Parameter_Type => | |
8152 | New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); | |
70482933 | 8153 | |
c6f39437 AC |
8154 | -- An exception raised during the execution of an incoming remote |
8155 | -- subprogram call and that needs to be sent back to the caller is | |
8156 | -- propagated by the receiving stubs, and will be handled by the | |
8157 | -- caller (the distribution runtime). | |
70482933 | 8158 | |
16db96c5 | 8159 | if Asynchronous and then not Dynamically_Asynchronous then |
fbf5a39b | 8160 | |
16db96c5 | 8161 | -- For an asynchronous procedure, add a null exception handler |
c885d7a1 | 8162 | |
16db96c5 | 8163 | Excep_Handlers := New_List ( |
8aa23fe3 | 8164 | Make_Implicit_Exception_Handler (Loc, |
16db96c5 AC |
8165 | Exception_Choices => New_List (Make_Others_Choice (Loc)), |
8166 | Statements => New_List (Make_Null_Statement (Loc)))); | |
70482933 | 8167 | |
bd7f7a65 | 8168 | else |
16db96c5 AC |
8169 | -- In the other cases, if an exception is raised, then the |
8170 | -- exception occurrence is propagated. | |
70482933 | 8171 | |
16db96c5 AC |
8172 | null; |
8173 | end if; | |
70482933 | 8174 | |
16db96c5 AC |
8175 | Append_To (Outer_Statements, |
8176 | Make_Block_Statement (Loc, | |
d693e39d | 8177 | Declarations => Decls, |
16db96c5 AC |
8178 | Handled_Statement_Sequence => |
8179 | Make_Handled_Sequence_Of_Statements (Loc, | |
8180 | Statements => Statements))); | |
70482933 | 8181 | |
bd7f7a65 | 8182 | return |
16db96c5 AC |
8183 | Make_Subprogram_Body (Loc, |
8184 | Specification => Subp_Spec, | |
8185 | Declarations => Outer_Decls, | |
8186 | Handled_Statement_Sequence => | |
8187 | Make_Handled_Sequence_Of_Statements (Loc, | |
8188 | Statements => Outer_Statements, | |
8189 | Exception_Handlers => Excep_Handlers)); | |
8190 | end Build_Subprogram_Receiving_Stubs; | |
8aa23fe3 | 8191 | |
bd7f7a65 AC |
8192 | ------------- |
8193 | -- Helpers -- | |
8194 | ------------- | |
8195 | ||
8196 | package body Helpers is | |
8197 | ||
8198 | ----------------------- | |
8199 | -- Local Subprograms -- | |
8200 | ----------------------- | |
8201 | ||
bd7f7a65 AC |
8202 | function Find_Numeric_Representation |
8203 | (Typ : Entity_Id) return Entity_Id; | |
686d0984 AC |
8204 | -- Given a numeric type Typ, return the smallest integer or modular |
8205 | -- type from Interfaces, or the smallest floating point type from | |
8206 | -- Standard whose range encompasses that of Typ. | |
bd7f7a65 | 8207 | |
1f5c7ba8 EB |
8208 | function Is_Generic_Actual_Subtype (Typ : Entity_Id) return Boolean; |
8209 | -- Return true if Typ is a subtype representing a generic formal type | |
8210 | -- as a subtype of the actual type in an instance. This is needed to | |
8211 | -- recognize these subtypes because the Is_Generic_Actual_Type flag | |
8212 | -- can only be relied upon within the instance. | |
8213 | ||
54838d1f | 8214 | function Make_Helper_Function_Name |
bd7f7a65 AC |
8215 | (Loc : Source_Ptr; |
8216 | Typ : Entity_Id; | |
8217 | Nam : Name_Id) return Entity_Id; | |
54838d1f | 8218 | -- Return the name to be assigned for helper subprogram Nam of Typ |
bd7f7a65 AC |
8219 | |
8220 | ------------------------------------------------------------ | |
8221 | -- Common subprograms for building various tree fragments -- | |
8222 | ------------------------------------------------------------ | |
8223 | ||
8224 | function Build_Get_Aggregate_Element | |
8225 | (Loc : Source_Ptr; | |
8226 | Any : Entity_Id; | |
8227 | TC : Node_Id; | |
8228 | Idx : Node_Id) return Node_Id; | |
7f0b5314 TQ |
8229 | -- Build a call to Get_Aggregate_Element on Any for typecode TC, |
8230 | -- returning the Idx'th element. | |
bd7f7a65 AC |
8231 | |
8232 | generic | |
8233 | Subprogram : Entity_Id; | |
8234 | -- Reference location for constructed nodes | |
8235 | ||
8236 | Arry : Entity_Id; | |
8237 | -- For 'Range and Etype | |
8238 | ||
3b42c566 | 8239 | Indexes : List_Id; |
bd7f7a65 AC |
8240 | -- For the construction of the innermost element expression |
8241 | ||
8242 | with procedure Add_Process_Element | |
8243 | (Stmts : List_Id; | |
8244 | Any : Entity_Id; | |
8245 | Counter : Entity_Id; | |
8246 | Datum : Node_Id); | |
8247 | ||
8248 | procedure Append_Array_Traversal | |
8249 | (Stmts : List_Id; | |
8250 | Any : Entity_Id; | |
8251 | Counter : Entity_Id := Empty; | |
8252 | Depth : Pos := 1); | |
8253 | -- Build nested loop statements that iterate over the elements of an | |
8254 | -- array Arry. The statement(s) built by Add_Process_Element are | |
3b42c566 | 8255 | -- executed for each element; Indexes is the list of indexes to be |
bd7f7a65 AC |
8256 | -- used in the construction of the indexed component that denotes the |
8257 | -- current element. Subprogram is the entity for the subprogram for | |
8258 | -- which this iterator is generated. The generated statements are | |
8259 | -- appended to Stmts. | |
8260 | ||
8261 | generic | |
8262 | Rec : Entity_Id; | |
8263 | -- The record entity being dealt with | |
8264 | ||
8265 | with procedure Add_Process_Element | |
8266 | (Stmts : List_Id; | |
8267 | Container : Node_Or_Entity_Id; | |
02248717 | 8268 | Counter : in out Nat; |
bd7f7a65 AC |
8269 | Rec : Entity_Id; |
8270 | Field : Node_Id); | |
8271 | -- Rec is the instance of the record type, or Empty. | |
8272 | -- Field is either the N_Defining_Identifier for a component, | |
8273 | -- or an N_Variant_Part. | |
8274 | ||
8275 | procedure Append_Record_Traversal | |
8276 | (Stmts : List_Id; | |
8277 | Clist : Node_Id; | |
8278 | Container : Node_Or_Entity_Id; | |
02248717 | 8279 | Counter : in out Nat); |
bd7f7a65 AC |
8280 | -- Process component list Clist. Individual fields are passed |
8281 | -- to Field_Processing. Each variant part is also processed. | |
8282 | -- Container is the outer Any (for From_Any/To_Any), | |
8283 | -- the outer typecode (for TC) to which the operation applies. | |
8284 | ||
8285 | ----------------------------- | |
8286 | -- Append_Record_Traversal -- | |
8287 | ----------------------------- | |
8288 | ||
8289 | procedure Append_Record_Traversal | |
8290 | (Stmts : List_Id; | |
8291 | Clist : Node_Id; | |
8292 | Container : Node_Or_Entity_Id; | |
02248717 | 8293 | Counter : in out Nat) |
bd7f7a65 | 8294 | is |
8aa23fe3 TQ |
8295 | CI : List_Id; |
8296 | VP : Node_Id; | |
8297 | -- Clist's Component_Items and Variant_Part | |
1735e55d | 8298 | |
8aa23fe3 | 8299 | Item : Node_Id; |
bd7f7a65 | 8300 | Def : Entity_Id; |
70482933 | 8301 | |
bd7f7a65 | 8302 | begin |
8aa23fe3 TQ |
8303 | if No (Clist) then |
8304 | return; | |
8305 | end if; | |
8306 | ||
8307 | CI := Component_Items (Clist); | |
8308 | VP := Variant_Part (Clist); | |
8309 | ||
8310 | Item := First (CI); | |
bd7f7a65 AC |
8311 | while Present (Item) loop |
8312 | Def := Defining_Identifier (Item); | |
2cd6f54e | 8313 | |
bd7f7a65 AC |
8314 | if not Is_Internal_Name (Chars (Def)) then |
8315 | Add_Process_Element | |
8316 | (Stmts, Container, Counter, Rec, Def); | |
8317 | end if; | |
2cd6f54e | 8318 | |
bd7f7a65 AC |
8319 | Next (Item); |
8320 | end loop; | |
1735e55d | 8321 | |
bd7f7a65 AC |
8322 | if Present (VP) then |
8323 | Add_Process_Element (Stmts, Container, Counter, Rec, VP); | |
8324 | end if; | |
8325 | end Append_Record_Traversal; | |
1735e55d | 8326 | |
72a3d7c7 AC |
8327 | ----------------------------- |
8328 | -- Assign_Opaque_From_Any -- | |
8329 | ----------------------------- | |
8330 | ||
8331 | procedure Assign_Opaque_From_Any | |
8b64ed4c TQ |
8332 | (Loc : Source_Ptr; |
8333 | Stms : List_Id; | |
8334 | Typ : Entity_Id; | |
8335 | N : Node_Id; | |
8336 | Target : Entity_Id; | |
8337 | Constrained : Boolean := False) | |
72a3d7c7 | 8338 | is |
2287a75d | 8339 | Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); |
72a3d7c7 AC |
8340 | Expr : Node_Id; |
8341 | ||
8342 | Read_Call_List : List_Id; | |
8343 | -- List on which to place the 'Read attribute reference | |
8344 | ||
8345 | begin | |
8346 | -- Strm : Buffer_Stream_Type; | |
8347 | ||
8348 | Append_To (Stms, | |
8349 | Make_Object_Declaration (Loc, | |
8350 | Defining_Identifier => Strm, | |
8351 | Aliased_Present => True, | |
8352 | Object_Definition => | |
8353 | New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); | |
8354 | ||
8355 | -- Any_To_BS (Strm, A); | |
8356 | ||
8357 | Append_To (Stms, | |
8358 | Make_Procedure_Call_Statement (Loc, | |
8359 | Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc), | |
8360 | Parameter_Associations => New_List ( | |
8361 | N, | |
8362 | New_Occurrence_Of (Strm, Loc)))); | |
8363 | ||
8b64ed4c | 8364 | if Transmit_As_Unconstrained (Typ) and then not Constrained then |
72a3d7c7 AC |
8365 | Expr := |
8366 | Make_Attribute_Reference (Loc, | |
8367 | Prefix => New_Occurrence_Of (Typ, Loc), | |
8368 | Attribute_Name => Name_Input, | |
8369 | Expressions => New_List ( | |
959dd7d8 AC |
8370 | Make_Attribute_Reference (Loc, |
8371 | Prefix => New_Occurrence_Of (Strm, Loc), | |
8372 | Attribute_Name => Name_Access))); | |
72a3d7c7 | 8373 | |
959dd7d8 | 8374 | -- Target := Typ'Input (Strm'Access) |
72a3d7c7 | 8375 | |
959dd7d8 | 8376 | if Present (Target) then |
72a3d7c7 AC |
8377 | Append_To (Stms, |
8378 | Make_Assignment_Statement (Loc, | |
8379 | Name => New_Occurrence_Of (Target, Loc), | |
8380 | Expression => Expr)); | |
8381 | ||
959dd7d8 | 8382 | -- return Typ'Input (Strm'Access); |
72a3d7c7 | 8383 | |
959dd7d8 | 8384 | else |
72a3d7c7 AC |
8385 | Append_To (Stms, |
8386 | Make_Simple_Return_Statement (Loc, | |
8387 | Expression => Expr)); | |
8388 | end if; | |
8389 | ||
8390 | else | |
8391 | if Present (Target) then | |
8392 | Read_Call_List := Stms; | |
8393 | Expr := New_Occurrence_Of (Target, Loc); | |
8394 | ||
8395 | else | |
8396 | declare | |
2287a75d | 8397 | Temp : constant Entity_Id := Make_Temporary (Loc, 'R'); |
959dd7d8 | 8398 | |
72a3d7c7 AC |
8399 | begin |
8400 | Read_Call_List := New_List; | |
8401 | Expr := New_Occurrence_Of (Temp, Loc); | |
8402 | ||
8403 | Append_To (Stms, Make_Block_Statement (Loc, | |
8404 | Declarations => New_List ( | |
8405 | Make_Object_Declaration (Loc, | |
8406 | Defining_Identifier => | |
8407 | Temp, | |
8408 | Object_Definition => | |
8409 | New_Occurrence_Of (Typ, Loc))), | |
8410 | ||
8411 | Handled_Statement_Sequence => | |
8412 | Make_Handled_Sequence_Of_Statements (Loc, | |
8413 | Statements => Read_Call_List))); | |
8414 | end; | |
8415 | end if; | |
8416 | ||
8417 | -- Typ'Read (Strm'Access, [Target|Temp]) | |
8418 | ||
8419 | Append_To (Read_Call_List, | |
8420 | Make_Attribute_Reference (Loc, | |
8421 | Prefix => New_Occurrence_Of (Typ, Loc), | |
8422 | Attribute_Name => Name_Read, | |
8423 | Expressions => New_List ( | |
8424 | Make_Attribute_Reference (Loc, | |
8425 | Prefix => New_Occurrence_Of (Strm, Loc), | |
8426 | Attribute_Name => Name_Access), | |
8427 | Expr))); | |
8428 | ||
8429 | if No (Target) then | |
959dd7d8 | 8430 | |
72a3d7c7 AC |
8431 | -- return Temp |
8432 | ||
8433 | Append_To (Read_Call_List, | |
8434 | Make_Simple_Return_Statement (Loc, | |
8435 | Expression => New_Copy (Expr))); | |
8436 | end if; | |
8437 | end if; | |
8438 | end Assign_Opaque_From_Any; | |
8439 | ||
bd7f7a65 AC |
8440 | ------------------------- |
8441 | -- Build_From_Any_Call -- | |
8442 | ------------------------- | |
1735e55d | 8443 | |
bd7f7a65 AC |
8444 | function Build_From_Any_Call |
8445 | (Typ : Entity_Id; | |
8446 | N : Node_Id; | |
8447 | Decls : List_Id) return Node_Id | |
8448 | is | |
8449 | Loc : constant Source_Ptr := Sloc (N); | |
1735e55d | 8450 | |
044e51e0 | 8451 | U_Type : Entity_Id := Underlying_Type (Typ); |
70482933 | 8452 | |
044e51e0 | 8453 | Fnam : Entity_Id; |
bd7f7a65 | 8454 | Lib_RE : RE_Id := RE_Null; |
8aa23fe3 | 8455 | Result : Node_Id; |
70482933 | 8456 | |
d693e39d | 8457 | begin |
bd7f7a65 AC |
8458 | -- First simple case where the From_Any function is present |
8459 | -- in the type's TSS. | |
70482933 | 8460 | |
a9d8907c | 8461 | Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any); |
70482933 | 8462 | |
f4b049db AC |
8463 | -- For the subtype representing a generic actual type, go to the |
8464 | -- actual type. | |
8465 | ||
1f5c7ba8 | 8466 | if Is_Generic_Actual_Subtype (U_Type) then |
f4b049db AC |
8467 | U_Type := Underlying_Type (Base_Type (U_Type)); |
8468 | end if; | |
8469 | ||
8470 | -- For a standard subtype, go to the base type | |
8471 | ||
bd7f7a65 AC |
8472 | if Sloc (U_Type) <= Standard_Location then |
8473 | U_Type := Base_Type (U_Type); | |
baad9830 TQ |
8474 | |
8475 | -- For a user subtype, go to first subtype | |
8476 | ||
8477 | elsif Comes_From_Source (U_Type) | |
8478 | and then Nkind (Declaration_Node (U_Type)) | |
8479 | = N_Subtype_Declaration | |
8480 | then | |
8481 | U_Type := First_Subtype (U_Type); | |
1735e55d | 8482 | end if; |
70482933 | 8483 | |
bd7f7a65 AC |
8484 | -- Check first for Boolean and Character. These are enumeration |
8485 | -- types, but we treat them specially, since they may require | |
8486 | -- special handling in the transfer protocol. However, this | |
8487 | -- special handling only applies if they have standard | |
8488 | -- representation, otherwise they are treated like any other | |
8489 | -- enumeration type. | |
70482933 | 8490 | |
bd7f7a65 AC |
8491 | if Present (Fnam) then |
8492 | null; | |
70482933 | 8493 | |
bd7f7a65 AC |
8494 | elsif U_Type = Standard_Boolean then |
8495 | Lib_RE := RE_FA_B; | |
70482933 | 8496 | |
bd7f7a65 AC |
8497 | elsif U_Type = Standard_Character then |
8498 | Lib_RE := RE_FA_C; | |
70482933 | 8499 | |
bd7f7a65 AC |
8500 | elsif U_Type = Standard_Wide_Character then |
8501 | Lib_RE := RE_FA_WC; | |
70482933 | 8502 | |
82c80734 RD |
8503 | elsif U_Type = Standard_Wide_Wide_Character then |
8504 | Lib_RE := RE_FA_WWC; | |
8505 | ||
bd7f7a65 | 8506 | -- Floating point types |
70482933 | 8507 | |
bd7f7a65 AC |
8508 | elsif U_Type = Standard_Short_Float then |
8509 | Lib_RE := RE_FA_SF; | |
7324bf49 | 8510 | |
bd7f7a65 AC |
8511 | elsif U_Type = Standard_Float then |
8512 | Lib_RE := RE_FA_F; | |
7324bf49 | 8513 | |
bd7f7a65 AC |
8514 | elsif U_Type = Standard_Long_Float then |
8515 | Lib_RE := RE_FA_LF; | |
70482933 | 8516 | |
bd7f7a65 AC |
8517 | elsif U_Type = Standard_Long_Long_Float then |
8518 | Lib_RE := RE_FA_LLF; | |
70482933 | 8519 | |
bd7f7a65 | 8520 | -- Integer types |
70482933 | 8521 | |
686d0984 | 8522 | elsif U_Type = RTE (RE_Integer_8) then |
044e51e0 | 8523 | Lib_RE := RE_FA_I8; |
70482933 | 8524 | |
686d0984 AC |
8525 | elsif U_Type = RTE (RE_Integer_16) then |
8526 | Lib_RE := RE_FA_I16; | |
70482933 | 8527 | |
686d0984 AC |
8528 | elsif U_Type = RTE (RE_Integer_32) then |
8529 | Lib_RE := RE_FA_I32; | |
70482933 | 8530 | |
686d0984 AC |
8531 | elsif U_Type = RTE (RE_Integer_64) then |
8532 | Lib_RE := RE_FA_I64; | |
70482933 | 8533 | |
bd7f7a65 | 8534 | -- Unsigned integer types |
70482933 | 8535 | |
686d0984 AC |
8536 | elsif U_Type = RTE (RE_Unsigned_8) then |
8537 | Lib_RE := RE_FA_U8; | |
70482933 | 8538 | |
686d0984 AC |
8539 | elsif U_Type = RTE (RE_Unsigned_16) then |
8540 | Lib_RE := RE_FA_U16; | |
70482933 | 8541 | |
686d0984 AC |
8542 | elsif U_Type = RTE (RE_Unsigned_32) then |
8543 | Lib_RE := RE_FA_U32; | |
70482933 | 8544 | |
686d0984 AC |
8545 | elsif U_Type = RTE (RE_Unsigned_64) then |
8546 | Lib_RE := RE_FA_U64; | |
70482933 | 8547 | |
6bde3eb5 | 8548 | elsif Is_RTE (U_Type, RE_Unbounded_String) then |
bd7f7a65 | 8549 | Lib_RE := RE_FA_String; |
70482933 | 8550 | |
54838d1f AC |
8551 | -- Special DSA types |
8552 | ||
0999b547 | 8553 | elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then |
54838d1f AC |
8554 | Lib_RE := RE_FA_A; |
8555 | ||
bd7f7a65 | 8556 | -- Other (non-primitive) types |
1735e55d | 8557 | |
bd7f7a65 AC |
8558 | else |
8559 | declare | |
8560 | Decl : Entity_Id; | |
dae4faf2 | 8561 | |
bd7f7a65 | 8562 | begin |
7b00e31d | 8563 | Build_From_Any_Function (Loc, U_Type, Decl, Fnam); |
bd7f7a65 AC |
8564 | Append_To (Decls, Decl); |
8565 | end; | |
8566 | end if; | |
70482933 | 8567 | |
bd7f7a65 | 8568 | -- Call the function |
70482933 | 8569 | |
bd7f7a65 AC |
8570 | if Lib_RE /= RE_Null then |
8571 | pragma Assert (No (Fnam)); | |
8572 | Fnam := RTE (Lib_RE); | |
8573 | end if; | |
70482933 | 8574 | |
8aa23fe3 TQ |
8575 | Result := |
8576 | Make_Function_Call (Loc, | |
8577 | Name => New_Occurrence_Of (Fnam, Loc), | |
8578 | Parameter_Associations => New_List (N)); | |
8579 | ||
8580 | -- We must set the type of Result, so the unchecked conversion | |
8581 | -- from the underlying type to the base type is properly done. | |
8582 | ||
8583 | Set_Etype (Result, U_Type); | |
8584 | ||
8585 | return Unchecked_Convert_To (Typ, Result); | |
bd7f7a65 AC |
8586 | end Build_From_Any_Call; |
8587 | ||
8588 | ----------------------------- | |
8589 | -- Build_From_Any_Function -- | |
8590 | ----------------------------- | |
8591 | ||
8592 | procedure Build_From_Any_Function | |
8593 | (Loc : Source_Ptr; | |
8594 | Typ : Entity_Id; | |
8595 | Decl : out Node_Id; | |
8596 | Fnam : out Entity_Id) | |
8597 | is | |
25e9b6fe | 8598 | Spec : Node_Id; |
bd7f7a65 | 8599 | Decls : constant List_Id := New_List; |
25e9b6fe TQ |
8600 | Stms : constant List_Id := New_List; |
8601 | ||
2287a75d | 8602 | Any_Parameter : constant Entity_Id := Make_Temporary (Loc, 'A'); |
25e9b6fe TQ |
8603 | |
8604 | Use_Opaque_Representation : Boolean; | |
8605 | ||
bd7f7a65 | 8606 | begin |
690001a2 BD |
8607 | -- For a derived type, we can't go past the base type (to the |
8608 | -- parent type) here, because that would cause the attribute's | |
8609 | -- formal parameter to have the wrong type; hence the Base_Type | |
8610 | -- check here. | |
a712aa03 AC |
8611 | |
8612 | if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then | |
8aa23fe3 TQ |
8613 | Build_From_Any_Function |
8614 | (Loc => Loc, | |
d693e39d TQ |
8615 | Typ => Etype (Typ), |
8616 | Decl => Decl, | |
8617 | Fnam => Fnam); | |
8aa23fe3 TQ |
8618 | return; |
8619 | end if; | |
8620 | ||
54838d1f | 8621 | Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any); |
70482933 | 8622 | |
bd7f7a65 AC |
8623 | Spec := |
8624 | Make_Function_Specification (Loc, | |
8625 | Defining_Unit_Name => Fnam, | |
8626 | Parameter_Specifications => New_List ( | |
8627 | Make_Parameter_Specification (Loc, | |
d693e39d TQ |
8628 | Defining_Identifier => Any_Parameter, |
8629 | Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), | |
3eb8fddc | 8630 | Result_Definition => New_Occurrence_Of (Typ, Loc)); |
70482933 | 8631 | |
2794f022 | 8632 | -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any |
70482933 | 8633 | |
bd7f7a65 AC |
8634 | pragma Assert |
8635 | (not (Is_Remote_Access_To_Class_Wide_Type (Typ))); | |
70482933 | 8636 | |
25e9b6fe TQ |
8637 | Use_Opaque_Representation := False; |
8638 | ||
8639 | if Has_Stream_Attribute_Definition | |
8640 | (Typ, TSS_Stream_Output, At_Any_Place => True) | |
d693e39d | 8641 | or else |
25e9b6fe TQ |
8642 | Has_Stream_Attribute_Definition |
8643 | (Typ, TSS_Stream_Write, At_Any_Place => True) | |
bd7f7a65 | 8644 | then |
25e9b6fe TQ |
8645 | -- If user-defined stream attributes are specified for this |
8646 | -- type, use them and transmit data as an opaque sequence of | |
8647 | -- stream elements. | |
8648 | ||
8649 | Use_Opaque_Representation := True; | |
8650 | ||
8651 | elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then | |
bd7f7a65 | 8652 | Append_To (Stms, |
bfc2cdb1 | 8653 | Make_Simple_Return_Statement (Loc, |
bd7f7a65 | 8654 | Expression => |
d693e39d TQ |
8655 | OK_Convert_To (Typ, |
8656 | Build_From_Any_Call | |
8657 | (Root_Type (Typ), | |
8658 | New_Occurrence_Of (Any_Parameter, Loc), | |
8659 | Decls)))); | |
bd7f7a65 AC |
8660 | |
8661 | elsif Is_Record_Type (Typ) | |
8662 | and then not Is_Derived_Type (Typ) | |
8663 | and then not Is_Tagged_Type (Typ) | |
8664 | then | |
8665 | if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then | |
8666 | Append_To (Stms, | |
bfc2cdb1 | 8667 | Make_Simple_Return_Statement (Loc, |
bd7f7a65 | 8668 | Expression => |
dae4faf2 TQ |
8669 | Build_From_Any_Call |
8670 | (Etype (Typ), | |
8671 | New_Occurrence_Of (Any_Parameter, Loc), | |
8672 | Decls))); | |
d693e39d | 8673 | |
bd7f7a65 AC |
8674 | else |
8675 | declare | |
d693e39d | 8676 | Disc : Entity_Id := Empty; |
bd7f7a65 | 8677 | Discriminant_Associations : List_Id; |
d693e39d TQ |
8678 | Rdef : constant Node_Id := |
8679 | Type_Definition | |
8680 | (Declaration_Node (Typ)); | |
02248717 | 8681 | Component_Counter : Nat := 0; |
bd7f7a65 AC |
8682 | |
8683 | -- The returned object | |
8684 | ||
2287a75d | 8685 | Res : constant Entity_Id := Make_Temporary (Loc, 'R'); |
bd7f7a65 AC |
8686 | |
8687 | Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc); | |
8688 | ||
8689 | procedure FA_Rec_Add_Process_Element | |
8690 | (Stmts : List_Id; | |
8691 | Any : Entity_Id; | |
02248717 | 8692 | Counter : in out Nat; |
bd7f7a65 AC |
8693 | Rec : Entity_Id; |
8694 | Field : Node_Id); | |
8695 | ||
8696 | procedure FA_Append_Record_Traversal is | |
8697 | new Append_Record_Traversal | |
d693e39d TQ |
8698 | (Rec => Res, |
8699 | Add_Process_Element => FA_Rec_Add_Process_Element); | |
bd7f7a65 AC |
8700 | |
8701 | -------------------------------- | |
8702 | -- FA_Rec_Add_Process_Element -- | |
8703 | -------------------------------- | |
8704 | ||
8705 | procedure FA_Rec_Add_Process_Element | |
8706 | (Stmts : List_Id; | |
8707 | Any : Entity_Id; | |
02248717 | 8708 | Counter : in out Nat; |
bd7f7a65 AC |
8709 | Rec : Entity_Id; |
8710 | Field : Node_Id) | |
8711 | is | |
72a3d7c7 | 8712 | Ctyp : Entity_Id; |
bd7f7a65 AC |
8713 | begin |
8714 | if Nkind (Field) = N_Defining_Identifier then | |
bd7f7a65 AC |
8715 | -- A regular component |
8716 | ||
72a3d7c7 AC |
8717 | Ctyp := Etype (Field); |
8718 | ||
bd7f7a65 AC |
8719 | Append_To (Stmts, |
8720 | Make_Assignment_Statement (Loc, | |
8721 | Name => Make_Selected_Component (Loc, | |
8722 | Prefix => | |
8723 | New_Occurrence_Of (Rec, Loc), | |
8724 | Selector_Name => | |
8725 | New_Occurrence_Of (Field, Loc)), | |
c6f39437 | 8726 | |
bd7f7a65 | 8727 | Expression => |
72a3d7c7 | 8728 | Build_From_Any_Call (Ctyp, |
bd7f7a65 AC |
8729 | Build_Get_Aggregate_Element (Loc, |
8730 | Any => Any, | |
959dd7d8 AC |
8731 | TC => |
8732 | Build_TypeCode_Call (Loc, Ctyp, Decls), | |
8733 | Idx => | |
8734 | Make_Integer_Literal (Loc, Counter)), | |
bd7f7a65 AC |
8735 | Decls))); |
8736 | ||
8737 | else | |
8738 | -- A variant part | |
8739 | ||
8740 | declare | |
d693e39d | 8741 | Variant : Node_Id; |
02248717 | 8742 | Struct_Counter : Nat := 0; |
bd7f7a65 AC |
8743 | |
8744 | Block_Decls : constant List_Id := New_List; | |
8745 | Block_Stmts : constant List_Id := New_List; | |
8746 | VP_Stmts : List_Id; | |
8747 | ||
8748 | Alt_List : constant List_Id := New_List; | |
8749 | Choice_List : List_Id; | |
8750 | ||
8751 | Struct_Any : constant Entity_Id := | |
2287a75d | 8752 | Make_Temporary (Loc, 'S'); |
bd7f7a65 AC |
8753 | |
8754 | begin | |
8755 | Append_To (Decls, | |
8756 | Make_Object_Declaration (Loc, | |
d693e39d TQ |
8757 | Defining_Identifier => Struct_Any, |
8758 | Constant_Present => True, | |
8759 | Object_Definition => | |
bd7f7a65 | 8760 | New_Occurrence_Of (RTE (RE_Any), Loc), |
d693e39d | 8761 | Expression => |
bd7f7a65 | 8762 | Make_Function_Call (Loc, |
d693e39d TQ |
8763 | Name => |
8764 | New_Occurrence_Of | |
8765 | (RTE (RE_Extract_Union_Value), Loc), | |
8766 | ||
bd7f7a65 AC |
8767 | Parameter_Associations => New_List ( |
8768 | Build_Get_Aggregate_Element (Loc, | |
8769 | Any => Any, | |
7f0b5314 TQ |
8770 | TC => |
8771 | Make_Function_Call (Loc, | |
8772 | Name => New_Occurrence_Of ( | |
8773 | RTE (RE_Any_Member_Type), Loc), | |
8774 | Parameter_Associations => | |
8775 | New_List ( | |
8776 | New_Occurrence_Of (Any, Loc), | |
8777 | Make_Integer_Literal (Loc, | |
8778 | Intval => Counter))), | |
8779 | Idx => | |
8780 | Make_Integer_Literal (Loc, | |
8781 | Intval => Counter)))))); | |
bd7f7a65 AC |
8782 | |
8783 | Append_To (Stmts, | |
8784 | Make_Block_Statement (Loc, | |
d693e39d | 8785 | Declarations => Block_Decls, |
bd7f7a65 AC |
8786 | Handled_Statement_Sequence => |
8787 | Make_Handled_Sequence_Of_Statements (Loc, | |
8788 | Statements => Block_Stmts))); | |
8789 | ||
8790 | Append_To (Block_Stmts, | |
8791 | Make_Case_Statement (Loc, | |
8792 | Expression => | |
8793 | Make_Selected_Component (Loc, | |
16db96c5 | 8794 | Prefix => Rec, |
d693e39d TQ |
8795 | Selector_Name => Chars (Name (Field))), |
8796 | Alternatives => Alt_List)); | |
bd7f7a65 AC |
8797 | |
8798 | Variant := First_Non_Pragma (Variants (Field)); | |
bd7f7a65 | 8799 | while Present (Variant) loop |
d693e39d TQ |
8800 | Choice_List := |
8801 | New_Copy_List_Tree | |
8802 | (Discrete_Choices (Variant)); | |
bd7f7a65 AC |
8803 | |
8804 | VP_Stmts := New_List; | |
8aa23fe3 TQ |
8805 | |
8806 | -- Struct_Counter should be reset before | |
8807 | -- handling a variant part. Indeed only one | |
8808 | -- of the case statement alternatives will be | |
e7c0dd39 | 8809 | -- executed at run time, so the counter must |
8aa23fe3 TQ |
8810 | -- start at 0 for every case statement. |
8811 | ||
8812 | Struct_Counter := 0; | |
8813 | ||
bd7f7a65 AC |
8814 | FA_Append_Record_Traversal ( |
8815 | Stmts => VP_Stmts, | |
8816 | Clist => Component_List (Variant), | |
8817 | Container => Struct_Any, | |
8818 | Counter => Struct_Counter); | |
8819 | ||
8820 | Append_To (Alt_List, | |
8821 | Make_Case_Statement_Alternative (Loc, | |
8822 | Discrete_Choices => Choice_List, | |
d693e39d | 8823 | Statements => VP_Stmts)); |
bd7f7a65 AC |
8824 | Next_Non_Pragma (Variant); |
8825 | end loop; | |
8826 | end; | |
8827 | end if; | |
d693e39d | 8828 | |
bd7f7a65 AC |
8829 | Counter := Counter + 1; |
8830 | end FA_Rec_Add_Process_Element; | |
8831 | ||
8832 | begin | |
8833 | -- First all discriminants | |
8834 | ||
8835 | if Has_Discriminants (Typ) then | |
bd7f7a65 AC |
8836 | Discriminant_Associations := New_List; |
8837 | ||
2cd6f54e | 8838 | Disc := First_Discriminant (Typ); |
bd7f7a65 AC |
8839 | while Present (Disc) loop |
8840 | declare | |
8841 | Disc_Var_Name : constant Entity_Id := | |
2cd6f54e TQ |
8842 | Make_Defining_Identifier (Loc, |
8843 | Chars => Chars (Disc)); | |
8844 | Disc_Type : constant Entity_Id := | |
8845 | Etype (Disc); | |
8846 | ||
bd7f7a65 AC |
8847 | begin |
8848 | Append_To (Decls, | |
8849 | Make_Object_Declaration (Loc, | |
d693e39d TQ |
8850 | Defining_Identifier => Disc_Var_Name, |
8851 | Constant_Present => True, | |
8852 | Object_Definition => | |
bd7f7a65 | 8853 | New_Occurrence_Of (Disc_Type, Loc), |
d693e39d | 8854 | |
bd7f7a65 | 8855 | Expression => |
8aa23fe3 | 8856 | Build_From_Any_Call (Disc_Type, |
bd7f7a65 AC |
8857 | Build_Get_Aggregate_Element (Loc, |
8858 | Any => Any_Parameter, | |
7f0b5314 | 8859 | TC => Build_TypeCode_Call |
8aa23fe3 | 8860 | (Loc, Disc_Type, Decls), |
7f0b5314 TQ |
8861 | Idx => Make_Integer_Literal (Loc, |
8862 | Intval => Component_Counter)), | |
bd7f7a65 | 8863 | Decls))); |
d693e39d | 8864 | |
bd7f7a65 AC |
8865 | Component_Counter := Component_Counter + 1; |
8866 | ||
8867 | Append_To (Discriminant_Associations, | |
8868 | Make_Discriminant_Association (Loc, | |
8869 | Selector_Names => New_List ( | |
8870 | New_Occurrence_Of (Disc, Loc)), | |
8871 | Expression => | |
8872 | New_Occurrence_Of (Disc_Var_Name, Loc))); | |
8873 | end; | |
8874 | Next_Discriminant (Disc); | |
8875 | end loop; | |
8876 | ||
2cd6f54e TQ |
8877 | Res_Definition := |
8878 | Make_Subtype_Indication (Loc, | |
8879 | Subtype_Mark => Res_Definition, | |
8880 | Constraint => | |
8881 | Make_Index_Or_Discriminant_Constraint (Loc, | |
8882 | Discriminant_Associations)); | |
bd7f7a65 AC |
8883 | end if; |
8884 | ||
8885 | -- Now we have all the discriminants in variables, we can | |
8886 | -- declared a constrained object. Note that we are not | |
8887 | -- initializing (non-discriminant) components directly in | |
8888 | -- the object declarations, because which fields to | |
8889 | -- initialize depends (at run time) on the discriminant | |
8890 | -- values. | |
8891 | ||
8892 | Append_To (Decls, | |
8893 | Make_Object_Declaration (Loc, | |
d693e39d TQ |
8894 | Defining_Identifier => Res, |
8895 | Object_Definition => Res_Definition)); | |
bd7f7a65 AC |
8896 | |
8897 | -- ... then all components | |
8898 | ||
8899 | FA_Append_Record_Traversal (Stms, | |
8900 | Clist => Component_List (Rdef), | |
8901 | Container => Any_Parameter, | |
8902 | Counter => Component_Counter); | |
8903 | ||
8904 | Append_To (Stms, | |
bfc2cdb1 | 8905 | Make_Simple_Return_Statement (Loc, |
bd7f7a65 AC |
8906 | Expression => New_Occurrence_Of (Res, Loc))); |
8907 | end; | |
8908 | end if; | |
70482933 | 8909 | |
bd7f7a65 AC |
8910 | elsif Is_Array_Type (Typ) then |
8911 | declare | |
8912 | Constrained : constant Boolean := Is_Constrained (Typ); | |
8913 | ||
8914 | procedure FA_Ary_Add_Process_Element | |
8915 | (Stmts : List_Id; | |
8916 | Any : Entity_Id; | |
8917 | Counter : Entity_Id; | |
8918 | Datum : Node_Id); | |
8919 | -- Assign the current element (as identified by Counter) of | |
8920 | -- Any to the variable denoted by name Datum, and advance | |
8921 | -- Counter by 1. If Datum is not an Any, a call to From_Any | |
8922 | -- for its type is inserted. | |
8923 | ||
8924 | -------------------------------- | |
8925 | -- FA_Ary_Add_Process_Element -- | |
8926 | -------------------------------- | |
8927 | ||
8928 | procedure FA_Ary_Add_Process_Element | |
8929 | (Stmts : List_Id; | |
8930 | Any : Entity_Id; | |
8931 | Counter : Entity_Id; | |
8932 | Datum : Node_Id) | |
8933 | is | |
8934 | Assignment : constant Node_Id := | |
8935 | Make_Assignment_Statement (Loc, | |
8936 | Name => Datum, | |
8937 | Expression => Empty); | |
8938 | ||
8aa23fe3 | 8939 | Element_Any : Node_Id; |
8aa23fe3 | 8940 | |
2cd6f54e | 8941 | begin |
8aa23fe3 TQ |
8942 | declare |
8943 | Element_TC : Node_Id; | |
8aa23fe3 | 8944 | |
2cd6f54e | 8945 | begin |
8aa23fe3 TQ |
8946 | if Etype (Datum) = RTE (RE_Any) then |
8947 | ||
8948 | -- When Datum is an Any the Etype field is not | |
8949 | -- sufficient to determine the typecode of Datum | |
8950 | -- (which can be a TC_SEQUENCE or TC_ARRAY | |
8951 | -- depending on the value of Constrained). | |
d693e39d | 8952 | |
8aa23fe3 TQ |
8953 | -- Therefore we retrieve the typecode which has |
8954 | -- been constructed in Append_Array_Traversal with | |
8955 | -- a call to Get_Any_Type. | |
8956 | ||
8957 | Element_TC := | |
8958 | Make_Function_Call (Loc, | |
8959 | Name => New_Occurrence_Of ( | |
8960 | RTE (RE_Get_Any_Type), Loc), | |
8961 | Parameter_Associations => New_List ( | |
8962 | New_Occurrence_Of (Entity (Datum), Loc))); | |
8963 | else | |
8964 | -- For non Any Datum we simply construct a typecode | |
8965 | -- matching the Etype of the Datum. | |
8966 | ||
8967 | Element_TC := Build_TypeCode_Call | |
8968 | (Loc, Etype (Datum), Decls); | |
8969 | end if; | |
8970 | ||
8971 | Element_Any := | |
8972 | Build_Get_Aggregate_Element (Loc, | |
8973 | Any => Any, | |
7f0b5314 | 8974 | TC => Element_TC, |
8aa23fe3 TQ |
8975 | Idx => New_Occurrence_Of (Counter, Loc)); |
8976 | end; | |
8977 | ||
bd7f7a65 AC |
8978 | -- Note: here we *prepend* statements to Stmts, so |
8979 | -- we must do it in reverse order. | |
8980 | ||
8981 | Prepend_To (Stmts, | |
8982 | Make_Assignment_Statement (Loc, | |
8983 | Name => | |
8984 | New_Occurrence_Of (Counter, Loc), | |
8985 | Expression => | |
8986 | Make_Op_Add (Loc, | |
d693e39d TQ |
8987 | Left_Opnd => New_Occurrence_Of (Counter, Loc), |
8988 | Right_Opnd => Make_Integer_Literal (Loc, 1)))); | |
bd7f7a65 AC |
8989 | |
8990 | if Nkind (Datum) /= N_Attribute_Reference then | |
8991 | ||
8992 | -- We ignore the value of the length of each | |
98c99a5a AC |
8993 | -- dimension, since the target array has already been |
8994 | -- constrained anyway. | |
bd7f7a65 AC |
8995 | |
8996 | if Etype (Datum) /= RTE (RE_Any) then | |
8997 | Set_Expression (Assignment, | |
d693e39d TQ |
8998 | Build_From_Any_Call |
8999 | (Component_Type (Typ), Element_Any, Decls)); | |
bd7f7a65 AC |
9000 | else |
9001 | Set_Expression (Assignment, Element_Any); | |
9002 | end if; | |
2cd6f54e | 9003 | |
bd7f7a65 AC |
9004 | Prepend_To (Stmts, Assignment); |
9005 | end if; | |
9006 | end FA_Ary_Add_Process_Element; | |
9007 | ||
2cd6f54e TQ |
9008 | ------------------------ |
9009 | -- Local Declarations -- | |
9010 | ------------------------ | |
9011 | ||
bd7f7a65 AC |
9012 | Counter : constant Entity_Id := |
9013 | Make_Defining_Identifier (Loc, Name_J); | |
9014 | ||
9015 | Initial_Counter_Value : Int := 0; | |
9016 | ||
9017 | Component_TC : constant Entity_Id := | |
9018 | Make_Defining_Identifier (Loc, Name_T); | |
9019 | ||
9020 | Res : constant Entity_Id := | |
9021 | Make_Defining_Identifier (Loc, Name_R); | |
9022 | ||
9023 | procedure Append_From_Any_Array_Iterator is | |
9024 | new Append_Array_Traversal ( | |
9025 | Subprogram => Fnam, | |
9026 | Arry => Res, | |
3b42c566 | 9027 | Indexes => New_List, |
bd7f7a65 AC |
9028 | Add_Process_Element => FA_Ary_Add_Process_Element); |
9029 | ||
9030 | Res_Subtype_Indication : Node_Id := | |
9031 | New_Occurrence_Of (Typ, Loc); | |
70482933 | 9032 | |
bd7f7a65 AC |
9033 | begin |
9034 | if not Constrained then | |
9035 | declare | |
9036 | Ndim : constant Int := Number_Dimensions (Typ); | |
9037 | Lnam : Name_Id; | |
9038 | Hnam : Name_Id; | |
9039 | Indx : Node_Id := First_Index (Typ); | |
9040 | Indt : Entity_Id; | |
9041 | ||
9042 | Ranges : constant List_Id := New_List; | |
9043 | ||
9044 | begin | |
9045 | for J in 1 .. Ndim loop | |
9046 | Lnam := New_External_Name ('L', J); | |
9047 | Hnam := New_External_Name ('H', J); | |
6bde3eb5 AC |
9048 | |
9049 | -- Note, for empty arrays bounds may be out of | |
9050 | -- the range of Etype (Indx). | |
9051 | ||
9052 | Indt := Base_Type (Etype (Indx)); | |
bd7f7a65 AC |
9053 | |
9054 | Append_To (Decls, | |
9055 | Make_Object_Declaration (Loc, | |
9056 | Defining_Identifier => | |
9057 | Make_Defining_Identifier (Loc, Lnam), | |
d693e39d | 9058 | Constant_Present => True, |
bd7f7a65 AC |
9059 | Object_Definition => |
9060 | New_Occurrence_Of (Indt, Loc), | |
9061 | Expression => | |
d693e39d TQ |
9062 | Build_From_Any_Call |
9063 | (Indt, | |
9064 | Build_Get_Aggregate_Element (Loc, | |
9065 | Any => Any_Parameter, | |
9066 | TC => Build_TypeCode_Call | |
9067 | (Loc, Indt, Decls), | |
9068 | Idx => | |
9069 | Make_Integer_Literal (Loc, J - 1)), | |
bd7f7a65 AC |
9070 | Decls))); |
9071 | ||
9072 | Append_To (Decls, | |
9073 | Make_Object_Declaration (Loc, | |
9074 | Defining_Identifier => | |
9075 | Make_Defining_Identifier (Loc, Hnam), | |
d693e39d TQ |
9076 | |
9077 | Constant_Present => True, | |
9078 | ||
bd7f7a65 AC |
9079 | Object_Definition => |
9080 | New_Occurrence_Of (Indt, Loc), | |
d693e39d | 9081 | |
bd7f7a65 AC |
9082 | Expression => Make_Attribute_Reference (Loc, |
9083 | Prefix => | |
9084 | New_Occurrence_Of (Indt, Loc), | |
d693e39d | 9085 | |
bd7f7a65 | 9086 | Attribute_Name => Name_Val, |
d693e39d | 9087 | |
bd7f7a65 AC |
9088 | Expressions => New_List ( |
9089 | Make_Op_Subtract (Loc, | |
9090 | Left_Opnd => | |
9091 | Make_Op_Add (Loc, | |
9092 | Left_Opnd => | |
7675ad4f AC |
9093 | OK_Convert_To |
9094 | (Standard_Long_Integer, | |
9095 | Make_Identifier (Loc, Lnam)), | |
d693e39d | 9096 | |
bd7f7a65 | 9097 | Right_Opnd => |
7675ad4f AC |
9098 | OK_Convert_To |
9099 | (Standard_Long_Integer, | |
9100 | Make_Function_Call (Loc, | |
9101 | Name => | |
9102 | New_Occurrence_Of (RTE ( | |
9103 | RE_Get_Nested_Sequence_Length | |
9104 | ), Loc), | |
9105 | Parameter_Associations => | |
9106 | New_List ( | |
9107 | New_Occurrence_Of ( | |
9108 | Any_Parameter, Loc), | |
9109 | Make_Integer_Literal (Loc, | |
9110 | Intval => J))))), | |
d693e39d | 9111 | |
bd7f7a65 AC |
9112 | Right_Opnd => |
9113 | Make_Integer_Literal (Loc, 1)))))); | |
9114 | ||
9115 | Append_To (Ranges, | |
9116 | Make_Range (Loc, | |
9117 | Low_Bound => Make_Identifier (Loc, Lnam), | |
9118 | High_Bound => Make_Identifier (Loc, Hnam))); | |
9119 | ||
9120 | Next_Index (Indx); | |
9121 | end loop; | |
9122 | ||
9123 | -- Now we have all the necessary bound information: | |
9124 | -- apply the set of range constraints to the | |
9125 | -- (unconstrained) nominal subtype of Res. | |
9126 | ||
9127 | Initial_Counter_Value := Ndim; | |
9128 | Res_Subtype_Indication := Make_Subtype_Indication (Loc, | |
d693e39d | 9129 | Subtype_Mark => Res_Subtype_Indication, |
bd7f7a65 AC |
9130 | Constraint => |
9131 | Make_Index_Or_Discriminant_Constraint (Loc, | |
9132 | Constraints => Ranges)); | |
9133 | end; | |
9134 | end if; | |
70482933 | 9135 | |
bd7f7a65 AC |
9136 | Append_To (Decls, |
9137 | Make_Object_Declaration (Loc, | |
9138 | Defining_Identifier => Res, | |
9139 | Object_Definition => Res_Subtype_Indication)); | |
9140 | Set_Etype (Res, Typ); | |
70482933 | 9141 | |
bd7f7a65 AC |
9142 | Append_To (Decls, |
9143 | Make_Object_Declaration (Loc, | |
9144 | Defining_Identifier => Counter, | |
9145 | Object_Definition => | |
686d0984 | 9146 | New_Occurrence_Of (RTE (RE_Unsigned_32), Loc), |
bd7f7a65 AC |
9147 | Expression => |
9148 | Make_Integer_Literal (Loc, Initial_Counter_Value))); | |
70482933 | 9149 | |
bd7f7a65 AC |
9150 | Append_To (Decls, |
9151 | Make_Object_Declaration (Loc, | |
9152 | Defining_Identifier => Component_TC, | |
d693e39d TQ |
9153 | Constant_Present => True, |
9154 | Object_Definition => | |
bd7f7a65 | 9155 | New_Occurrence_Of (RTE (RE_TypeCode), Loc), |
d693e39d | 9156 | Expression => |
bd7f7a65 AC |
9157 | Build_TypeCode_Call (Loc, |
9158 | Component_Type (Typ), Decls))); | |
9159 | ||
d693e39d TQ |
9160 | Append_From_Any_Array_Iterator |
9161 | (Stms, Any_Parameter, Counter); | |
bd7f7a65 AC |
9162 | |
9163 | Append_To (Stms, | |
bfc2cdb1 | 9164 | Make_Simple_Return_Statement (Loc, |
bd7f7a65 AC |
9165 | Expression => New_Occurrence_Of (Res, Loc))); |
9166 | end; | |
70482933 | 9167 | |
bd7f7a65 AC |
9168 | elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then |
9169 | Append_To (Stms, | |
bfc2cdb1 | 9170 | Make_Simple_Return_Statement (Loc, |
bd7f7a65 | 9171 | Expression => |
d693e39d TQ |
9172 | Unchecked_Convert_To (Typ, |
9173 | Build_From_Any_Call | |
9174 | (Find_Numeric_Representation (Typ), | |
9175 | New_Occurrence_Of (Any_Parameter, Loc), | |
9176 | Decls)))); | |
c885d7a1 | 9177 | |
bd7f7a65 | 9178 | else |
25e9b6fe TQ |
9179 | Use_Opaque_Representation := True; |
9180 | end if; | |
9181 | ||
9182 | if Use_Opaque_Representation then | |
72a3d7c7 AC |
9183 | Assign_Opaque_From_Any (Loc, |
9184 | Stms => Stms, | |
9185 | Typ => Typ, | |
9186 | N => New_Occurrence_Of (Any_Parameter, Loc), | |
9187 | Target => Empty); | |
bd7f7a65 | 9188 | end if; |
1735e55d | 9189 | |
bd7f7a65 AC |
9190 | Decl := |
9191 | Make_Subprogram_Body (Loc, | |
9192 | Specification => Spec, | |
9193 | Declarations => Decls, | |
9194 | Handled_Statement_Sequence => | |
9195 | Make_Handled_Sequence_Of_Statements (Loc, | |
9196 | Statements => Stms)); | |
9197 | end Build_From_Any_Function; | |
9198 | ||
9199 | --------------------------------- | |
9200 | -- Build_Get_Aggregate_Element -- | |
9201 | --------------------------------- | |
9202 | ||
9203 | function Build_Get_Aggregate_Element | |
9204 | (Loc : Source_Ptr; | |
9205 | Any : Entity_Id; | |
9206 | TC : Node_Id; | |
9207 | Idx : Node_Id) return Node_Id | |
9208 | is | |
9209 | begin | |
9210 | return Make_Function_Call (Loc, | |
9211 | Name => | |
d693e39d | 9212 | New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc), |
bd7f7a65 AC |
9213 | Parameter_Associations => New_List ( |
9214 | New_Occurrence_Of (Any, Loc), | |
9215 | TC, | |
9216 | Idx)); | |
9217 | end Build_Get_Aggregate_Element; | |
9218 | ||
8016e567 PT |
9219 | ---------------------------------- |
9220 | -- Build_Name_And_Repository_Id -- | |
9221 | ---------------------------------- | |
bd7f7a65 AC |
9222 | |
9223 | procedure Build_Name_And_Repository_Id | |
9224 | (E : Entity_Id; | |
9225 | Name_Str : out String_Id; | |
9226 | Repo_Id_Str : out String_Id) | |
9227 | is | |
9228 | begin | |
72267417 | 9229 | Name_Str := Fully_Qualified_Name_String (E, Append_NUL => False); |
bd7f7a65 AC |
9230 | Start_String; |
9231 | Store_String_Chars ("DSA:"); | |
72267417 | 9232 | Store_String_Chars (Name_Str); |
bd7f7a65 AC |
9233 | Store_String_Chars (":1.0"); |
9234 | Repo_Id_Str := End_String; | |
bd7f7a65 AC |
9235 | end Build_Name_And_Repository_Id; |
9236 | ||
9237 | ----------------------- | |
9238 | -- Build_To_Any_Call -- | |
9239 | ----------------------- | |
9240 | ||
9241 | function Build_To_Any_Call | |
8b64ed4c TQ |
9242 | (Loc : Source_Ptr; |
9243 | N : Node_Id; | |
9244 | Decls : List_Id; | |
9245 | Constrained : Boolean := False) return Node_Id | |
bd7f7a65 | 9246 | is |
c6f39437 AC |
9247 | Typ : Entity_Id := Etype (N); |
9248 | U_Type : Entity_Id; | |
9249 | C_Type : Entity_Id; | |
044e51e0 | 9250 | Fnam : Entity_Id; |
c6f39437 | 9251 | Lib_RE : RE_Id := RE_Null; |
70482933 | 9252 | |
bd7f7a65 | 9253 | begin |
8aa23fe3 | 9254 | -- If N is a selected component, then maybe its Etype has not been |
2cd6f54e | 9255 | -- set yet: try to use Etype of the selector_name in that case. |
70482933 | 9256 | |
bd7f7a65 AC |
9257 | if No (Typ) and then Nkind (N) = N_Selected_Component then |
9258 | Typ := Etype (Selector_Name (N)); | |
9259 | end if; | |
c6f39437 | 9260 | |
bd7f7a65 | 9261 | pragma Assert (Present (Typ)); |
70482933 | 9262 | |
2cd6f54e | 9263 | -- Get full view for private type, completion for incomplete type |
70482933 | 9264 | |
bd7f7a65 | 9265 | U_Type := Underlying_Type (Typ); |
1735e55d | 9266 | |
8aa23fe3 TQ |
9267 | -- First simple case where the To_Any function is present in the |
9268 | -- type's TSS. | |
1735e55d | 9269 | |
a9d8907c | 9270 | Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any); |
1735e55d | 9271 | |
f4b049db AC |
9272 | -- For the subtype representing a generic actual type, go to the |
9273 | -- actual type. | |
9274 | ||
1f5c7ba8 | 9275 | if Is_Generic_Actual_Subtype (U_Type) then |
f4b049db AC |
9276 | U_Type := Underlying_Type (Base_Type (U_Type)); |
9277 | end if; | |
9278 | ||
9279 | -- For a standard subtype, go to the base type | |
1735e55d | 9280 | |
bd7f7a65 AC |
9281 | if Sloc (U_Type) <= Standard_Location then |
9282 | U_Type := Base_Type (U_Type); | |
baad9830 TQ |
9283 | |
9284 | -- For a user subtype, go to first subtype | |
9285 | ||
9286 | elsif Comes_From_Source (U_Type) | |
9287 | and then Nkind (Declaration_Node (U_Type)) | |
9288 | = N_Subtype_Declaration | |
9289 | then | |
9290 | U_Type := First_Subtype (U_Type); | |
bd7f7a65 | 9291 | end if; |
1735e55d | 9292 | |
bd7f7a65 AC |
9293 | if Present (Fnam) then |
9294 | null; | |
1735e55d | 9295 | |
f4b049db AC |
9296 | -- Check first for Boolean and Character. These are enumeration |
9297 | -- types, but we treat them specially, since they may require | |
9298 | -- special handling in the transfer protocol. However, this | |
9299 | -- special handling only applies if they have standard | |
9300 | -- representation, otherwise they are treated like any other | |
9301 | -- enumeration type. | |
9302 | ||
bd7f7a65 AC |
9303 | elsif U_Type = Standard_Boolean then |
9304 | Lib_RE := RE_TA_B; | |
1735e55d | 9305 | |
bd7f7a65 AC |
9306 | elsif U_Type = Standard_Character then |
9307 | Lib_RE := RE_TA_C; | |
70482933 | 9308 | |
bd7f7a65 AC |
9309 | elsif U_Type = Standard_Wide_Character then |
9310 | Lib_RE := RE_TA_WC; | |
70482933 | 9311 | |
82c80734 RD |
9312 | elsif U_Type = Standard_Wide_Wide_Character then |
9313 | Lib_RE := RE_TA_WWC; | |
9314 | ||
bd7f7a65 | 9315 | -- Floating point types |
70482933 | 9316 | |
bd7f7a65 AC |
9317 | elsif U_Type = Standard_Short_Float then |
9318 | Lib_RE := RE_TA_SF; | |
70482933 | 9319 | |
bd7f7a65 AC |
9320 | elsif U_Type = Standard_Float then |
9321 | Lib_RE := RE_TA_F; | |
c885d7a1 | 9322 | |
bd7f7a65 AC |
9323 | elsif U_Type = Standard_Long_Float then |
9324 | Lib_RE := RE_TA_LF; | |
c885d7a1 | 9325 | |
bd7f7a65 AC |
9326 | elsif U_Type = Standard_Long_Long_Float then |
9327 | Lib_RE := RE_TA_LLF; | |
70482933 | 9328 | |
bd7f7a65 | 9329 | -- Integer types |
70482933 | 9330 | |
686d0984 AC |
9331 | elsif U_Type = RTE (RE_Integer_8) then |
9332 | Lib_RE := RE_TA_I8; | |
70482933 | 9333 | |
686d0984 AC |
9334 | elsif U_Type = RTE (RE_Integer_16) then |
9335 | Lib_RE := RE_TA_I16; | |
70482933 | 9336 | |
686d0984 AC |
9337 | elsif U_Type = RTE (RE_Integer_32) then |
9338 | Lib_RE := RE_TA_I32; | |
70482933 | 9339 | |
686d0984 AC |
9340 | elsif U_Type = RTE (RE_Integer_64) then |
9341 | Lib_RE := RE_TA_I64; | |
70482933 | 9342 | |
bd7f7a65 | 9343 | -- Unsigned integer types |
70482933 | 9344 | |
686d0984 AC |
9345 | elsif U_Type = RTE (RE_Unsigned_8) then |
9346 | Lib_RE := RE_TA_U8; | |
1735e55d | 9347 | |
686d0984 AC |
9348 | elsif U_Type = RTE (RE_Unsigned_16) then |
9349 | Lib_RE := RE_TA_U16; | |
1735e55d | 9350 | |
686d0984 AC |
9351 | elsif U_Type = RTE (RE_Unsigned_32) then |
9352 | Lib_RE := RE_TA_U32; | |
70482933 | 9353 | |
686d0984 AC |
9354 | elsif U_Type = RTE (RE_Unsigned_64) then |
9355 | Lib_RE := RE_TA_U64; | |
70482933 | 9356 | |
6bde3eb5 | 9357 | elsif Is_RTE (U_Type, RE_Unbounded_String) then |
bd7f7a65 | 9358 | Lib_RE := RE_TA_String; |
70482933 | 9359 | |
54838d1f AC |
9360 | -- Special DSA types |
9361 | ||
0999b547 | 9362 | elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then |
54838d1f | 9363 | Lib_RE := RE_TA_A; |
0999b547 | 9364 | U_Type := Typ; |
54838d1f | 9365 | |
bd7f7a65 | 9366 | elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then |
1db3c072 | 9367 | |
54838d1f | 9368 | -- No corresponding FA_TC ??? |
1db3c072 | 9369 | |
bd7f7a65 | 9370 | Lib_RE := RE_TA_TC; |
70482933 | 9371 | |
bd7f7a65 | 9372 | -- Other (non-primitive) types |
70482933 | 9373 | |
bd7f7a65 AC |
9374 | else |
9375 | declare | |
9376 | Decl : Entity_Id; | |
9377 | begin | |
9378 | Build_To_Any_Function (Loc, U_Type, Decl, Fnam); | |
9379 | Append_To (Decls, Decl); | |
9380 | end; | |
9381 | end if; | |
1735e55d | 9382 | |
bd7f7a65 | 9383 | -- Call the function |
1735e55d | 9384 | |
bd7f7a65 AC |
9385 | if Lib_RE /= RE_Null then |
9386 | pragma Assert (No (Fnam)); | |
9387 | Fnam := RTE (Lib_RE); | |
9388 | end if; | |
70482933 | 9389 | |
6bde3eb5 AC |
9390 | -- If Fnam is already analyzed, find the proper expected type, |
9391 | -- else we have a newly constructed To_Any function and we know | |
9392 | -- that the expected type of its parameter is U_Type. | |
9393 | ||
9394 | if Ekind (Fnam) = E_Function | |
092ef350 | 9395 | and then Present (First_Formal (Fnam)) |
6bde3eb5 AC |
9396 | then |
9397 | C_Type := Etype (First_Formal (Fnam)); | |
9398 | else | |
9399 | C_Type := U_Type; | |
9400 | end if; | |
9401 | ||
8b64ed4c TQ |
9402 | declare |
9403 | Params : constant List_Id := | |
9404 | New_List (OK_Convert_To (C_Type, N)); | |
9405 | begin | |
9406 | if Is_Limited_Type (C_Type) then | |
9407 | Append_To (Params, | |
9408 | New_Occurrence_Of (Boolean_Literals (Constrained), Loc)); | |
9409 | end if; | |
9410 | ||
9411 | return | |
9412 | Make_Function_Call (Loc, | |
9413 | Name => New_Occurrence_Of (Fnam, Loc), | |
9414 | Parameter_Associations => Params); | |
9415 | end; | |
bd7f7a65 AC |
9416 | end Build_To_Any_Call; |
9417 | ||
9418 | --------------------------- | |
9419 | -- Build_To_Any_Function -- | |
9420 | --------------------------- | |
9421 | ||
9422 | procedure Build_To_Any_Function | |
9423 | (Loc : Source_Ptr; | |
9424 | Typ : Entity_Id; | |
9425 | Decl : out Node_Id; | |
9426 | Fnam : out Entity_Id) | |
9427 | is | |
8b64ed4c TQ |
9428 | Spec : Node_Id; |
9429 | Params : List_Id; | |
9430 | Decls : List_Id; | |
9431 | Stms : List_Id; | |
70482933 | 9432 | |
8b64ed4c | 9433 | Expr_Formal : Entity_Id; |
1f8766d3 | 9434 | Cstr_Formal : Entity_Id := Empty; -- initialize to prevent warning |
8b64ed4c TQ |
9435 | Any : Entity_Id; |
9436 | Result_TC : Node_Id; | |
1735e55d | 9437 | |
bd7f7a65 | 9438 | Any_Decl : Node_Id; |
1735e55d | 9439 | |
25e9b6fe TQ |
9440 | Use_Opaque_Representation : Boolean; |
9441 | -- When True, use stream attributes and represent type as an | |
9442 | -- opaque sequence of bytes. | |
9443 | ||
bd7f7a65 | 9444 | begin |
690001a2 BD |
9445 | -- For a derived type, we can't go past the base type (to the |
9446 | -- parent type) here, because that would cause the attribute's | |
9447 | -- formal parameter to have the wrong type; hence the Base_Type | |
9448 | -- check here. | |
a712aa03 AC |
9449 | |
9450 | if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then | |
8aa23fe3 | 9451 | Build_To_Any_Function |
c768e988 AC |
9452 | (Loc => Loc, |
9453 | Typ => Etype (Typ), | |
9454 | Decl => Decl, | |
9455 | Fnam => Fnam); | |
8aa23fe3 TQ |
9456 | return; |
9457 | end if; | |
9458 | ||
8b64ed4c TQ |
9459 | Decls := New_List; |
9460 | Stms := New_List; | |
9461 | ||
9462 | Any := Make_Defining_Identifier (Loc, Name_A); | |
9463 | Result_TC := Build_TypeCode_Call (Loc, Typ, Decls); | |
f4b049db | 9464 | |
54838d1f | 9465 | Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any); |
1735e55d | 9466 | |
8b64ed4c TQ |
9467 | Expr_Formal := Make_Defining_Identifier (Loc, Name_E); |
9468 | Params := New_List ( | |
9469 | Make_Parameter_Specification (Loc, | |
9470 | Defining_Identifier => Expr_Formal, | |
9471 | Parameter_Type => New_Occurrence_Of (Typ, Loc))); | |
9472 | Set_Etype (Expr_Formal, Typ); | |
9473 | ||
9474 | if Is_Limited_Type (Typ) then | |
9475 | Cstr_Formal := Make_Defining_Identifier (Loc, Name_C); | |
9476 | Append_To (Params, | |
9477 | Make_Parameter_Specification (Loc, | |
9478 | Defining_Identifier => Cstr_Formal, | |
9479 | Parameter_Type => | |
9480 | New_Occurrence_Of (Standard_Boolean, Loc))); | |
9481 | end if; | |
9482 | ||
bd7f7a65 AC |
9483 | Spec := |
9484 | Make_Function_Specification (Loc, | |
8b64ed4c TQ |
9485 | Defining_Unit_Name => Fnam, |
9486 | Parameter_Specifications => Params, | |
9487 | Result_Definition => | |
9488 | New_Occurrence_Of (RTE (RE_Any), Loc)); | |
bd7f7a65 AC |
9489 | |
9490 | Any_Decl := | |
9491 | Make_Object_Declaration (Loc, | |
d693e39d TQ |
9492 | Defining_Identifier => Any, |
9493 | Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); | |
1735e55d | 9494 | |
25e9b6fe TQ |
9495 | Use_Opaque_Representation := False; |
9496 | ||
9497 | if Has_Stream_Attribute_Definition | |
9498 | (Typ, TSS_Stream_Output, At_Any_Place => True) | |
9499 | or else | |
9500 | Has_Stream_Attribute_Definition | |
9501 | (Typ, TSS_Stream_Write, At_Any_Place => True) | |
9502 | then | |
9503 | -- If user-defined stream attributes are specified for this | |
9504 | -- type, use them and transmit data as an opaque sequence of | |
9505 | -- stream elements. | |
9506 | ||
9507 | Use_Opaque_Representation := True; | |
9508 | ||
9509 | elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then | |
9510 | ||
1fb63e89 | 9511 | -- Untagged derived type: convert to root type |
25e9b6fe | 9512 | |
bd7f7a65 | 9513 | declare |
25e9b6fe TQ |
9514 | Rt_Type : constant Entity_Id := Root_Type (Typ); |
9515 | Expr : constant Node_Id := | |
9516 | OK_Convert_To | |
9517 | (Rt_Type, | |
8b64ed4c | 9518 | New_Occurrence_Of (Expr_Formal, Loc)); |
bd7f7a65 | 9519 | begin |
30ebb114 AC |
9520 | Set_Expression (Any_Decl, |
9521 | Build_To_Any_Call (Loc, Expr, Decls)); | |
bd7f7a65 | 9522 | end; |
1735e55d | 9523 | |
bd7f7a65 | 9524 | elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then |
25e9b6fe | 9525 | |
1fb63e89 | 9526 | -- Untagged record type |
25e9b6fe | 9527 | |
bd7f7a65 AC |
9528 | if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then |
9529 | declare | |
25e9b6fe TQ |
9530 | Rt_Type : constant Entity_Id := Etype (Typ); |
9531 | Expr : constant Node_Id := | |
9532 | OK_Convert_To (Rt_Type, | |
8b64ed4c | 9533 | New_Occurrence_Of (Expr_Formal, Loc)); |
bd7f7a65 AC |
9534 | |
9535 | begin | |
d693e39d | 9536 | Set_Expression |
30ebb114 | 9537 | (Any_Decl, Build_To_Any_Call (Loc, Expr, Decls)); |
bd7f7a65 AC |
9538 | end; |
9539 | ||
25e9b6fe TQ |
9540 | -- Comment needed here (and label on declare block ???) |
9541 | ||
bd7f7a65 AC |
9542 | else |
9543 | declare | |
25e9b6fe TQ |
9544 | Disc : Entity_Id := Empty; |
9545 | Rdef : constant Node_Id := | |
9546 | Type_Definition (Declaration_Node (Typ)); | |
02248717 | 9547 | Counter : Nat := 0; |
bd7f7a65 AC |
9548 | Elements : constant List_Id := New_List; |
9549 | ||
9550 | procedure TA_Rec_Add_Process_Element | |
9551 | (Stmts : List_Id; | |
9552 | Container : Node_Or_Entity_Id; | |
02248717 | 9553 | Counter : in out Nat; |
bd7f7a65 AC |
9554 | Rec : Entity_Id; |
9555 | Field : Node_Id); | |
25e9b6fe | 9556 | -- Processing routine for traversal below |
bd7f7a65 AC |
9557 | |
9558 | procedure TA_Append_Record_Traversal is | |
9559 | new Append_Record_Traversal | |
8b64ed4c | 9560 | (Rec => Expr_Formal, |
bd7f7a65 AC |
9561 | Add_Process_Element => TA_Rec_Add_Process_Element); |
9562 | ||
9563 | -------------------------------- | |
9564 | -- TA_Rec_Add_Process_Element -- | |
9565 | -------------------------------- | |
9566 | ||
9567 | procedure TA_Rec_Add_Process_Element | |
9568 | (Stmts : List_Id; | |
9569 | Container : Node_Or_Entity_Id; | |
02248717 | 9570 | Counter : in out Nat; |
bd7f7a65 AC |
9571 | Rec : Entity_Id; |
9572 | Field : Node_Id) | |
9573 | is | |
9574 | Field_Ref : Node_Id; | |
9575 | ||
9576 | begin | |
9577 | if Nkind (Field) = N_Defining_Identifier then | |
9578 | ||
9579 | -- A regular component | |
9580 | ||
9581 | Field_Ref := Make_Selected_Component (Loc, | |
16db96c5 | 9582 | Prefix => New_Occurrence_Of (Rec, Loc), |
bd7f7a65 AC |
9583 | Selector_Name => New_Occurrence_Of (Field, Loc)); |
9584 | Set_Etype (Field_Ref, Etype (Field)); | |
9585 | ||
9586 | Append_To (Stmts, | |
9587 | Make_Procedure_Call_Statement (Loc, | |
9588 | Name => | |
9589 | New_Occurrence_Of ( | |
9590 | RTE (RE_Add_Aggregate_Element), Loc), | |
9591 | Parameter_Associations => New_List ( | |
8aa23fe3 | 9592 | New_Occurrence_Of (Container, Loc), |
30ebb114 | 9593 | Build_To_Any_Call (Loc, Field_Ref, Decls)))); |
bd7f7a65 AC |
9594 | |
9595 | else | |
9596 | -- A variant part | |
9597 | ||
25e9b6fe TQ |
9598 | Variant_Part : declare |
9599 | Variant : Node_Id; | |
02248717 | 9600 | Struct_Counter : Nat := 0; |
bd7f7a65 AC |
9601 | |
9602 | Block_Decls : constant List_Id := New_List; | |
9603 | Block_Stmts : constant List_Id := New_List; | |
9604 | VP_Stmts : List_Id; | |
9605 | ||
25e9b6fe | 9606 | Alt_List : constant List_Id := New_List; |
bd7f7a65 AC |
9607 | Choice_List : List_Id; |
9608 | ||
9609 | Union_Any : constant Entity_Id := | |
2287a75d | 9610 | Make_Temporary (Loc, 'V'); |
bd7f7a65 AC |
9611 | |
9612 | Struct_Any : constant Entity_Id := | |
2287a75d | 9613 | Make_Temporary (Loc, 'S'); |
bd7f7a65 AC |
9614 | |
9615 | function Make_Discriminant_Reference | |
9616 | return Node_Id; | |
25e9b6fe TQ |
9617 | -- Build reference to the discriminant for this |
9618 | -- variant part. | |
bd7f7a65 AC |
9619 | |
9620 | --------------------------------- | |
9621 | -- Make_Discriminant_Reference -- | |
9622 | --------------------------------- | |
9623 | ||
9624 | function Make_Discriminant_Reference | |
9625 | return Node_Id | |
9626 | is | |
9627 | Nod : constant Node_Id := | |
9628 | Make_Selected_Component (Loc, | |
16db96c5 | 9629 | Prefix => Rec, |
bd7f7a65 | 9630 | Selector_Name => |
16db96c5 | 9631 | Chars (Name (Field))); |
bd7f7a65 | 9632 | begin |
8aa23fe3 | 9633 | Set_Etype (Nod, Etype (Name (Field))); |
bd7f7a65 AC |
9634 | return Nod; |
9635 | end Make_Discriminant_Reference; | |
9636 | ||
d8221f45 | 9637 | -- Start of processing for Variant_Part |
25e9b6fe | 9638 | |
bd7f7a65 AC |
9639 | begin |
9640 | Append_To (Stmts, | |
9641 | Make_Block_Statement (Loc, | |
9642 | Declarations => | |
9643 | Block_Decls, | |
9644 | Handled_Statement_Sequence => | |
9645 | Make_Handled_Sequence_Of_Statements (Loc, | |
9646 | Statements => Block_Stmts))); | |
9647 | ||
25e9b6fe TQ |
9648 | -- Declare variant part aggregate (Union_Any). |
9649 | -- Knowing the position of this VP in the | |
9650 | -- variant record, we can fetch the VP typecode | |
9651 | -- from Container. | |
8aa23fe3 | 9652 | |
bd7f7a65 AC |
9653 | Append_To (Block_Decls, |
9654 | Make_Object_Declaration (Loc, | |
9655 | Defining_Identifier => Union_Any, | |
9656 | Object_Definition => | |
9657 | New_Occurrence_Of (RTE (RE_Any), Loc), | |
9658 | Expression => | |
9659 | Make_Function_Call (Loc, | |
9660 | Name => New_Occurrence_Of ( | |
9661 | RTE (RE_Create_Any), Loc), | |
9662 | Parameter_Associations => New_List ( | |
9663 | Make_Function_Call (Loc, | |
9664 | Name => | |
9665 | New_Occurrence_Of ( | |
9666 | RTE (RE_Any_Member_Type), Loc), | |
9667 | Parameter_Associations => New_List ( | |
9668 | New_Occurrence_Of (Container, Loc), | |
9669 | Make_Integer_Literal (Loc, | |
9670 | Counter))))))); | |
9671 | ||
25e9b6fe TQ |
9672 | -- Declare inner struct aggregate (which |
9673 | -- contains the components of this VP). | |
8aa23fe3 | 9674 | |
bd7f7a65 AC |
9675 | Append_To (Block_Decls, |
9676 | Make_Object_Declaration (Loc, | |
9677 | Defining_Identifier => Struct_Any, | |
9678 | Object_Definition => | |
9679 | New_Occurrence_Of (RTE (RE_Any), Loc), | |
9680 | Expression => | |
9681 | Make_Function_Call (Loc, | |
9682 | Name => New_Occurrence_Of ( | |
9683 | RTE (RE_Create_Any), Loc), | |
9684 | Parameter_Associations => New_List ( | |
9685 | Make_Function_Call (Loc, | |
9686 | Name => | |
9687 | New_Occurrence_Of ( | |
9688 | RTE (RE_Any_Member_Type), Loc), | |
9689 | Parameter_Associations => New_List ( | |
9690 | New_Occurrence_Of (Union_Any, Loc), | |
9691 | Make_Integer_Literal (Loc, | |
8aa23fe3 TQ |
9692 | Uint_1))))))); |
9693 | ||
25e9b6fe | 9694 | -- Build case statement |
bd7f7a65 AC |
9695 | |
9696 | Append_To (Block_Stmts, | |
9697 | Make_Case_Statement (Loc, | |
d693e39d TQ |
9698 | Expression => Make_Discriminant_Reference, |
9699 | Alternatives => Alt_List)); | |
bd7f7a65 AC |
9700 | |
9701 | Variant := First_Non_Pragma (Variants (Field)); | |
9702 | while Present (Variant) loop | |
9703 | Choice_List := New_Copy_List_Tree | |
9704 | (Discrete_Choices (Variant)); | |
9705 | ||
9706 | VP_Stmts := New_List; | |
bd7f7a65 | 9707 | |
25e9b6fe | 9708 | -- Append discriminant val to union aggregate |
bd7f7a65 AC |
9709 | |
9710 | Append_To (VP_Stmts, | |
9711 | Make_Procedure_Call_Statement (Loc, | |
9712 | Name => | |
9713 | New_Occurrence_Of ( | |
9714 | RTE (RE_Add_Aggregate_Element), Loc), | |
9715 | Parameter_Associations => New_List ( | |
9716 | New_Occurrence_Of (Union_Any, Loc), | |
d693e39d | 9717 | Build_To_Any_Call |
30ebb114 AC |
9718 | (Loc, |
9719 | Make_Discriminant_Reference, | |
d693e39d | 9720 | Block_Decls)))); |
bd7f7a65 | 9721 | |
8aa23fe3 TQ |
9722 | -- Populate inner struct aggregate |
9723 | ||
9724 | -- Struct_Counter should be reset before | |
9725 | -- handling a variant part. Indeed only one | |
9726 | -- of the case statement alternatives will be | |
e7c0dd39 | 9727 | -- executed at run time, so the counter must |
8aa23fe3 TQ |
9728 | -- start at 0 for every case statement. |
9729 | ||
9730 | Struct_Counter := 0; | |
9731 | ||
c6f39437 AC |
9732 | TA_Append_Record_Traversal |
9733 | (Stmts => VP_Stmts, | |
9734 | Clist => Component_List (Variant), | |
9735 | Container => Struct_Any, | |
9736 | Counter => Struct_Counter); | |
8aa23fe3 TQ |
9737 | |
9738 | -- Append inner struct to union aggregate | |
9739 | ||
bd7f7a65 AC |
9740 | Append_To (VP_Stmts, |
9741 | Make_Procedure_Call_Statement (Loc, | |
9742 | Name => | |
c6f39437 AC |
9743 | New_Occurrence_Of |
9744 | (RTE (RE_Add_Aggregate_Element), Loc), | |
bd7f7a65 AC |
9745 | Parameter_Associations => New_List ( |
9746 | New_Occurrence_Of (Union_Any, Loc), | |
9747 | New_Occurrence_Of (Struct_Any, Loc)))); | |
9748 | ||
9749 | -- Append union to outer aggregate | |
9750 | ||
9751 | Append_To (VP_Stmts, | |
9752 | Make_Procedure_Call_Statement (Loc, | |
9753 | Name => | |
c6f39437 AC |
9754 | New_Occurrence_Of |
9755 | (RTE (RE_Add_Aggregate_Element), Loc), | |
8aa23fe3 TQ |
9756 | Parameter_Associations => New_List ( |
9757 | New_Occurrence_Of (Container, Loc), | |
9758 | New_Occurrence_Of | |
9759 | (Union_Any, Loc)))); | |
bd7f7a65 AC |
9760 | |
9761 | Append_To (Alt_List, | |
9762 | Make_Case_Statement_Alternative (Loc, | |
9763 | Discrete_Choices => Choice_List, | |
d693e39d | 9764 | Statements => VP_Stmts)); |
8aa23fe3 | 9765 | |
bd7f7a65 AC |
9766 | Next_Non_Pragma (Variant); |
9767 | end loop; | |
25e9b6fe | 9768 | end Variant_Part; |
bd7f7a65 | 9769 | end if; |
25e9b6fe | 9770 | |
8aa23fe3 | 9771 | Counter := Counter + 1; |
bd7f7a65 AC |
9772 | end TA_Rec_Add_Process_Element; |
9773 | ||
9774 | begin | |
8aa23fe3 | 9775 | -- Records are encoded in a TC_STRUCT aggregate: |
2cd6f54e | 9776 | |
8aa23fe3 TQ |
9777 | -- -- Outer aggregate (TC_STRUCT) |
9778 | -- | [discriminant1] | |
9779 | -- | [discriminant2] | |
9780 | -- | ... | |
2cd6f54e | 9781 | -- | |
8aa23fe3 TQ |
9782 | -- | [component1] |
9783 | -- | [component2] | |
9784 | -- | ... | |
2cd6f54e TQ |
9785 | |
9786 | -- A component can be a common component or variant part | |
9787 | ||
8aa23fe3 | 9788 | -- A variant part is encoded as a TC_UNION aggregate: |
2cd6f54e | 9789 | |
8aa23fe3 TQ |
9790 | -- -- Variant Part Aggregate (TC_UNION) |
9791 | -- | [discriminant choice for this Variant Part] | |
9792 | -- | | |
9793 | -- | -- Inner struct (TC_STRUCT) | |
9794 | -- | | [component1] | |
9795 | -- | | [component2] | |
9796 | -- | | ... | |
9797 | ||
2cd6f54e TQ |
9798 | -- Let's start by building the outer aggregate. First we |
9799 | -- construct Elements array containing all discriminants. | |
bd7f7a65 AC |
9800 | |
9801 | if Has_Discriminants (Typ) then | |
9802 | Disc := First_Discriminant (Typ); | |
bd7f7a65 | 9803 | while Present (Disc) loop |
8aa23fe3 TQ |
9804 | declare |
9805 | Discriminant : constant Entity_Id := | |
5073ad7a AC |
9806 | Make_Selected_Component (Loc, |
9807 | Prefix => Expr_Formal, | |
9808 | Selector_Name => Chars (Disc)); | |
8aa23fe3 TQ |
9809 | begin |
9810 | Set_Etype (Discriminant, Etype (Disc)); | |
8aa23fe3 TQ |
9811 | Append_To (Elements, |
9812 | Make_Component_Association (Loc, | |
9813 | Choices => New_List ( | |
9814 | Make_Integer_Literal (Loc, Counter)), | |
9815 | Expression => | |
30ebb114 AC |
9816 | Build_To_Any_Call (Loc, |
9817 | Discriminant, Decls))); | |
8aa23fe3 | 9818 | end; |
2cd6f54e | 9819 | |
bd7f7a65 AC |
9820 | Counter := Counter + 1; |
9821 | Next_Discriminant (Disc); | |
9822 | end loop; | |
9823 | ||
9824 | else | |
8aa23fe3 TQ |
9825 | -- If there are no discriminants, we declare an empty |
9826 | -- Elements array. | |
bd7f7a65 AC |
9827 | |
9828 | declare | |
9829 | Dummy_Any : constant Entity_Id := | |
2287a75d | 9830 | Make_Temporary (Loc, 'A'); |
bd7f7a65 AC |
9831 | |
9832 | begin | |
9833 | Append_To (Decls, | |
9834 | Make_Object_Declaration (Loc, | |
9835 | Defining_Identifier => Dummy_Any, | |
9836 | Object_Definition => | |
9837 | New_Occurrence_Of (RTE (RE_Any), Loc))); | |
9838 | ||
9839 | Append_To (Elements, | |
9840 | Make_Component_Association (Loc, | |
9841 | Choices => New_List ( | |
9842 | Make_Range (Loc, | |
9843 | Low_Bound => | |
9844 | Make_Integer_Literal (Loc, 1), | |
9845 | High_Bound => | |
9846 | Make_Integer_Literal (Loc, 0))), | |
9847 | Expression => | |
9848 | New_Occurrence_Of (Dummy_Any, Loc))); | |
9849 | end; | |
9850 | end if; | |
9851 | ||
8aa23fe3 TQ |
9852 | -- We build the result aggregate with discriminants |
9853 | -- as the first elements. | |
9854 | ||
bd7f7a65 AC |
9855 | Set_Expression (Any_Decl, |
9856 | Make_Function_Call (Loc, | |
c6f39437 AC |
9857 | Name => New_Occurrence_Of |
9858 | (RTE (RE_Any_Aggregate_Build), Loc), | |
bd7f7a65 AC |
9859 | Parameter_Associations => New_List ( |
9860 | Result_TC, | |
9861 | Make_Aggregate (Loc, | |
9862 | Component_Associations => Elements)))); | |
9863 | Result_TC := Empty; | |
9864 | ||
8aa23fe3 TQ |
9865 | -- Then we append all the components to the result |
9866 | -- aggregate. | |
bd7f7a65 AC |
9867 | |
9868 | TA_Append_Record_Traversal (Stms, | |
9869 | Clist => Component_List (Rdef), | |
9870 | Container => Any, | |
9871 | Counter => Counter); | |
9872 | end; | |
9873 | end if; | |
70482933 | 9874 | |
bd7f7a65 | 9875 | elsif Is_Array_Type (Typ) then |
25e9b6fe TQ |
9876 | |
9877 | -- Constrained and unconstrained array types | |
9878 | ||
bd7f7a65 | 9879 | declare |
a9895094 | 9880 | Constrained : constant Boolean := |
1f0b1e48 | 9881 | not Transmit_As_Unconstrained (Typ); |
bd7f7a65 AC |
9882 | |
9883 | procedure TA_Ary_Add_Process_Element | |
9884 | (Stmts : List_Id; | |
9885 | Any : Entity_Id; | |
9886 | Counter : Entity_Id; | |
9887 | Datum : Node_Id); | |
9888 | ||
9889 | -------------------------------- | |
9890 | -- TA_Ary_Add_Process_Element -- | |
9891 | -------------------------------- | |
9892 | ||
9893 | procedure TA_Ary_Add_Process_Element | |
9894 | (Stmts : List_Id; | |
9895 | Any : Entity_Id; | |
9896 | Counter : Entity_Id; | |
9897 | Datum : Node_Id) | |
9898 | is | |
bd7f7a65 | 9899 | pragma Unreferenced (Counter); |
bd7f7a65 AC |
9900 | |
9901 | Element_Any : Node_Id; | |
9902 | ||
9903 | begin | |
9904 | if Etype (Datum) = RTE (RE_Any) then | |
9905 | Element_Any := Datum; | |
9906 | else | |
30ebb114 | 9907 | Element_Any := Build_To_Any_Call (Loc, Datum, Decls); |
bd7f7a65 AC |
9908 | end if; |
9909 | ||
9910 | Append_To (Stmts, | |
9911 | Make_Procedure_Call_Statement (Loc, | |
9912 | Name => New_Occurrence_Of ( | |
9913 | RTE (RE_Add_Aggregate_Element), Loc), | |
9914 | Parameter_Associations => New_List ( | |
9915 | New_Occurrence_Of (Any, Loc), | |
9916 | Element_Any))); | |
9917 | end TA_Ary_Add_Process_Element; | |
9918 | ||
9919 | procedure Append_To_Any_Array_Iterator is | |
9920 | new Append_Array_Traversal ( | |
9921 | Subprogram => Fnam, | |
8b64ed4c | 9922 | Arry => Expr_Formal, |
3b42c566 | 9923 | Indexes => New_List, |
bd7f7a65 AC |
9924 | Add_Process_Element => TA_Ary_Add_Process_Element); |
9925 | ||
9926 | Index : Node_Id; | |
70482933 | 9927 | |
bd7f7a65 AC |
9928 | begin |
9929 | Set_Expression (Any_Decl, | |
9930 | Make_Function_Call (Loc, | |
1f0b1e48 | 9931 | Name => |
bd7f7a65 AC |
9932 | New_Occurrence_Of (RTE (RE_Create_Any), Loc), |
9933 | Parameter_Associations => New_List (Result_TC))); | |
9934 | Result_TC := Empty; | |
9935 | ||
9936 | if not Constrained then | |
9937 | Index := First_Index (Typ); | |
9938 | for J in 1 .. Number_Dimensions (Typ) loop | |
9939 | Append_To (Stms, | |
9940 | Make_Procedure_Call_Statement (Loc, | |
1f0b1e48 RD |
9941 | Name => |
9942 | New_Occurrence_Of | |
9943 | (RTE (RE_Add_Aggregate_Element), Loc), | |
bd7f7a65 AC |
9944 | Parameter_Associations => New_List ( |
9945 | New_Occurrence_Of (Any, Loc), | |
30ebb114 | 9946 | Build_To_Any_Call (Loc, |
bd7f7a65 AC |
9947 | OK_Convert_To (Etype (Index), |
9948 | Make_Attribute_Reference (Loc, | |
9949 | Prefix => | |
8b64ed4c | 9950 | New_Occurrence_Of (Expr_Formal, Loc), |
bd7f7a65 AC |
9951 | Attribute_Name => Name_First, |
9952 | Expressions => New_List ( | |
9953 | Make_Integer_Literal (Loc, J)))), | |
9954 | Decls)))); | |
9955 | Next_Index (Index); | |
9956 | end loop; | |
9957 | end if; | |
70482933 | 9958 | |
bd7f7a65 AC |
9959 | Append_To_Any_Array_Iterator (Stms, Any); |
9960 | end; | |
70482933 | 9961 | |
bd7f7a65 | 9962 | elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then |
25e9b6fe TQ |
9963 | |
9964 | -- Integer types | |
9965 | ||
bd7f7a65 | 9966 | Set_Expression (Any_Decl, |
30ebb114 | 9967 | Build_To_Any_Call (Loc, |
bd7f7a65 AC |
9968 | OK_Convert_To ( |
9969 | Find_Numeric_Representation (Typ), | |
8b64ed4c | 9970 | New_Occurrence_Of (Expr_Formal, Loc)), |
bd7f7a65 | 9971 | Decls)); |
70482933 | 9972 | |
bd7f7a65 | 9973 | else |
25e9b6fe TQ |
9974 | -- Default case, including tagged types: opaque representation |
9975 | ||
9976 | Use_Opaque_Representation := True; | |
9977 | end if; | |
70482933 | 9978 | |
25e9b6fe | 9979 | if Use_Opaque_Representation then |
bd7f7a65 | 9980 | declare |
2287a75d | 9981 | Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); |
25e9b6fe TQ |
9982 | -- Stream used to store data representation produced by |
9983 | -- stream attribute. | |
70482933 | 9984 | |
bd7f7a65 | 9985 | begin |
25e9b6fe TQ |
9986 | -- Generate: |
9987 | -- Strm : aliased Buffer_Stream_Type; | |
70482933 | 9988 | |
bd7f7a65 AC |
9989 | Append_To (Decls, |
9990 | Make_Object_Declaration (Loc, | |
1f0b1e48 RD |
9991 | Defining_Identifier => Strm, |
9992 | Aliased_Present => True, | |
bd7f7a65 AC |
9993 | Object_Definition => |
9994 | New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); | |
70482933 | 9995 | |
25e9b6fe TQ |
9996 | -- Generate: |
9997 | -- T'Output (Strm'Access, E); | |
a9895094 AC |
9998 | -- or |
9999 | -- T'Write (Strm'Access, E); | |
8b64ed4c TQ |
10000 | -- depending on whether to transmit as unconstrained. |
10001 | ||
10002 | -- For limited types, select at run time depending on | |
10003 | -- Constrained parameter. | |
70482933 | 10004 | |
a9895094 | 10005 | declare |
8b64ed4c TQ |
10006 | function Stream_Call (Attr : Name_Id) return Node_Id; |
10007 | -- Return a call to the named attribute | |
10008 | ||
10009 | ----------------- | |
10010 | -- Stream_Call -- | |
10011 | ----------------- | |
10012 | ||
10013 | function Stream_Call (Attr : Name_Id) return Node_Id is | |
10014 | begin | |
10015 | return Make_Attribute_Reference (Loc, | |
10016 | Prefix => | |
10017 | New_Occurrence_Of (Typ, Loc), | |
10018 | Attribute_Name => Attr, | |
10019 | Expressions => New_List ( | |
10020 | Make_Attribute_Reference (Loc, | |
10021 | Prefix => | |
10022 | New_Occurrence_Of (Strm, Loc), | |
10023 | Attribute_Name => Name_Access), | |
10024 | New_Occurrence_Of (Expr_Formal, Loc))); | |
10025 | ||
10026 | end Stream_Call; | |
1f0b1e48 | 10027 | |
a9895094 | 10028 | begin |
8b64ed4c TQ |
10029 | if Is_Limited_Type (Typ) then |
10030 | Append_To (Stms, | |
10031 | Make_Implicit_If_Statement (Typ, | |
5073ad7a AC |
10032 | Condition => |
10033 | New_Occurrence_Of (Cstr_Formal, Loc), | |
8b64ed4c TQ |
10034 | Then_Statements => New_List ( |
10035 | Stream_Call (Name_Write)), | |
10036 | Else_Statements => New_List ( | |
10037 | Stream_Call (Name_Output)))); | |
10038 | ||
10039 | elsif Transmit_As_Unconstrained (Typ) then | |
10040 | Append_To (Stms, Stream_Call (Name_Output)); | |
5073ad7a | 10041 | |
a9895094 | 10042 | else |
8b64ed4c | 10043 | Append_To (Stms, Stream_Call (Name_Write)); |
a9895094 | 10044 | end if; |
a9895094 | 10045 | end; |
bd7f7a65 | 10046 | |
25e9b6fe TQ |
10047 | -- Generate: |
10048 | -- BS_To_Any (Strm, A); | |
bd7f7a65 AC |
10049 | |
10050 | Append_To (Stms, | |
10051 | Make_Procedure_Call_Statement (Loc, | |
5073ad7a AC |
10052 | Name => |
10053 | New_Occurrence_Of (RTE (RE_BS_To_Any), Loc), | |
bd7f7a65 AC |
10054 | Parameter_Associations => New_List ( |
10055 | New_Occurrence_Of (Strm, Loc), | |
10056 | New_Occurrence_Of (Any, Loc)))); | |
10057 | ||
25e9b6fe TQ |
10058 | -- Generate: |
10059 | -- Release_Buffer (Strm); | |
bd7f7a65 AC |
10060 | |
10061 | Append_To (Stms, | |
10062 | Make_Procedure_Call_Statement (Loc, | |
5073ad7a AC |
10063 | Name => |
10064 | New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), | |
bd7f7a65 AC |
10065 | Parameter_Associations => New_List ( |
10066 | New_Occurrence_Of (Strm, Loc)))); | |
10067 | end; | |
10068 | end if; | |
70482933 | 10069 | |
bd7f7a65 | 10070 | Append_To (Decls, Any_Decl); |
70482933 | 10071 | |
bd7f7a65 AC |
10072 | if Present (Result_TC) then |
10073 | Append_To (Stms, | |
10074 | Make_Procedure_Call_Statement (Loc, | |
5073ad7a AC |
10075 | Name => |
10076 | New_Occurrence_Of (RTE (RE_Set_TC), Loc), | |
bd7f7a65 AC |
10077 | Parameter_Associations => New_List ( |
10078 | New_Occurrence_Of (Any, Loc), | |
10079 | Result_TC))); | |
10080 | end if; | |
70482933 | 10081 | |
bd7f7a65 | 10082 | Append_To (Stms, |
bfc2cdb1 | 10083 | Make_Simple_Return_Statement (Loc, |
bd7f7a65 AC |
10084 | Expression => New_Occurrence_Of (Any, Loc))); |
10085 | ||
10086 | Decl := | |
10087 | Make_Subprogram_Body (Loc, | |
d693e39d TQ |
10088 | Specification => Spec, |
10089 | Declarations => Decls, | |
bd7f7a65 AC |
10090 | Handled_Statement_Sequence => |
10091 | Make_Handled_Sequence_Of_Statements (Loc, | |
10092 | Statements => Stms)); | |
10093 | end Build_To_Any_Function; | |
10094 | ||
10095 | ------------------------- | |
10096 | -- Build_TypeCode_Call -- | |
10097 | ------------------------- | |
10098 | ||
10099 | function Build_TypeCode_Call | |
10100 | (Loc : Source_Ptr; | |
10101 | Typ : Entity_Id; | |
10102 | Decls : List_Id) return Node_Id | |
10103 | is | |
25e9b6fe | 10104 | U_Type : Entity_Id := Underlying_Type (Typ); |
bd7f7a65 AC |
10105 | -- The full view, if Typ is private; the completion, |
10106 | -- if Typ is incomplete. | |
70482933 | 10107 | |
044e51e0 | 10108 | Fnam : Entity_Id; |
25e9b6fe TQ |
10109 | Lib_RE : RE_Id := RE_Null; |
10110 | Expr : Node_Id; | |
70482933 | 10111 | |
bd7f7a65 AC |
10112 | begin |
10113 | -- Special case System.PolyORB.Interface.Any: its primitives have | |
10114 | -- not been set yet, so can't call Find_Inherited_TSS. | |
1735e55d | 10115 | |
bd7f7a65 | 10116 | if Typ = RTE (RE_Any) then |
54838d1f | 10117 | Fnam := RTE (RE_TC_A); |
1735e55d | 10118 | |
bd7f7a65 AC |
10119 | else |
10120 | -- First simple case where the TypeCode is present | |
10121 | -- in the type's TSS. | |
1735e55d | 10122 | |
a9d8907c | 10123 | Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode); |
bd7f7a65 | 10124 | end if; |
70482933 | 10125 | |
f4b049db AC |
10126 | -- For the subtype representing a generic actual type, go to the |
10127 | -- actual type. | |
fbf5a39b | 10128 | |
1f5c7ba8 | 10129 | if Is_Generic_Actual_Subtype (U_Type) then |
f4b049db AC |
10130 | U_Type := Underlying_Type (Base_Type (U_Type)); |
10131 | end if; | |
70482933 | 10132 | |
f4b049db | 10133 | -- For a standard subtype, go to the base type |
fbf5a39b | 10134 | |
f4b049db AC |
10135 | if Sloc (U_Type) <= Standard_Location then |
10136 | U_Type := Base_Type (U_Type); | |
baad9830 TQ |
10137 | |
10138 | -- For a user subtype, go to first subtype | |
10139 | ||
10140 | elsif Comes_From_Source (U_Type) | |
10141 | and then Nkind (Declaration_Node (U_Type)) | |
10142 | = N_Subtype_Declaration | |
10143 | then | |
10144 | U_Type := First_Subtype (U_Type); | |
f4b049db AC |
10145 | end if; |
10146 | ||
10147 | if No (Fnam) then | |
bd7f7a65 AC |
10148 | if U_Type = Standard_Boolean then |
10149 | Lib_RE := RE_TC_B; | |
70482933 | 10150 | |
bd7f7a65 AC |
10151 | elsif U_Type = Standard_Character then |
10152 | Lib_RE := RE_TC_C; | |
70482933 | 10153 | |
bd7f7a65 AC |
10154 | elsif U_Type = Standard_Wide_Character then |
10155 | Lib_RE := RE_TC_WC; | |
70482933 | 10156 | |
82c80734 RD |
10157 | elsif U_Type = Standard_Wide_Wide_Character then |
10158 | Lib_RE := RE_TC_WWC; | |
10159 | ||
bd7f7a65 | 10160 | -- Floating point types |
70482933 | 10161 | |
bd7f7a65 AC |
10162 | elsif U_Type = Standard_Short_Float then |
10163 | Lib_RE := RE_TC_SF; | |
c885d7a1 | 10164 | |
bd7f7a65 AC |
10165 | elsif U_Type = Standard_Float then |
10166 | Lib_RE := RE_TC_F; | |
1735e55d | 10167 | |
bd7f7a65 AC |
10168 | elsif U_Type = Standard_Long_Float then |
10169 | Lib_RE := RE_TC_LF; | |
1735e55d | 10170 | |
bd7f7a65 AC |
10171 | elsif U_Type = Standard_Long_Long_Float then |
10172 | Lib_RE := RE_TC_LLF; | |
1735e55d | 10173 | |
bd7f7a65 | 10174 | -- Integer types (walk back to the base type) |
1735e55d | 10175 | |
686d0984 | 10176 | elsif U_Type = RTE (RE_Integer_8) then |
0f4be535 | 10177 | Lib_RE := RE_TC_I8; |
1735e55d | 10178 | |
686d0984 AC |
10179 | elsif U_Type = RTE (RE_Integer_16) then |
10180 | Lib_RE := RE_TC_I16; | |
70482933 | 10181 | |
686d0984 AC |
10182 | elsif U_Type = RTE (RE_Integer_32) then |
10183 | Lib_RE := RE_TC_I32; | |
70482933 | 10184 | |
686d0984 AC |
10185 | elsif U_Type = RTE (RE_Integer_64) then |
10186 | Lib_RE := RE_TC_I64; | |
70482933 | 10187 | |
bd7f7a65 | 10188 | -- Unsigned integer types |
70482933 | 10189 | |
686d0984 AC |
10190 | elsif U_Type = RTE (RE_Unsigned_8) then |
10191 | Lib_RE := RE_TC_U8; | |
70482933 | 10192 | |
686d0984 AC |
10193 | elsif U_Type = RTE (RE_Unsigned_16) then |
10194 | Lib_RE := RE_TC_U16; | |
70482933 | 10195 | |
686d0984 AC |
10196 | elsif U_Type = RTE (RE_Unsigned_32) then |
10197 | Lib_RE := RE_TC_U32; | |
70482933 | 10198 | |
686d0984 AC |
10199 | elsif U_Type = RTE (RE_Unsigned_64) then |
10200 | Lib_RE := RE_TC_U64; | |
70482933 | 10201 | |
6bde3eb5 | 10202 | elsif Is_RTE (U_Type, RE_Unbounded_String) then |
bd7f7a65 | 10203 | Lib_RE := RE_TC_String; |
70482933 | 10204 | |
54838d1f AC |
10205 | -- Special DSA types |
10206 | ||
0999b547 | 10207 | elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then |
54838d1f AC |
10208 | Lib_RE := RE_TC_A; |
10209 | ||
bd7f7a65 AC |
10210 | -- Other (non-primitive) types |
10211 | ||
10212 | else | |
10213 | declare | |
10214 | Decl : Entity_Id; | |
10215 | begin | |
10216 | Build_TypeCode_Function (Loc, U_Type, Decl, Fnam); | |
10217 | Append_To (Decls, Decl); | |
10218 | end; | |
10219 | end if; | |
10220 | ||
10221 | if Lib_RE /= RE_Null then | |
10222 | Fnam := RTE (Lib_RE); | |
10223 | end if; | |
10224 | end if; | |
10225 | ||
10226 | -- Call the function | |
70482933 | 10227 | |
bd7f7a65 | 10228 | Expr := |
3eb8fddc | 10229 | Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc)); |
70482933 | 10230 | |
bd7f7a65 | 10231 | -- Allow Expr to be used as arg to Build_To_Any_Call immediately |
70482933 | 10232 | |
bd7f7a65 | 10233 | Set_Etype (Expr, RTE (RE_TypeCode)); |
70482933 | 10234 | |
bd7f7a65 AC |
10235 | return Expr; |
10236 | end Build_TypeCode_Call; | |
70482933 | 10237 | |
bd7f7a65 AC |
10238 | ----------------------------- |
10239 | -- Build_TypeCode_Function -- | |
10240 | ----------------------------- | |
1735e55d | 10241 | |
bd7f7a65 AC |
10242 | procedure Build_TypeCode_Function |
10243 | (Loc : Source_Ptr; | |
10244 | Typ : Entity_Id; | |
10245 | Decl : out Node_Id; | |
10246 | Fnam : out Entity_Id) | |
10247 | is | |
10248 | Spec : Node_Id; | |
10249 | Decls : constant List_Id := New_List; | |
10250 | Stms : constant List_Id := New_List; | |
10251 | ||
10252 | TCNam : constant Entity_Id := | |
54838d1f | 10253 | Make_Helper_Function_Name (Loc, Typ, Name_TypeCode); |
bd7f7a65 AC |
10254 | |
10255 | Parameters : List_Id; | |
10256 | ||
10257 | procedure Add_String_Parameter | |
10258 | (S : String_Id; | |
10259 | Parameter_List : List_Id); | |
10260 | -- Add a literal for S to Parameters | |
10261 | ||
10262 | procedure Add_TypeCode_Parameter | |
10263 | (TC_Node : Node_Id; | |
10264 | Parameter_List : List_Id); | |
10265 | -- Add the typecode for Typ to Parameters | |
10266 | ||
10267 | procedure Add_Long_Parameter | |
10268 | (Expr_Node : Node_Id; | |
10269 | Parameter_List : List_Id); | |
10270 | -- Add a signed long integer expression to Parameters | |
10271 | ||
10272 | procedure Initialize_Parameter_List | |
10273 | (Name_String : String_Id; | |
10274 | Repo_Id_String : String_Id; | |
10275 | Parameter_List : out List_Id); | |
10276 | -- Return a list that contains the first two parameters | |
10277 | -- for a parameterized typecode: name and repository id. | |
10278 | ||
10279 | function Make_Constructed_TypeCode | |
10280 | (Kind : Entity_Id; | |
10281 | Parameters : List_Id) return Node_Id; | |
5b75bf57 | 10282 | -- Call Build_Complex_TC with the given kind and parameters |
bd7f7a65 AC |
10283 | |
10284 | procedure Return_Constructed_TypeCode (Kind : Entity_Id); | |
5b75bf57 AC |
10285 | -- Make a return statement that calls Build_Complex_TC with the |
10286 | -- given typecode kind, and the constructed parameters list. | |
bd7f7a65 | 10287 | |
0f4be535 | 10288 | procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id); |
bd7f7a65 AC |
10289 | -- Return a typecode that is a TC_Alias for the given typecode |
10290 | ||
10291 | -------------------------- | |
10292 | -- Add_String_Parameter -- | |
10293 | -------------------------- | |
10294 | ||
10295 | procedure Add_String_Parameter | |
10296 | (S : String_Id; | |
10297 | Parameter_List : List_Id) | |
10298 | is | |
10299 | begin | |
10300 | Append_To (Parameter_List, | |
10301 | Make_Function_Call (Loc, | |
6bde3eb5 | 10302 | Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc), |
bd7f7a65 AC |
10303 | Parameter_Associations => New_List ( |
10304 | Make_String_Literal (Loc, S)))); | |
10305 | end Add_String_Parameter; | |
10306 | ||
10307 | ---------------------------- | |
10308 | -- Add_TypeCode_Parameter -- | |
10309 | ---------------------------- | |
10310 | ||
10311 | procedure Add_TypeCode_Parameter | |
10312 | (TC_Node : Node_Id; | |
10313 | Parameter_List : List_Id) | |
10314 | is | |
10315 | begin | |
10316 | Append_To (Parameter_List, | |
10317 | Make_Function_Call (Loc, | |
d693e39d TQ |
10318 | Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc), |
10319 | Parameter_Associations => New_List (TC_Node))); | |
bd7f7a65 AC |
10320 | end Add_TypeCode_Parameter; |
10321 | ||
10322 | ------------------------ | |
10323 | -- Add_Long_Parameter -- | |
10324 | ------------------------ | |
10325 | ||
10326 | procedure Add_Long_Parameter | |
10327 | (Expr_Node : Node_Id; | |
10328 | Parameter_List : List_Id) | |
10329 | is | |
10330 | begin | |
10331 | Append_To (Parameter_List, | |
10332 | Make_Function_Call (Loc, | |
2c1b72d7 AC |
10333 | Name => |
10334 | New_Occurrence_Of (RTE (RE_TA_I32), Loc), | |
bd7f7a65 AC |
10335 | Parameter_Associations => New_List (Expr_Node))); |
10336 | end Add_Long_Parameter; | |
10337 | ||
10338 | ------------------------------- | |
10339 | -- Initialize_Parameter_List -- | |
10340 | ------------------------------- | |
10341 | ||
10342 | procedure Initialize_Parameter_List | |
10343 | (Name_String : String_Id; | |
10344 | Repo_Id_String : String_Id; | |
10345 | Parameter_List : out List_Id) | |
10346 | is | |
10347 | begin | |
10348 | Parameter_List := New_List; | |
10349 | Add_String_Parameter (Name_String, Parameter_List); | |
10350 | Add_String_Parameter (Repo_Id_String, Parameter_List); | |
10351 | end Initialize_Parameter_List; | |
10352 | ||
10353 | --------------------------- | |
10354 | -- Return_Alias_TypeCode -- | |
10355 | --------------------------- | |
10356 | ||
baad9830 | 10357 | procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id) is |
bd7f7a65 AC |
10358 | begin |
10359 | Add_TypeCode_Parameter (Base_TypeCode, Parameters); | |
5b75bf57 | 10360 | Return_Constructed_TypeCode (RTE (RE_Tk_Alias)); |
bd7f7a65 AC |
10361 | end Return_Alias_TypeCode; |
10362 | ||
10363 | ------------------------------- | |
10364 | -- Make_Constructed_TypeCode -- | |
10365 | ------------------------------- | |
10366 | ||
10367 | function Make_Constructed_TypeCode | |
10368 | (Kind : Entity_Id; | |
10369 | Parameters : List_Id) return Node_Id | |
10370 | is | |
10371 | Constructed_TC : constant Node_Id := | |
10372 | Make_Function_Call (Loc, | |
0088ba92 | 10373 | Name => |
5b75bf57 | 10374 | New_Occurrence_Of (RTE (RE_Build_Complex_TC), Loc), |
bd7f7a65 AC |
10375 | Parameter_Associations => New_List ( |
10376 | New_Occurrence_Of (Kind, Loc), | |
10377 | Make_Aggregate (Loc, | |
0088ba92 | 10378 | Expressions => Parameters))); |
bd7f7a65 AC |
10379 | begin |
10380 | Set_Etype (Constructed_TC, RTE (RE_TypeCode)); | |
10381 | return Constructed_TC; | |
10382 | end Make_Constructed_TypeCode; | |
1735e55d | 10383 | |
bd7f7a65 AC |
10384 | --------------------------------- |
10385 | -- Return_Constructed_TypeCode -- | |
10386 | --------------------------------- | |
1735e55d | 10387 | |
bd7f7a65 AC |
10388 | procedure Return_Constructed_TypeCode (Kind : Entity_Id) is |
10389 | begin | |
10390 | Append_To (Stms, | |
bfc2cdb1 | 10391 | Make_Simple_Return_Statement (Loc, |
bd7f7a65 | 10392 | Expression => |
d693e39d | 10393 | Make_Constructed_TypeCode (Kind, Parameters))); |
bd7f7a65 AC |
10394 | end Return_Constructed_TypeCode; |
10395 | ||
10396 | ------------------ | |
10397 | -- Record types -- | |
10398 | ------------------ | |
10399 | ||
10400 | procedure TC_Rec_Add_Process_Element | |
10401 | (Params : List_Id; | |
10402 | Any : Entity_Id; | |
02248717 | 10403 | Counter : in out Nat; |
bd7f7a65 AC |
10404 | Rec : Entity_Id; |
10405 | Field : Node_Id); | |
10406 | ||
10407 | procedure TC_Append_Record_Traversal is | |
10408 | new Append_Record_Traversal ( | |
10409 | Rec => Empty, | |
10410 | Add_Process_Element => TC_Rec_Add_Process_Element); | |
10411 | ||
10412 | -------------------------------- | |
10413 | -- TC_Rec_Add_Process_Element -- | |
10414 | -------------------------------- | |
10415 | ||
10416 | procedure TC_Rec_Add_Process_Element | |
10417 | (Params : List_Id; | |
10418 | Any : Entity_Id; | |
02248717 | 10419 | Counter : in out Nat; |
bd7f7a65 AC |
10420 | Rec : Entity_Id; |
10421 | Field : Node_Id) | |
10422 | is | |
bd7f7a65 | 10423 | pragma Unreferenced (Any, Counter, Rec); |
1735e55d | 10424 | |
bd7f7a65 AC |
10425 | begin |
10426 | if Nkind (Field) = N_Defining_Identifier then | |
1735e55d | 10427 | |
bd7f7a65 | 10428 | -- A regular component |
1735e55d | 10429 | |
d693e39d TQ |
10430 | Add_TypeCode_Parameter |
10431 | (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params); | |
bd7f7a65 AC |
10432 | Get_Name_String (Chars (Field)); |
10433 | Add_String_Parameter (String_From_Name_Buffer, Params); | |
1735e55d | 10434 | |
bd7f7a65 | 10435 | else |
1735e55d | 10436 | |
bd7f7a65 | 10437 | -- A variant part |
1735e55d | 10438 | |
1df4f514 | 10439 | Variant_Part : declare |
cb25faf8 | 10440 | Disc_Type : constant Entity_Id := Etype (Name (Field)); |
1735e55d | 10441 | |
bd7f7a65 | 10442 | Is_Enum : constant Boolean := |
cb25faf8 | 10443 | Is_Enumeration_Type (Disc_Type); |
70482933 | 10444 | |
bd7f7a65 AC |
10445 | Union_TC_Params : List_Id; |
10446 | ||
10447 | U_Name : constant Name_Id := | |
8aa23fe3 | 10448 | New_External_Name (Chars (Typ), 'V', -1); |
bd7f7a65 AC |
10449 | |
10450 | Name_Str : String_Id; | |
10451 | Struct_TC_Params : List_Id; | |
10452 | ||
10453 | Variant : Node_Id; | |
10454 | Choice : Node_Id; | |
10455 | Default : constant Node_Id := | |
10456 | Make_Integer_Literal (Loc, -1); | |
10457 | ||
02248717 | 10458 | Dummy_Counter : Nat := 0; |
bd7f7a65 | 10459 | |
8aa23fe3 | 10460 | Choice_Index : Int := 0; |
1df4f514 AC |
10461 | -- Index of current choice in TypeCode, used to identify |
10462 | -- it as the default choice if it is a "when others". | |
8aa23fe3 | 10463 | |
bd7f7a65 AC |
10464 | procedure Add_Params_For_Variant_Components; |
10465 | -- Add a struct TypeCode and a corresponding member name | |
10466 | -- to the union parameter list. | |
10467 | ||
10468 | -- Ordering of declarations is a complete mess in this | |
16b05213 | 10469 | -- area, it is supposed to be types/variables, then |
bd7f7a65 AC |
10470 | -- subprogram specs, then subprogram bodies ??? |
10471 | ||
10472 | --------------------------------------- | |
10473 | -- Add_Params_For_Variant_Components -- | |
10474 | --------------------------------------- | |
10475 | ||
cb25faf8 | 10476 | procedure Add_Params_For_Variant_Components is |
bd7f7a65 AC |
10477 | S_Name : constant Name_Id := |
10478 | New_External_Name (U_Name, 'S', -1); | |
10479 | ||
10480 | begin | |
10481 | Get_Name_String (S_Name); | |
10482 | Name_Str := String_From_Name_Buffer; | |
10483 | Initialize_Parameter_List | |
10484 | (Name_Str, Name_Str, Struct_TC_Params); | |
10485 | ||
10486 | -- Build struct parameters | |
10487 | ||
10488 | TC_Append_Record_Traversal (Struct_TC_Params, | |
10489 | Component_List (Variant), | |
10490 | Empty, | |
10491 | Dummy_Counter); | |
10492 | ||
10493 | Add_TypeCode_Parameter | |
10494 | (Make_Constructed_TypeCode | |
5b75bf57 | 10495 | (RTE (RE_Tk_Struct), Struct_TC_Params), |
bd7f7a65 AC |
10496 | Union_TC_Params); |
10497 | ||
10498 | Add_String_Parameter (Name_Str, Union_TC_Params); | |
10499 | end Add_Params_For_Variant_Components; | |
10500 | ||
1df4f514 AC |
10501 | -- Start of processing for Variant_Part |
10502 | ||
bd7f7a65 AC |
10503 | begin |
10504 | Get_Name_String (U_Name); | |
10505 | Name_Str := String_From_Name_Buffer; | |
10506 | ||
10507 | Initialize_Parameter_List | |
10508 | (Name_Str, Name_Str, Union_TC_Params); | |
10509 | ||
bd7f7a65 AC |
10510 | -- Add union in enclosing parameter list |
10511 | ||
10512 | Add_TypeCode_Parameter | |
10513 | (Make_Constructed_TypeCode | |
5b75bf57 | 10514 | (RTE (RE_Tk_Union), Union_TC_Params), |
8aa23fe3 TQ |
10515 | Params); |
10516 | ||
10517 | Add_String_Parameter (Name_Str, Params); | |
bd7f7a65 AC |
10518 | |
10519 | -- Build union parameters | |
10520 | ||
10521 | Add_TypeCode_Parameter | |
cb25faf8 | 10522 | (Build_TypeCode_Call (Loc, Disc_Type, Decls), |
8aa23fe3 TQ |
10523 | Union_TC_Params); |
10524 | ||
bd7f7a65 AC |
10525 | Add_Long_Parameter (Default, Union_TC_Params); |
10526 | ||
10527 | Variant := First_Non_Pragma (Variants (Field)); | |
10528 | while Present (Variant) loop | |
10529 | Choice := First (Discrete_Choices (Variant)); | |
10530 | while Present (Choice) loop | |
10531 | case Nkind (Choice) is | |
10532 | when N_Range => | |
10533 | declare | |
10534 | L : constant Uint := | |
10535 | Expr_Value (Low_Bound (Choice)); | |
10536 | H : constant Uint := | |
10537 | Expr_Value (High_Bound (Choice)); | |
10538 | J : Uint := L; | |
10539 | -- 3.8.1(8) guarantees that the bounds of | |
10540 | -- this range are static. | |
10541 | ||
10542 | Expr : Node_Id; | |
10543 | ||
10544 | begin | |
10545 | while J <= H loop | |
10546 | if Is_Enum then | |
cb25faf8 AC |
10547 | Expr := Get_Enum_Lit_From_Pos |
10548 | (Disc_Type, J, Loc); | |
bd7f7a65 AC |
10549 | else |
10550 | Expr := | |
10551 | Make_Integer_Literal (Loc, J); | |
10552 | end if; | |
ee2e3f6b | 10553 | |
cb25faf8 | 10554 | Set_Etype (Expr, Disc_Type); |
bd7f7a65 | 10555 | Append_To (Union_TC_Params, |
30ebb114 | 10556 | Build_To_Any_Call (Loc, Expr, Decls)); |
8aa23fe3 | 10557 | |
bd7f7a65 AC |
10558 | Add_Params_For_Variant_Components; |
10559 | J := J + Uint_1; | |
10560 | end loop; | |
226a7fa4 | 10561 | |
1df4f514 AC |
10562 | Choice_Index := |
10563 | Choice_Index + UI_To_Int (H - L) + 1; | |
bd7f7a65 AC |
10564 | end; |
10565 | ||
10566 | when N_Others_Choice => | |
8aa23fe3 | 10567 | |
cb25faf8 AC |
10568 | -- This variant has a default choice. We must |
10569 | -- therefore set the default parameter to the | |
10570 | -- current choice index. This parameter is by | |
10571 | -- construction the 4th in Union_TC_Params. | |
8aa23fe3 | 10572 | |
1df4f514 AC |
10573 | Replace |
10574 | (Pick (Union_TC_Params, 4), | |
10575 | Make_Function_Call (Loc, | |
10576 | Name => | |
10577 | New_Occurrence_Of | |
10578 | (RTE (RE_TA_I32), Loc), | |
10579 | Parameter_Associations => | |
10580 | New_List ( | |
10581 | Make_Integer_Literal (Loc, | |
10582 | Intval => Choice_Index)))); | |
8aa23fe3 | 10583 | |
cb25faf8 AC |
10584 | -- Add a placeholder member label for the |
10585 | -- default case, which must have the | |
10586 | -- discriminant type. | |
8aa23fe3 TQ |
10587 | |
10588 | declare | |
10589 | Exp : constant Node_Id := | |
ee2e3f6b AC |
10590 | Make_Attribute_Reference (Loc, |
10591 | Prefix => New_Occurrence_Of | |
10592 | (Disc_Type, Loc), | |
10593 | Attribute_Name => Name_First); | |
8aa23fe3 | 10594 | begin |
cb25faf8 | 10595 | Set_Etype (Exp, Disc_Type); |
8aa23fe3 | 10596 | Append_To (Union_TC_Params, |
30ebb114 | 10597 | Build_To_Any_Call (Loc, Exp, Decls)); |
8aa23fe3 TQ |
10598 | end; |
10599 | ||
bd7f7a65 | 10600 | Add_Params_For_Variant_Components; |
1df4f514 | 10601 | Choice_Index := Choice_Index + 1; |
bd7f7a65 | 10602 | |
226a7fa4 | 10603 | -- Case of an explicit choice |
bfc2cdb1 | 10604 | |
226a7fa4 | 10605 | when others => |
8aa23fe3 TQ |
10606 | declare |
10607 | Exp : constant Node_Id := | |
d693e39d | 10608 | New_Copy_Tree (Choice); |
8aa23fe3 TQ |
10609 | begin |
10610 | Append_To (Union_TC_Params, | |
30ebb114 | 10611 | Build_To_Any_Call (Loc, Exp, Decls)); |
8aa23fe3 | 10612 | end; |
bd7f7a65 | 10613 | |
8aa23fe3 | 10614 | Add_Params_For_Variant_Components; |
1df4f514 | 10615 | Choice_Index := Choice_Index + 1; |
bd7f7a65 | 10616 | end case; |
d693e39d | 10617 | |
8aa23fe3 | 10618 | Next (Choice); |
bd7f7a65 AC |
10619 | end loop; |
10620 | ||
10621 | Next_Non_Pragma (Variant); | |
10622 | end loop; | |
1df4f514 | 10623 | end Variant_Part; |
bd7f7a65 AC |
10624 | end if; |
10625 | end TC_Rec_Add_Process_Element; | |
70482933 | 10626 | |
bd7f7a65 AC |
10627 | Type_Name_Str : String_Id; |
10628 | Type_Repo_Id_Str : String_Id; | |
70482933 | 10629 | |
a712aa03 AC |
10630 | -- Start of processing for Build_TypeCode_Function |
10631 | ||
bd7f7a65 | 10632 | begin |
690001a2 BD |
10633 | -- For a derived type, we can't go past the base type (to the |
10634 | -- parent type) here, because that would cause the attribute's | |
10635 | -- formal parameter to have the wrong type; hence the Base_Type | |
10636 | -- check here. | |
a712aa03 AC |
10637 | |
10638 | if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then | |
8aa23fe3 TQ |
10639 | Build_TypeCode_Function |
10640 | (Loc => Loc, | |
1c218ac3 AC |
10641 | Typ => Etype (Typ), |
10642 | Decl => Decl, | |
10643 | Fnam => Fnam); | |
8aa23fe3 TQ |
10644 | return; |
10645 | end if; | |
10646 | ||
bd7f7a65 | 10647 | Fnam := TCNam; |
70482933 | 10648 | |
bd7f7a65 AC |
10649 | Spec := |
10650 | Make_Function_Specification (Loc, | |
d693e39d | 10651 | Defining_Unit_Name => Fnam, |
bd7f7a65 | 10652 | Parameter_Specifications => Empty_List, |
d693e39d | 10653 | Result_Definition => |
3eb8fddc | 10654 | New_Occurrence_Of (RTE (RE_TypeCode), Loc)); |
70482933 | 10655 | |
bd7f7a65 AC |
10656 | Build_Name_And_Repository_Id (Typ, |
10657 | Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str); | |
d693e39d | 10658 | |
bd7f7a65 AC |
10659 | Initialize_Parameter_List |
10660 | (Type_Name_Str, Type_Repo_Id_Str, Parameters); | |
70482933 | 10661 | |
25e9b6fe TQ |
10662 | if Has_Stream_Attribute_Definition |
10663 | (Typ, TSS_Stream_Output, At_Any_Place => True) | |
d693e39d | 10664 | or else |
25e9b6fe TQ |
10665 | Has_Stream_Attribute_Definition |
10666 | (Typ, TSS_Stream_Write, At_Any_Place => True) | |
bd7f7a65 | 10667 | then |
25e9b6fe TQ |
10668 | -- If user-defined stream attributes are specified for this |
10669 | -- type, use them and transmit data as an opaque sequence of | |
10670 | -- stream elements. | |
10671 | ||
10672 | Return_Alias_TypeCode | |
10673 | (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc)); | |
10674 | ||
10675 | elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then | |
8aa23fe3 TQ |
10676 | Return_Alias_TypeCode ( |
10677 | Build_TypeCode_Call (Loc, Etype (Typ), Decls)); | |
70482933 | 10678 | |
25e9b6fe | 10679 | elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then |
bd7f7a65 AC |
10680 | Return_Alias_TypeCode ( |
10681 | Build_TypeCode_Call (Loc, | |
10682 | Find_Numeric_Representation (Typ), Decls)); | |
70482933 | 10683 | |
25e9b6fe | 10684 | elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then |
8aa23fe3 TQ |
10685 | |
10686 | -- Record typecodes are encoded as follows: | |
10687 | -- -- TC_STRUCT | |
10688 | -- | | |
10689 | -- | [Name] | |
10690 | -- | [Repository Id] | |
10691 | -- | |
10692 | -- Then for each discriminant: | |
10693 | -- | |
10694 | -- | [Discriminant Type Code] | |
10695 | -- | [Discriminant Name] | |
10696 | -- | ... | |
10697 | -- | |
10698 | -- Then for each component: | |
10699 | -- | |
10700 | -- | [Component Type Code] | |
10701 | -- | [Component Name] | |
10702 | -- | ... | |
10703 | -- | |
10704 | -- Variants components type codes are encoded as follows: | |
10705 | -- -- TC_UNION | |
10706 | -- | | |
10707 | -- | [Name] | |
10708 | -- | [Repository Id] | |
10709 | -- | [Discriminant Type Code] | |
10710 | -- | [Index of Default Variant Part or -1 for no default] | |
10711 | -- | |
10712 | -- Then for each Variant Part : | |
10713 | -- | |
10714 | -- | [VP Label] | |
10715 | -- | | |
10716 | -- | -- TC_STRUCT | |
10717 | -- | | [Variant Part Name] | |
10718 | -- | | [Variant Part Repository Id] | |
10719 | -- | | | |
10720 | -- | Then for each VP component: | |
10721 | -- | | [VP component Typecode] | |
10722 | -- | | [VP component Name] | |
10723 | -- | | ... | |
10724 | -- | -- | |
10725 | -- | | |
10726 | -- | [VP Name] | |
10727 | ||
bd7f7a65 | 10728 | if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then |
d693e39d TQ |
10729 | Return_Alias_TypeCode |
10730 | (Build_TypeCode_Call (Loc, Etype (Typ), Decls)); | |
10731 | ||
bd7f7a65 AC |
10732 | else |
10733 | declare | |
10734 | Disc : Entity_Id := Empty; | |
10735 | Rdef : constant Node_Id := | |
d693e39d | 10736 | Type_Definition (Declaration_Node (Typ)); |
bd7f7a65 | 10737 | Dummy_Counter : Int := 0; |
d693e39d | 10738 | |
bd7f7a65 | 10739 | begin |
8aa23fe3 | 10740 | -- Construct the discriminants typecodes |
bd7f7a65 AC |
10741 | |
10742 | if Has_Discriminants (Typ) then | |
10743 | Disc := First_Discriminant (Typ); | |
10744 | end if; | |
d693e39d | 10745 | |
bd7f7a65 AC |
10746 | while Present (Disc) loop |
10747 | Add_TypeCode_Parameter ( | |
10748 | Build_TypeCode_Call (Loc, Etype (Disc), Decls), | |
10749 | Parameters); | |
10750 | Get_Name_String (Chars (Disc)); | |
10751 | Add_String_Parameter ( | |
10752 | String_From_Name_Buffer, | |
10753 | Parameters); | |
10754 | Next_Discriminant (Disc); | |
10755 | end loop; | |
10756 | ||
8aa23fe3 | 10757 | -- then the components typecodes |
bd7f7a65 AC |
10758 | |
10759 | TC_Append_Record_Traversal | |
10760 | (Parameters, Component_List (Rdef), | |
10761 | Empty, Dummy_Counter); | |
5b75bf57 | 10762 | Return_Constructed_TypeCode (RTE (RE_Tk_Struct)); |
bd7f7a65 AC |
10763 | end; |
10764 | end if; | |
70482933 | 10765 | |
bd7f7a65 AC |
10766 | elsif Is_Array_Type (Typ) then |
10767 | declare | |
10768 | Ndim : constant Pos := Number_Dimensions (Typ); | |
10769 | Inner_TypeCode : Node_Id; | |
10770 | Constrained : constant Boolean := Is_Constrained (Typ); | |
10771 | Indx : Node_Id := First_Index (Typ); | |
70482933 | 10772 | |
bd7f7a65 | 10773 | begin |
d693e39d TQ |
10774 | Inner_TypeCode := |
10775 | Build_TypeCode_Call (Loc, Component_Type (Typ), Decls); | |
bd7f7a65 AC |
10776 | |
10777 | for J in 1 .. Ndim loop | |
10778 | if Constrained then | |
10779 | Inner_TypeCode := Make_Constructed_TypeCode | |
5b75bf57 | 10780 | (RTE (RE_Tk_Array), New_List ( |
30ebb114 | 10781 | Build_To_Any_Call (Loc, |
686d0984 | 10782 | OK_Convert_To (RTE (RE_Unsigned_32), |
bd7f7a65 | 10783 | Make_Attribute_Reference (Loc, |
d693e39d TQ |
10784 | Prefix => New_Occurrence_Of (Typ, Loc), |
10785 | Attribute_Name => Name_Length, | |
bd7f7a65 AC |
10786 | Expressions => New_List ( |
10787 | Make_Integer_Literal (Loc, | |
d693e39d | 10788 | Intval => Ndim - J + 1)))), |
bd7f7a65 | 10789 | Decls), |
30ebb114 | 10790 | Build_To_Any_Call (Loc, Inner_TypeCode, Decls))); |
bd7f7a65 AC |
10791 | |
10792 | else | |
10793 | -- Unconstrained case: add low bound for each | |
10794 | -- dimension. | |
10795 | ||
10796 | Add_TypeCode_Parameter | |
10797 | (Build_TypeCode_Call (Loc, Etype (Indx), Decls), | |
10798 | Parameters); | |
10799 | Get_Name_String (New_External_Name ('L', J)); | |
10800 | Add_String_Parameter ( | |
10801 | String_From_Name_Buffer, | |
10802 | Parameters); | |
10803 | Next_Index (Indx); | |
10804 | ||
10805 | Inner_TypeCode := Make_Constructed_TypeCode | |
5b75bf57 | 10806 | (RTE (RE_Tk_Sequence), New_List ( |
30ebb114 | 10807 | Build_To_Any_Call (Loc, |
686d0984 | 10808 | OK_Convert_To (RTE (RE_Unsigned_32), |
bd7f7a65 AC |
10809 | Make_Integer_Literal (Loc, 0)), |
10810 | Decls), | |
30ebb114 | 10811 | Build_To_Any_Call (Loc, Inner_TypeCode, Decls))); |
bd7f7a65 AC |
10812 | end if; |
10813 | end loop; | |
10814 | ||
10815 | if Constrained then | |
10816 | Return_Alias_TypeCode (Inner_TypeCode); | |
10817 | else | |
10818 | Add_TypeCode_Parameter (Inner_TypeCode, Parameters); | |
10819 | Start_String; | |
10820 | Store_String_Char ('V'); | |
10821 | Add_String_Parameter (End_String, Parameters); | |
5b75bf57 | 10822 | Return_Constructed_TypeCode (RTE (RE_Tk_Struct)); |
bd7f7a65 AC |
10823 | end if; |
10824 | end; | |
70482933 | 10825 | |
bd7f7a65 AC |
10826 | else |
10827 | -- Default: type is represented as an opaque sequence of bytes | |
1735e55d | 10828 | |
bd7f7a65 AC |
10829 | Return_Alias_TypeCode |
10830 | (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc)); | |
10831 | end if; | |
70482933 | 10832 | |
bd7f7a65 AC |
10833 | Decl := |
10834 | Make_Subprogram_Body (Loc, | |
d693e39d TQ |
10835 | Specification => Spec, |
10836 | Declarations => Decls, | |
bd7f7a65 AC |
10837 | Handled_Statement_Sequence => |
10838 | Make_Handled_Sequence_Of_Statements (Loc, | |
10839 | Statements => Stms)); | |
10840 | end Build_TypeCode_Function; | |
10841 | ||
bd7f7a65 AC |
10842 | --------------------------------- |
10843 | -- Find_Numeric_Representation -- | |
10844 | --------------------------------- | |
7324bf49 | 10845 | |
6ce0c3f5 TQ |
10846 | function Find_Numeric_Representation |
10847 | (Typ : Entity_Id) return Entity_Id | |
bd7f7a65 AC |
10848 | is |
10849 | FST : constant Entity_Id := First_Subtype (Typ); | |
10850 | P_Size : constant Uint := Esize (FST); | |
7324bf49 | 10851 | |
bd7f7a65 | 10852 | begin |
24c34107 AC |
10853 | -- Special case: for Stream_Element_Offset and Storage_Offset, |
10854 | -- always force transmission as a 64-bit value. | |
10855 | ||
10856 | if Is_RTE (FST, RE_Stream_Element_Offset) | |
579fda56 AC |
10857 | or else |
10858 | Is_RTE (FST, RE_Storage_Offset) | |
24c34107 AC |
10859 | then |
10860 | return RTE (RE_Unsigned_64); | |
10861 | end if; | |
10862 | ||
bd7f7a65 | 10863 | if Is_Unsigned_Type (Typ) then |
686d0984 AC |
10864 | if P_Size <= 8 then |
10865 | return RTE (RE_Unsigned_8); | |
7324bf49 | 10866 | |
686d0984 AC |
10867 | elsif P_Size <= 16 then |
10868 | return RTE (RE_Unsigned_16); | |
1735e55d | 10869 | |
686d0984 AC |
10870 | elsif P_Size <= 32 then |
10871 | return RTE (RE_Unsigned_32); | |
bd7f7a65 AC |
10872 | |
10873 | else | |
686d0984 | 10874 | return RTE (RE_Unsigned_64); |
1735e55d | 10875 | end if; |
7324bf49 | 10876 | |
bd7f7a65 | 10877 | elsif Is_Integer_Type (Typ) then |
686d0984 AC |
10878 | if P_Size <= 8 then |
10879 | return RTE (RE_Integer_8); | |
7324bf49 | 10880 | |
bd7f7a65 | 10881 | elsif P_Size <= Standard_Short_Integer_Size then |
686d0984 | 10882 | return RTE (RE_Integer_16); |
7324bf49 | 10883 | |
bd7f7a65 | 10884 | elsif P_Size <= Standard_Integer_Size then |
686d0984 | 10885 | return RTE (RE_Integer_32); |
70482933 | 10886 | |
bd7f7a65 | 10887 | else |
686d0984 | 10888 | return RTE (RE_Integer_64); |
bd7f7a65 | 10889 | end if; |
70482933 | 10890 | |
bd7f7a65 AC |
10891 | elsif Is_Floating_Point_Type (Typ) then |
10892 | if P_Size <= Standard_Short_Float_Size then | |
10893 | return Standard_Short_Float; | |
1735e55d | 10894 | |
bd7f7a65 AC |
10895 | elsif P_Size <= Standard_Float_Size then |
10896 | return Standard_Float; | |
1735e55d | 10897 | |
bd7f7a65 AC |
10898 | elsif P_Size <= Standard_Long_Float_Size then |
10899 | return Standard_Long_Float; | |
70482933 | 10900 | |
bd7f7a65 AC |
10901 | else |
10902 | return Standard_Long_Long_Float; | |
10903 | end if; | |
70482933 | 10904 | |
bd7f7a65 AC |
10905 | else |
10906 | raise Program_Error; | |
10907 | end if; | |
70482933 | 10908 | |
bd7f7a65 AC |
10909 | -- TBD: fixed point types??? |
10910 | -- TBverified numeric types with a biased representation??? | |
70482933 | 10911 | |
bd7f7a65 | 10912 | end Find_Numeric_Representation; |
70482933 | 10913 | |
1f5c7ba8 EB |
10914 | --------------------------------- |
10915 | -- Is_Generic_Actual_Subtype -- | |
10916 | --------------------------------- | |
10917 | ||
10918 | function Is_Generic_Actual_Subtype (Typ : Entity_Id) return Boolean is | |
10919 | begin | |
10920 | if Is_Itype (Typ) | |
10921 | and then Present (Associated_Node_For_Itype (Typ)) | |
10922 | then | |
10923 | declare | |
10924 | N : constant Node_Id := Associated_Node_For_Itype (Typ); | |
10925 | begin | |
10926 | if Nkind (N) = N_Subtype_Declaration | |
10927 | and then Nkind (Parent (N)) = N_Package_Specification | |
10928 | and then Is_Generic_Instance (Scope_Of_Spec (Parent (N))) | |
10929 | then | |
10930 | return True; | |
10931 | end if; | |
10932 | end; | |
10933 | end if; | |
10934 | ||
10935 | return False; | |
10936 | end Is_Generic_Actual_Subtype; | |
10937 | ||
bd7f7a65 AC |
10938 | --------------------------- |
10939 | -- Append_Array_Traversal -- | |
10940 | --------------------------- | |
70482933 | 10941 | |
bd7f7a65 AC |
10942 | procedure Append_Array_Traversal |
10943 | (Stmts : List_Id; | |
10944 | Any : Entity_Id; | |
10945 | Counter : Entity_Id := Empty; | |
10946 | Depth : Pos := 1) | |
10947 | is | |
10948 | Loc : constant Source_Ptr := Sloc (Subprogram); | |
10949 | Typ : constant Entity_Id := Etype (Arry); | |
10950 | Constrained : constant Boolean := Is_Constrained (Typ); | |
10951 | Ndim : constant Pos := Number_Dimensions (Typ); | |
70482933 | 10952 | |
bd7f7a65 | 10953 | Inner_Any, Inner_Counter : Entity_Id; |
70482933 | 10954 | |
bd7f7a65 AC |
10955 | Loop_Stm : Node_Id; |
10956 | Inner_Stmts : constant List_Id := New_List; | |
70482933 | 10957 | |
bd7f7a65 AC |
10958 | begin |
10959 | if Depth > Ndim then | |
70482933 | 10960 | |
bd7f7a65 | 10961 | -- Processing for one element of an array |
70482933 | 10962 | |
bd7f7a65 AC |
10963 | declare |
10964 | Element_Expr : constant Node_Id := | |
10965 | Make_Indexed_Component (Loc, | |
10966 | New_Occurrence_Of (Arry, Loc), | |
3b42c566 | 10967 | Indexes); |
bd7f7a65 AC |
10968 | begin |
10969 | Set_Etype (Element_Expr, Component_Type (Typ)); | |
10970 | Add_Process_Element (Stmts, | |
10971 | Any => Any, | |
10972 | Counter => Counter, | |
10973 | Datum => Element_Expr); | |
10974 | end; | |
70482933 | 10975 | |
bd7f7a65 AC |
10976 | return; |
10977 | end if; | |
70482933 | 10978 | |
3b42c566 | 10979 | Append_To (Indexes, |
bd7f7a65 | 10980 | Make_Identifier (Loc, New_External_Name ('L', Depth))); |
70482933 | 10981 | |
6ce0c3f5 | 10982 | if not Constrained or else Depth > 1 then |
bd7f7a65 | 10983 | Inner_Any := Make_Defining_Identifier (Loc, |
6ce0c3f5 | 10984 | New_External_Name ('A', Depth)); |
bd7f7a65 | 10985 | Set_Etype (Inner_Any, RTE (RE_Any)); |
6ce0c3f5 TQ |
10986 | else |
10987 | Inner_Any := Empty; | |
10988 | end if; | |
70482933 | 10989 | |
6ce0c3f5 TQ |
10990 | if Present (Counter) then |
10991 | Inner_Counter := Make_Defining_Identifier (Loc, | |
10992 | New_External_Name ('J', Depth)); | |
10993 | else | |
10994 | Inner_Counter := Empty; | |
bd7f7a65 | 10995 | end if; |
70482933 | 10996 | |
6ce0c3f5 TQ |
10997 | declare |
10998 | Loop_Any : Node_Id := Inner_Any; | |
6ce0c3f5 | 10999 | |
d693e39d | 11000 | begin |
6ce0c3f5 TQ |
11001 | -- For the first dimension of a constrained array, we add |
11002 | -- elements directly in the corresponding Any; there is no | |
11003 | -- intervening inner Any. | |
11004 | ||
11005 | if No (Loop_Any) then | |
11006 | Loop_Any := Any; | |
11007 | end if; | |
11008 | ||
11009 | Append_Array_Traversal (Inner_Stmts, | |
11010 | Any => Loop_Any, | |
11011 | Counter => Inner_Counter, | |
11012 | Depth => Depth + 1); | |
11013 | end; | |
bd7f7a65 AC |
11014 | |
11015 | Loop_Stm := | |
11016 | Make_Implicit_Loop_Statement (Subprogram, | |
11017 | Iteration_Scheme => | |
11018 | Make_Iteration_Scheme (Loc, | |
11019 | Loop_Parameter_Specification => | |
11020 | Make_Loop_Parameter_Specification (Loc, | |
11021 | Defining_Identifier => | |
11022 | Make_Defining_Identifier (Loc, | |
11023 | Chars => New_External_Name ('L', Depth)), | |
70482933 | 11024 | |
bd7f7a65 AC |
11025 | Discrete_Subtype_Definition => |
11026 | Make_Attribute_Reference (Loc, | |
11027 | Prefix => New_Occurrence_Of (Arry, Loc), | |
11028 | Attribute_Name => Name_Range, | |
70482933 | 11029 | |
bd7f7a65 AC |
11030 | Expressions => New_List ( |
11031 | Make_Integer_Literal (Loc, Depth))))), | |
11032 | Statements => Inner_Stmts); | |
70482933 | 11033 | |
bd7f7a65 AC |
11034 | declare |
11035 | Decls : constant List_Id := New_List; | |
11036 | Dimen_Stmts : constant List_Id := New_List; | |
11037 | Length_Node : Node_Id; | |
70482933 | 11038 | |
bd7f7a65 AC |
11039 | Inner_Any_TypeCode : constant Entity_Id := |
11040 | Make_Defining_Identifier (Loc, | |
11041 | New_External_Name ('T', Depth)); | |
70482933 | 11042 | |
bd7f7a65 | 11043 | Inner_Any_TypeCode_Expr : Node_Id; |
70482933 | 11044 | |
bd7f7a65 AC |
11045 | begin |
11046 | if Depth = 1 then | |
6ce0c3f5 TQ |
11047 | if Constrained then |
11048 | Inner_Any_TypeCode_Expr := | |
11049 | Make_Function_Call (Loc, | |
d693e39d | 11050 | Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc), |
6ce0c3f5 TQ |
11051 | Parameter_Associations => New_List ( |
11052 | New_Occurrence_Of (Any, Loc))); | |
c6f39437 | 11053 | |
6ce0c3f5 TQ |
11054 | else |
11055 | Inner_Any_TypeCode_Expr := | |
11056 | Make_Function_Call (Loc, | |
11057 | Name => | |
11058 | New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc), | |
11059 | Parameter_Associations => New_List ( | |
11060 | New_Occurrence_Of (Any, Loc), | |
11061 | Make_Integer_Literal (Loc, Ndim))); | |
11062 | end if; | |
c6f39437 | 11063 | |
bd7f7a65 AC |
11064 | else |
11065 | Inner_Any_TypeCode_Expr := | |
11066 | Make_Function_Call (Loc, | |
d693e39d | 11067 | Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc), |
bd7f7a65 AC |
11068 | Parameter_Associations => New_List ( |
11069 | Make_Identifier (Loc, | |
d693e39d | 11070 | Chars => New_External_Name ('T', Depth - 1)))); |
bd7f7a65 | 11071 | end if; |
70482933 | 11072 | |
bd7f7a65 AC |
11073 | Append_To (Decls, |
11074 | Make_Object_Declaration (Loc, | |
11075 | Defining_Identifier => Inner_Any_TypeCode, | |
11076 | Constant_Present => True, | |
11077 | Object_Definition => New_Occurrence_Of ( | |
11078 | RTE (RE_TypeCode), Loc), | |
11079 | Expression => Inner_Any_TypeCode_Expr)); | |
6ce0c3f5 TQ |
11080 | |
11081 | if Present (Inner_Any) then | |
11082 | Append_To (Decls, | |
11083 | Make_Object_Declaration (Loc, | |
11084 | Defining_Identifier => Inner_Any, | |
11085 | Object_Definition => | |
11086 | New_Occurrence_Of (RTE (RE_Any), Loc), | |
11087 | Expression => | |
11088 | Make_Function_Call (Loc, | |
11089 | Name => | |
11090 | New_Occurrence_Of ( | |
11091 | RTE (RE_Create_Any), Loc), | |
11092 | Parameter_Associations => New_List ( | |
11093 | New_Occurrence_Of (Inner_Any_TypeCode, Loc))))); | |
11094 | end if; | |
70482933 | 11095 | |
bd7f7a65 AC |
11096 | if Present (Inner_Counter) then |
11097 | Append_To (Decls, | |
11098 | Make_Object_Declaration (Loc, | |
11099 | Defining_Identifier => Inner_Counter, | |
11100 | Object_Definition => | |
686d0984 | 11101 | New_Occurrence_Of (RTE (RE_Unsigned_32), Loc), |
bd7f7a65 AC |
11102 | Expression => |
11103 | Make_Integer_Literal (Loc, 0))); | |
11104 | end if; | |
70482933 | 11105 | |
6ce0c3f5 TQ |
11106 | if not Constrained then |
11107 | Length_Node := Make_Attribute_Reference (Loc, | |
11108 | Prefix => New_Occurrence_Of (Arry, Loc), | |
11109 | Attribute_Name => Name_Length, | |
11110 | Expressions => | |
11111 | New_List (Make_Integer_Literal (Loc, Depth))); | |
686d0984 | 11112 | Set_Etype (Length_Node, RTE (RE_Unsigned_32)); |
6ce0c3f5 TQ |
11113 | |
11114 | Add_Process_Element (Dimen_Stmts, | |
11115 | Datum => Length_Node, | |
11116 | Any => Inner_Any, | |
11117 | Counter => Inner_Counter); | |
11118 | end if; | |
70482933 | 11119 | |
8aa23fe3 | 11120 | -- Loop_Stm does appropriate processing for each element |
bd7f7a65 | 11121 | -- of Inner_Any. |
1735e55d | 11122 | |
bd7f7a65 | 11123 | Append_To (Dimen_Stmts, Loop_Stm); |
1735e55d | 11124 | |
bd7f7a65 | 11125 | -- Link outer and inner any |
1735e55d | 11126 | |
6ce0c3f5 TQ |
11127 | if Present (Inner_Any) then |
11128 | Add_Process_Element (Dimen_Stmts, | |
11129 | Any => Any, | |
11130 | Counter => Counter, | |
11131 | Datum => New_Occurrence_Of (Inner_Any, Loc)); | |
11132 | end if; | |
1735e55d | 11133 | |
bd7f7a65 AC |
11134 | Append_To (Stmts, |
11135 | Make_Block_Statement (Loc, | |
11136 | Declarations => | |
11137 | Decls, | |
11138 | Handled_Statement_Sequence => | |
11139 | Make_Handled_Sequence_Of_Statements (Loc, | |
11140 | Statements => Dimen_Stmts))); | |
11141 | end; | |
11142 | end Append_Array_Traversal; | |
1735e55d | 11143 | |
54838d1f AC |
11144 | ------------------------------- |
11145 | -- Make_Helper_Function_Name -- | |
11146 | ------------------------------- | |
1735e55d | 11147 | |
54838d1f | 11148 | function Make_Helper_Function_Name |
bd7f7a65 AC |
11149 | (Loc : Source_Ptr; |
11150 | Typ : Entity_Id; | |
11151 | Nam : Name_Id) return Entity_Id | |
11152 | is | |
11153 | begin | |
54838d1f AC |
11154 | declare |
11155 | Serial : Nat := 0; | |
1c218ac3 AC |
11156 | -- For tagged types that aren't frozen yet, generate the helper |
11157 | -- under its canonical name so that it matches the primitive | |
11158 | -- spec. For all other cases, we use a serialized name so that | |
11159 | -- multiple generations of the same procedure do not clash. | |
53aa4444 | 11160 | |
54838d1f | 11161 | begin |
1c218ac3 AC |
11162 | if Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then |
11163 | null; | |
1c218ac3 | 11164 | else |
54838d1f AC |
11165 | Serial := Increment_Serial_Number; |
11166 | end if; | |
11167 | ||
1c218ac3 | 11168 | -- Use prefixed underscore to avoid potential clash with user |
54838d1f AC |
11169 | -- identifier (we use attribute names for Nam). |
11170 | ||
d693e39d TQ |
11171 | return |
11172 | Make_Defining_Identifier (Loc, | |
bd7f7a65 | 11173 | Chars => |
54838d1f | 11174 | New_External_Name |
1c218ac3 AC |
11175 | (Related_Id => Nam, |
11176 | Suffix => ' ', | |
11177 | Suffix_Index => Serial, | |
11178 | Prefix => '_')); | |
54838d1f AC |
11179 | end; |
11180 | end Make_Helper_Function_Name; | |
bd7f7a65 | 11181 | end Helpers; |
16db96c5 AC |
11182 | |
11183 | ----------------------------------- | |
11184 | -- Reserve_NamingContext_Methods -- | |
11185 | ----------------------------------- | |
11186 | ||
11187 | procedure Reserve_NamingContext_Methods is | |
11188 | Str_Resolve : constant String := "resolve"; | |
11189 | begin | |
11190 | Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve; | |
11191 | Name_Len := Str_Resolve'Length; | |
11192 | Overload_Counter_Table.Set (Name_Find, 1); | |
11193 | end Reserve_NamingContext_Methods; | |
11194 | ||
a3068ca6 AC |
11195 | ----------------------- |
11196 | -- RPC_Receiver_Decl -- | |
11197 | ----------------------- | |
11198 | ||
11199 | function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is | |
11200 | Loc : constant Source_Ptr := Sloc (RACW_Type); | |
a3068ca6 AC |
11201 | begin |
11202 | return | |
11203 | Make_Object_Declaration (Loc, | |
11204 | Defining_Identifier => Make_Temporary (Loc, 'R'), | |
11205 | Aliased_Present => True, | |
11206 | Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); | |
11207 | end RPC_Receiver_Decl; | |
11208 | ||
1735e55d AC |
11209 | end PolyORB_Support; |
11210 | ||
70482933 RK |
11211 | ------------------------------- |
11212 | -- RACW_Type_Is_Asynchronous -- | |
11213 | ------------------------------- | |
11214 | ||
c885d7a1 | 11215 | procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is |
5885facb | 11216 | Asynchronous_Flag : constant Entity_Id := |
1735e55d | 11217 | Asynchronous_Flags_Table.Get (RACW_Type); |
70482933 | 11218 | begin |
5885facb TQ |
11219 | Replace (Expression (Parent (Asynchronous_Flag)), |
11220 | New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag))); | |
70482933 RK |
11221 | end RACW_Type_Is_Asynchronous; |
11222 | ||
11223 | ------------------------- | |
11224 | -- RCI_Package_Locator -- | |
11225 | ------------------------- | |
11226 | ||
11227 | function RCI_Package_Locator | |
11228 | (Loc : Source_Ptr; | |
c885d7a1 | 11229 | Package_Spec : Node_Id) return Node_Id |
70482933 | 11230 | is |
1735e55d | 11231 | Inst : Node_Id; |
72267417 AC |
11232 | Pkg_Name : constant String_Id := |
11233 | Fully_Qualified_Name_String | |
11234 | (Defining_Entity (Package_Spec), Append_NUL => False); | |
70482933 RK |
11235 | |
11236 | begin | |
48ab1182 TQ |
11237 | Inst := |
11238 | Make_Package_Instantiation (Loc, | |
2287a75d | 11239 | Defining_Unit_Name => Make_Temporary (Loc, 'R'), |
c6f39437 | 11240 | |
48ab1182 TQ |
11241 | Name => |
11242 | New_Occurrence_Of (RTE (RE_RCI_Locator), Loc), | |
c6f39437 | 11243 | |
48ab1182 TQ |
11244 | Generic_Associations => New_List ( |
11245 | Make_Generic_Association (Loc, | |
11246 | Selector_Name => | |
11247 | Make_Identifier (Loc, Name_RCI_Name), | |
11248 | Explicit_Generic_Actual_Parameter => | |
11249 | Make_String_Literal (Loc, | |
8aa23fe3 | 11250 | Strval => Pkg_Name)), |
c6f39437 | 11251 | |
8aa23fe3 TQ |
11252 | Make_Generic_Association (Loc, |
11253 | Selector_Name => | |
11254 | Make_Identifier (Loc, Name_Version), | |
11255 | Explicit_Generic_Actual_Parameter => | |
11256 | Make_Attribute_Reference (Loc, | |
11257 | Prefix => | |
11258 | New_Occurrence_Of (Defining_Entity (Package_Spec), Loc), | |
11259 | Attribute_Name => | |
11260 | Name_Version)))); | |
48ab1182 | 11261 | |
c6f39437 AC |
11262 | RCI_Locator_Table.Set |
11263 | (Defining_Unit_Name (Package_Spec), | |
11264 | Defining_Unit_Name (Inst)); | |
70482933 RK |
11265 | return Inst; |
11266 | end RCI_Package_Locator; | |
11267 | ||
11268 | ----------------------------------------------- | |
11269 | -- Remote_Types_Tagged_Full_View_Encountered -- | |
11270 | ----------------------------------------------- | |
11271 | ||
11272 | procedure Remote_Types_Tagged_Full_View_Encountered | |
c885d7a1 | 11273 | (Full_View : Entity_Id) |
70482933 RK |
11274 | is |
11275 | Stub_Elements : constant Stub_Structure := | |
11276 | Stubs_Table.Get (Full_View); | |
651a2cb0 | 11277 | |
70482933 | 11278 | begin |
25e9b6fe TQ |
11279 | -- For an RACW encountered before the freeze point of its designated |
11280 | -- type, the stub type is generated at the point of the RACW declaration | |
11281 | -- but the primitives are generated only once the designated type is | |
11282 | -- frozen. That freeze can occur in another scope, for example when the | |
11283 | -- RACW is declared in a nested package. In that case we need to | |
11284 | -- reestablish the stub type's scope prior to generating its primitive | |
11285 | -- operations. | |
11286 | ||
70482933 | 11287 | if Stub_Elements /= Empty_Stub_Structure then |
25e9b6fe TQ |
11288 | declare |
11289 | Saved_Scope : constant Entity_Id := Current_Scope; | |
11290 | Stubs_Scope : constant Entity_Id := | |
11291 | Scope (Stub_Elements.Stub_Type); | |
651a2cb0 | 11292 | |
25e9b6fe TQ |
11293 | begin |
11294 | if Current_Scope /= Stubs_Scope then | |
11295 | Push_Scope (Stubs_Scope); | |
11296 | end if; | |
11297 | ||
11298 | Add_RACW_Primitive_Declarations_And_Bodies | |
11299 | (Full_View, | |
11300 | Stub_Elements.RPC_Receiver_Decl, | |
11301 | Stub_Elements.Body_Decls); | |
11302 | ||
11303 | if Current_Scope /= Saved_Scope then | |
11304 | Pop_Scope; | |
11305 | end if; | |
11306 | end; | |
70482933 RK |
11307 | end if; |
11308 | end Remote_Types_Tagged_Full_View_Encountered; | |
11309 | ||
11310 | ------------------- | |
11311 | -- Scope_Of_Spec -- | |
11312 | ------------------- | |
11313 | ||
11314 | function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is | |
6ce0c3f5 | 11315 | Unit_Name : Node_Id; |
70482933 RK |
11316 | |
11317 | begin | |
6ce0c3f5 | 11318 | Unit_Name := Defining_Unit_Name (Spec); |
70482933 RK |
11319 | while Nkind (Unit_Name) /= N_Defining_Identifier loop |
11320 | Unit_Name := Defining_Identifier (Unit_Name); | |
11321 | end loop; | |
11322 | ||
11323 | return Unit_Name; | |
11324 | end Scope_Of_Spec; | |
11325 | ||
1735e55d AC |
11326 | ---------------------- |
11327 | -- Set_Renaming_TSS -- | |
11328 | ---------------------- | |
11329 | ||
11330 | procedure Set_Renaming_TSS | |
11331 | (Typ : Entity_Id; | |
11332 | Nam : Entity_Id; | |
a9d8907c | 11333 | TSS_Nam : TSS_Name_Type) |
1735e55d AC |
11334 | is |
11335 | Loc : constant Source_Ptr := Sloc (Nam); | |
11336 | Spec : constant Node_Id := Parent (Nam); | |
11337 | ||
11338 | TSS_Node : constant Node_Id := | |
11339 | Make_Subprogram_Renaming_Declaration (Loc, | |
11340 | Specification => | |
11341 | Copy_Specification (Loc, | |
11342 | Spec => Spec, | |
a9d8907c | 11343 | New_Name => Make_TSS_Name (Typ, TSS_Nam)), |
1735e55d AC |
11344 | Name => New_Occurrence_Of (Nam, Loc)); |
11345 | ||
11346 | Snam : constant Entity_Id := | |
11347 | Defining_Unit_Name (Specification (TSS_Node)); | |
11348 | ||
11349 | begin | |
11350 | if Nkind (Spec) = N_Function_Specification then | |
11351 | Set_Ekind (Snam, E_Function); | |
3eb8fddc | 11352 | Set_Etype (Snam, Entity (Result_Definition (Spec))); |
1735e55d AC |
11353 | else |
11354 | Set_Ekind (Snam, E_Procedure); | |
11355 | Set_Etype (Snam, Standard_Void_Type); | |
11356 | end if; | |
bd7f7a65 | 11357 | |
1735e55d AC |
11358 | Set_TSS (Typ, Snam); |
11359 | end Set_Renaming_TSS; | |
11360 | ||
82c80734 RD |
11361 | ---------------------------------------------- |
11362 | -- Specific_Add_Obj_RPC_Receiver_Completion -- | |
11363 | ---------------------------------------------- | |
11364 | ||
11365 | procedure Specific_Add_Obj_RPC_Receiver_Completion | |
11366 | (Loc : Source_Ptr; | |
11367 | Decls : List_Id; | |
11368 | RPC_Receiver : Entity_Id; | |
d693e39d TQ |
11369 | Stub_Elements : Stub_Structure) |
11370 | is | |
82c80734 RD |
11371 | begin |
11372 | case Get_PCS_Name is | |
11373 | when Name_PolyORB_DSA => | |
c6f39437 AC |
11374 | PolyORB_Support.Add_Obj_RPC_Receiver_Completion |
11375 | (Loc, Decls, RPC_Receiver, Stub_Elements); | |
d8f43ee6 | 11376 | |
82c80734 | 11377 | when others => |
c6f39437 AC |
11378 | GARLIC_Support.Add_Obj_RPC_Receiver_Completion |
11379 | (Loc, Decls, RPC_Receiver, Stub_Elements); | |
82c80734 RD |
11380 | end case; |
11381 | end Specific_Add_Obj_RPC_Receiver_Completion; | |
11382 | ||
1735e55d AC |
11383 | -------------------------------- |
11384 | -- Specific_Add_RACW_Features -- | |
11385 | -------------------------------- | |
11386 | ||
11387 | procedure Specific_Add_RACW_Features | |
11388 | (RACW_Type : Entity_Id; | |
11389 | Desig : Entity_Id; | |
11390 | Stub_Type : Entity_Id; | |
11391 | Stub_Type_Access : Entity_Id; | |
11392 | RPC_Receiver_Decl : Node_Id; | |
d693e39d TQ |
11393 | Body_Decls : List_Id) |
11394 | is | |
1735e55d AC |
11395 | begin |
11396 | case Get_PCS_Name is | |
11397 | when Name_PolyORB_DSA => | |
d693e39d TQ |
11398 | PolyORB_Support.Add_RACW_Features |
11399 | (RACW_Type, | |
11400 | Desig, | |
11401 | Stub_Type, | |
11402 | Stub_Type_Access, | |
11403 | RPC_Receiver_Decl, | |
11404 | Body_Decls); | |
1735e55d AC |
11405 | |
11406 | when others => | |
d693e39d TQ |
11407 | GARLIC_Support.Add_RACW_Features |
11408 | (RACW_Type, | |
11409 | Stub_Type, | |
11410 | Stub_Type_Access, | |
11411 | RPC_Receiver_Decl, | |
11412 | Body_Decls); | |
1735e55d AC |
11413 | end case; |
11414 | end Specific_Add_RACW_Features; | |
11415 | ||
11416 | -------------------------------- | |
11417 | -- Specific_Add_RAST_Features -- | |
11418 | -------------------------------- | |
11419 | ||
11420 | procedure Specific_Add_RAST_Features | |
11421 | (Vis_Decl : Node_Id; | |
d693e39d TQ |
11422 | RAS_Type : Entity_Id) |
11423 | is | |
1735e55d AC |
11424 | begin |
11425 | case Get_PCS_Name is | |
11426 | when Name_PolyORB_DSA => | |
c857f5ed | 11427 | PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type); |
d8f43ee6 | 11428 | |
1735e55d | 11429 | when others => |
c857f5ed | 11430 | GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type); |
1735e55d AC |
11431 | end case; |
11432 | end Specific_Add_RAST_Features; | |
11433 | ||
16db96c5 AC |
11434 | -------------------------------------------------- |
11435 | -- Specific_Add_Receiving_Stubs_To_Declarations -- | |
11436 | -------------------------------------------------- | |
11437 | ||
11438 | procedure Specific_Add_Receiving_Stubs_To_Declarations | |
11439 | (Pkg_Spec : Node_Id; | |
8aa23fe3 TQ |
11440 | Decls : List_Id; |
11441 | Stmts : List_Id) | |
16db96c5 AC |
11442 | is |
11443 | begin | |
11444 | case Get_PCS_Name is | |
11445 | when Name_PolyORB_DSA => | |
d693e39d TQ |
11446 | PolyORB_Support.Add_Receiving_Stubs_To_Declarations |
11447 | (Pkg_Spec, Decls, Stmts); | |
d8f43ee6 | 11448 | |
16db96c5 | 11449 | when others => |
d693e39d TQ |
11450 | GARLIC_Support.Add_Receiving_Stubs_To_Declarations |
11451 | (Pkg_Spec, Decls, Stmts); | |
16db96c5 AC |
11452 | end case; |
11453 | end Specific_Add_Receiving_Stubs_To_Declarations; | |
11454 | ||
bd7f7a65 AC |
11455 | ------------------------------------------ |
11456 | -- Specific_Build_General_Calling_Stubs -- | |
11457 | ------------------------------------------ | |
11458 | ||
11459 | procedure Specific_Build_General_Calling_Stubs | |
11460 | (Decls : List_Id; | |
11461 | Statements : List_Id; | |
11462 | Target : RPC_Target; | |
11463 | Subprogram_Id : Node_Id; | |
11464 | Asynchronous : Node_Id := Empty; | |
11465 | Is_Known_Asynchronous : Boolean := False; | |
11466 | Is_Known_Non_Asynchronous : Boolean := False; | |
11467 | Is_Function : Boolean; | |
11468 | Spec : Node_Id; | |
11469 | Stub_Type : Entity_Id := Empty; | |
11470 | RACW_Type : Entity_Id := Empty; | |
11471 | Nod : Node_Id) | |
11472 | is | |
11473 | begin | |
11474 | case Get_PCS_Name is | |
11475 | when Name_PolyORB_DSA => | |
d693e39d TQ |
11476 | PolyORB_Support.Build_General_Calling_Stubs |
11477 | (Decls, | |
11478 | Statements, | |
11479 | Target.Object, | |
11480 | Subprogram_Id, | |
11481 | Asynchronous, | |
11482 | Is_Known_Asynchronous, | |
11483 | Is_Known_Non_Asynchronous, | |
11484 | Is_Function, | |
11485 | Spec, | |
11486 | Stub_Type, | |
11487 | RACW_Type, | |
11488 | Nod); | |
11489 | ||
bd7f7a65 | 11490 | when others => |
d693e39d TQ |
11491 | GARLIC_Support.Build_General_Calling_Stubs |
11492 | (Decls, | |
11493 | Statements, | |
11494 | Target.Partition, | |
11495 | Target.RPC_Receiver, | |
11496 | Subprogram_Id, | |
11497 | Asynchronous, | |
11498 | Is_Known_Asynchronous, | |
11499 | Is_Known_Non_Asynchronous, | |
11500 | Is_Function, | |
11501 | Spec, | |
11502 | Stub_Type, | |
11503 | RACW_Type, | |
11504 | Nod); | |
bd7f7a65 AC |
11505 | end case; |
11506 | end Specific_Build_General_Calling_Stubs; | |
11507 | ||
16db96c5 AC |
11508 | -------------------------------------- |
11509 | -- Specific_Build_RPC_Receiver_Body -- | |
11510 | -------------------------------------- | |
11511 | ||
11512 | procedure Specific_Build_RPC_Receiver_Body | |
11513 | (RPC_Receiver : Entity_Id; | |
11514 | Request : out Entity_Id; | |
11515 | Subp_Id : out Entity_Id; | |
11516 | Subp_Index : out Entity_Id; | |
11517 | Stmts : out List_Id; | |
11518 | Decl : out Node_Id) | |
11519 | is | |
11520 | begin | |
11521 | case Get_PCS_Name is | |
11522 | when Name_PolyORB_DSA => | |
11523 | PolyORB_Support.Build_RPC_Receiver_Body | |
11524 | (RPC_Receiver, | |
11525 | Request, | |
11526 | Subp_Id, | |
11527 | Subp_Index, | |
11528 | Stmts, | |
11529 | Decl); | |
d693e39d | 11530 | |
16db96c5 AC |
11531 | when others => |
11532 | GARLIC_Support.Build_RPC_Receiver_Body | |
11533 | (RPC_Receiver, | |
11534 | Request, | |
11535 | Subp_Id, | |
11536 | Subp_Index, | |
11537 | Stmts, | |
11538 | Decl); | |
11539 | end case; | |
11540 | end Specific_Build_RPC_Receiver_Body; | |
11541 | ||
bd7f7a65 AC |
11542 | -------------------------------- |
11543 | -- Specific_Build_Stub_Target -- | |
11544 | -------------------------------- | |
11545 | ||
11546 | function Specific_Build_Stub_Target | |
11547 | (Loc : Source_Ptr; | |
11548 | Decls : List_Id; | |
11549 | RCI_Locator : Entity_Id; | |
6ce0c3f5 TQ |
11550 | Controlling_Parameter : Entity_Id) return RPC_Target |
11551 | is | |
bd7f7a65 AC |
11552 | begin |
11553 | case Get_PCS_Name is | |
11554 | when Name_PolyORB_DSA => | |
c6f39437 AC |
11555 | return |
11556 | PolyORB_Support.Build_Stub_Target | |
11557 | (Loc, Decls, RCI_Locator, Controlling_Parameter); | |
d693e39d | 11558 | |
bd7f7a65 | 11559 | when others => |
c6f39437 AC |
11560 | return |
11561 | GARLIC_Support.Build_Stub_Target | |
11562 | (Loc, Decls, RCI_Locator, Controlling_Parameter); | |
bd7f7a65 AC |
11563 | end case; |
11564 | end Specific_Build_Stub_Target; | |
11565 | ||
a3068ca6 AC |
11566 | -------------------------------- |
11567 | -- Specific_RPC_Receiver_Decl -- | |
11568 | -------------------------------- | |
bd7f7a65 | 11569 | |
a3068ca6 AC |
11570 | function Specific_RPC_Receiver_Decl |
11571 | (RACW_Type : Entity_Id) return Node_Id | |
bd7f7a65 AC |
11572 | is |
11573 | begin | |
11574 | case Get_PCS_Name is | |
11575 | when Name_PolyORB_DSA => | |
a3068ca6 | 11576 | return PolyORB_Support.RPC_Receiver_Decl (RACW_Type); |
d693e39d | 11577 | |
bd7f7a65 | 11578 | when others => |
a3068ca6 | 11579 | return GARLIC_Support.RPC_Receiver_Decl (RACW_Type); |
bd7f7a65 | 11580 | end case; |
a3068ca6 | 11581 | end Specific_RPC_Receiver_Decl; |
bd7f7a65 | 11582 | |
c6f39437 AC |
11583 | ----------------------------------------------- |
11584 | -- Specific_Build_Subprogram_Receiving_Stubs -- | |
11585 | ----------------------------------------------- | |
11586 | ||
16db96c5 AC |
11587 | function Specific_Build_Subprogram_Receiving_Stubs |
11588 | (Vis_Decl : Node_Id; | |
11589 | Asynchronous : Boolean; | |
11590 | Dynamically_Asynchronous : Boolean := False; | |
11591 | Stub_Type : Entity_Id := Empty; | |
11592 | RACW_Type : Entity_Id := Empty; | |
6ce0c3f5 TQ |
11593 | Parent_Primitive : Entity_Id := Empty) return Node_Id |
11594 | is | |
16db96c5 AC |
11595 | begin |
11596 | case Get_PCS_Name is | |
11597 | when Name_PolyORB_DSA => | |
c6f39437 AC |
11598 | return |
11599 | PolyORB_Support.Build_Subprogram_Receiving_Stubs | |
11600 | (Vis_Decl, | |
11601 | Asynchronous, | |
11602 | Dynamically_Asynchronous, | |
11603 | Stub_Type, | |
11604 | RACW_Type, | |
11605 | Parent_Primitive); | |
d693e39d | 11606 | |
16db96c5 | 11607 | when others => |
c6f39437 AC |
11608 | return |
11609 | GARLIC_Support.Build_Subprogram_Receiving_Stubs | |
11610 | (Vis_Decl, | |
11611 | Asynchronous, | |
11612 | Dynamically_Asynchronous, | |
11613 | Stub_Type, | |
11614 | RACW_Type, | |
11615 | Parent_Primitive); | |
16db96c5 AC |
11616 | end case; |
11617 | end Specific_Build_Subprogram_Receiving_Stubs; | |
11618 | ||
7f0b5314 TQ |
11619 | ------------------------------- |
11620 | -- Transmit_As_Unconstrained -- | |
11621 | ------------------------------- | |
11622 | ||
11623 | function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is | |
11624 | begin | |
11625 | return | |
11626 | not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ)) | |
11627 | or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ)); | |
11628 | end Transmit_As_Unconstrained; | |
11629 | ||
c885d7a1 AC |
11630 | -------------------------- |
11631 | -- Underlying_RACW_Type -- | |
11632 | -------------------------- | |
11633 | ||
11634 | function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is | |
11635 | Record_Type : Entity_Id; | |
11636 | ||
11637 | begin | |
11638 | if Ekind (RAS_Typ) = E_Record_Type then | |
11639 | Record_Type := RAS_Typ; | |
11640 | else | |
11641 | pragma Assert (Present (Equivalent_Type (RAS_Typ))); | |
11642 | Record_Type := Equivalent_Type (RAS_Typ); | |
11643 | end if; | |
11644 | ||
11645 | return | |
d693e39d TQ |
11646 | Etype (Subtype_Indication |
11647 | (Component_Definition | |
11648 | (First (Component_Items | |
11649 | (Component_List | |
11650 | (Type_Definition | |
11651 | (Declaration_Node (Record_Type)))))))); | |
c885d7a1 AC |
11652 | end Underlying_RACW_Type; |
11653 | ||
70482933 | 11654 | end Exp_Dist; |