|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S E M _ D I S T --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
|
|
|
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- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
|
17 -- for more details. You should have received a copy of the GNU General --
|
|
|
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
|
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
23 -- --
|
|
|
24 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 with Atree; use Atree;
|
|
|
27 with Casing; use Casing;
|
|
|
28 with Einfo; use Einfo;
|
|
|
29 with Errout; use Errout;
|
|
|
30 with Exp_Dist; use Exp_Dist;
|
|
|
31 with Exp_Tss; use Exp_Tss;
|
|
|
32 with Nlists; use Nlists;
|
|
|
33 with Nmake; use Nmake;
|
|
|
34 with Namet; use Namet;
|
|
|
35 with Opt; use Opt;
|
|
|
36 with Rtsfind; use Rtsfind;
|
|
|
37 with Sem; use Sem;
|
|
|
38 with Sem_Aux; use Sem_Aux;
|
|
|
39 with Sem_Disp; use Sem_Disp;
|
|
|
40 with Sem_Eval; use Sem_Eval;
|
|
|
41 with Sem_Res; use Sem_Res;
|
|
|
42 with Sem_Util; use Sem_Util;
|
|
|
43 with Sinfo; use Sinfo;
|
|
|
44 with Stand; use Stand;
|
|
|
45 with Stringt; use Stringt;
|
|
|
46 with Tbuild; use Tbuild;
|
|
|
47 with Uintp; use Uintp;
|
|
|
48
|
|
|
49 package body Sem_Dist is
|
|
|
50
|
|
|
51 -----------------------
|
|
|
52 -- Local Subprograms --
|
|
|
53 -----------------------
|
|
|
54
|
|
|
55 procedure RAS_E_Dereference (Pref : Node_Id);
|
|
|
56 -- Handles explicit dereference of Remote Access to Subprograms
|
|
|
57
|
|
|
58 function Full_Qualified_Name (E : Entity_Id) return String_Id;
|
|
|
59 -- returns the full qualified name of the entity in lower case
|
|
|
60
|
|
|
61 -------------------------
|
|
|
62 -- Add_Stub_Constructs --
|
|
|
63 -------------------------
|
|
|
64
|
|
|
65 procedure Add_Stub_Constructs (N : Node_Id) is
|
|
|
66 U : constant Node_Id := Unit (N);
|
|
|
67 Spec : Entity_Id := Empty;
|
|
|
68
|
|
|
69 Exp : Node_Id := U;
|
|
|
70 -- Unit that will be expanded
|
|
|
71
|
|
|
72 begin
|
|
|
73 pragma Assert (Distribution_Stub_Mode /= No_Stubs);
|
|
|
74
|
|
|
75 if Nkind (U) = N_Package_Declaration then
|
|
|
76 Spec := Defining_Entity (Specification (U));
|
|
|
77
|
|
|
78 elsif Nkind (U) = N_Package_Body then
|
|
|
79 Spec := Corresponding_Spec (U);
|
|
|
80
|
|
|
81 else pragma Assert (Nkind (U) = N_Package_Instantiation);
|
|
|
82 Exp := Instance_Spec (U);
|
|
|
83 Spec := Defining_Entity (Specification (Exp));
|
|
|
84 end if;
|
|
|
85
|
|
|
86 pragma Assert (Is_Shared_Passive (Spec)
|
|
|
87 or else Is_Remote_Call_Interface (Spec));
|
|
|
88
|
|
|
89 if Distribution_Stub_Mode = Generate_Caller_Stub_Body then
|
|
|
90 if Is_Shared_Passive (Spec) then
|
|
|
91 null;
|
|
|
92 elsif Nkind (U) = N_Package_Body then
|
|
|
93 Error_Msg_N
|
|
|
94 ("Specification file expected from command line", U);
|
|
|
95 else
|
|
|
96 Expand_Calling_Stubs_Bodies (Exp);
|
|
|
97 end if;
|
|
|
98
|
|
|
99 else
|
|
|
100 if Is_Shared_Passive (Spec) then
|
|
|
101 Build_Passive_Partition_Stub (Exp);
|
|
|
102 else
|
|
|
103 Expand_Receiving_Stubs_Bodies (Exp);
|
|
|
104 end if;
|
|
|
105
|
|
|
106 end if;
|
|
|
107 end Add_Stub_Constructs;
|
|
|
108
|
|
|
109 ---------------------------------------
|
|
|
110 -- Build_RAS_Primitive_Specification --
|
|
|
111 ---------------------------------------
|
|
|
112
|
|
|
113 function Build_RAS_Primitive_Specification
|
|
|
114 (Subp_Spec : Node_Id;
|
|
|
115 Remote_Object_Type : Node_Id) return Node_Id
|
|
|
116 is
|
|
|
117 Loc : constant Source_Ptr := Sloc (Subp_Spec);
|
|
|
118
|
|
|
119 Primitive_Spec : constant Node_Id :=
|
|
|
120 Copy_Specification (Loc,
|
|
|
121 Spec => Subp_Spec,
|
|
|
122 New_Name => Name_uCall);
|
|
|
123
|
|
|
124 Subtype_Mark_For_Self : Node_Id;
|
|
|
125
|
|
|
126 begin
|
|
|
127 if No (Parameter_Specifications (Primitive_Spec)) then
|
|
|
128 Set_Parameter_Specifications (Primitive_Spec, New_List);
|
|
|
129 end if;
|
|
|
130
|
|
|
131 if Nkind (Remote_Object_Type) in N_Entity then
|
|
|
132 Subtype_Mark_For_Self :=
|
|
|
133 New_Occurrence_Of (Remote_Object_Type, Loc);
|
|
|
134 else
|
|
|
135 Subtype_Mark_For_Self := Remote_Object_Type;
|
|
|
136 end if;
|
|
|
137
|
|
|
138 Prepend_To (
|
|
|
139 Parameter_Specifications (Primitive_Spec),
|
|
|
140 Make_Parameter_Specification (Loc,
|
|
|
141 Defining_Identifier =>
|
|
|
142 Make_Defining_Identifier (Loc, Name_uS),
|
|
|
143 Parameter_Type =>
|
|
|
144 Make_Access_Definition (Loc,
|
|
|
145 Subtype_Mark =>
|
|
|
146 Subtype_Mark_For_Self)));
|
|
|
147
|
|
|
148 -- Trick later semantic analysis into considering this operation as a
|
|
|
149 -- primitive (dispatching) operation of tagged type Obj_Type.
|
|
|
150
|
|
|
151 Set_Comes_From_Source (
|
|
|
152 Defining_Unit_Name (Primitive_Spec), True);
|
|
|
153
|
|
|
154 return Primitive_Spec;
|
|
|
155 end Build_RAS_Primitive_Specification;
|
|
|
156
|
|
|
157 -------------------------
|
|
|
158 -- Full_Qualified_Name --
|
|
|
159 -------------------------
|
|
|
160
|
|
|
161 function Full_Qualified_Name (E : Entity_Id) return String_Id is
|
|
|
162 Ent : Entity_Id := E;
|
|
|
163 Parent_Name : String_Id := No_String;
|
|
|
164
|
|
|
165 begin
|
|
|
166 -- Deals properly with child units
|
|
|
167
|
|
|
168 if Nkind (Ent) = N_Defining_Program_Unit_Name then
|
|
|
169 Ent := Defining_Identifier (Ent);
|
|
|
170 end if;
|
|
|
171
|
|
|
172 -- Compute recursively the qualification (only "Standard" has no scope)
|
|
|
173
|
|
|
174 if Present (Scope (Scope (Ent))) then
|
|
|
175 Parent_Name := Full_Qualified_Name (Scope (Ent));
|
|
|
176 end if;
|
|
|
177
|
|
|
178 -- Every entity should have a name except some expanded blocks. Do not
|
|
|
179 -- bother about those.
|
|
|
180
|
|
|
181 if Chars (Ent) = No_Name then
|
|
|
182 return Parent_Name;
|
|
|
183 end if;
|
|
|
184
|
|
|
185 -- Add a period between Name and qualification
|
|
|
186
|
|
|
187 if Parent_Name /= No_String then
|
|
|
188 Start_String (Parent_Name);
|
|
|
189 Store_String_Char (Get_Char_Code ('.'));
|
|
|
190 else
|
|
|
191 Start_String;
|
|
|
192 end if;
|
|
|
193
|
|
|
194 -- Generates the entity name in upper case
|
|
|
195
|
|
|
196 Get_Name_String (Chars (Ent));
|
|
|
197 Set_Casing (All_Lower_Case);
|
|
|
198 Store_String_Chars (Name_Buffer (1 .. Name_Len));
|
|
|
199 return End_String;
|
|
|
200 end Full_Qualified_Name;
|
|
|
201
|
|
|
202 ------------------
|
|
|
203 -- Get_PCS_Name --
|
|
|
204 ------------------
|
|
|
205
|
|
|
206 function Get_PCS_Name return PCS_Names is
|
|
|
207 begin
|
|
|
208 return
|
|
|
209 Chars (Entity (Expression (Parent (RTE (RE_DSA_Implementation)))));
|
|
|
210 end Get_PCS_Name;
|
|
|
211
|
|
|
212 ---------------------
|
|
|
213 -- Get_PCS_Version --
|
|
|
214 ---------------------
|
|
|
215
|
|
|
216 function Get_PCS_Version return Int is
|
|
|
217 PCS_Version_Entity : Entity_Id;
|
|
|
218 PCS_Version : Int;
|
|
|
219
|
|
|
220 begin
|
|
|
221 if RTE_Available (RE_PCS_Version) then
|
|
|
222 PCS_Version_Entity := RTE (RE_PCS_Version);
|
|
|
223 pragma Assert (Ekind (PCS_Version_Entity) = E_Named_Integer);
|
|
|
224 PCS_Version :=
|
|
|
225 UI_To_Int (Expr_Value (Constant_Value (PCS_Version_Entity)));
|
|
|
226
|
|
|
227 else
|
|
|
228 -- Case of System.Partition_Interface.PCS_Version not found:
|
|
|
229 -- return a null version.
|
|
|
230
|
|
|
231 PCS_Version := 0;
|
|
|
232 end if;
|
|
|
233
|
|
|
234 return PCS_Version;
|
|
|
235 end Get_PCS_Version;
|
|
|
236
|
|
|
237 ------------------------
|
|
|
238 -- Is_All_Remote_Call --
|
|
|
239 ------------------------
|
|
|
240
|
|
|
241 function Is_All_Remote_Call (N : Node_Id) return Boolean is
|
|
|
242 Par : Node_Id;
|
|
|
243
|
|
|
244 begin
|
|
|
245 if Nkind (N) in N_Subprogram_Call
|
|
|
246 and then Nkind (Name (N)) in N_Has_Entity
|
|
|
247 and then Is_Remote_Call_Interface (Entity (Name (N)))
|
|
|
248 and then Has_All_Calls_Remote (Scope (Entity (Name (N))))
|
|
|
249 and then Comes_From_Source (N)
|
|
|
250 then
|
|
|
251 Par := Parent (Entity (Name (N)));
|
|
|
252 while Present (Par)
|
|
|
253 and then (Nkind (Par) /= N_Package_Specification
|
|
|
254 or else Is_Wrapper_Package (Defining_Entity (Par)))
|
|
|
255 loop
|
|
|
256 Par := Parent (Par);
|
|
|
257 end loop;
|
|
|
258
|
|
|
259 if Present (Par) then
|
|
|
260 return
|
|
|
261 not Scope_Within_Or_Same (Current_Scope, Defining_Entity (Par));
|
|
|
262 else
|
|
|
263 return False;
|
|
|
264 end if;
|
|
|
265 else
|
|
|
266 return False;
|
|
|
267 end if;
|
|
|
268 end Is_All_Remote_Call;
|
|
|
269
|
|
|
270 ---------------------------------
|
|
|
271 -- Is_RACW_Stub_Type_Operation --
|
|
|
272 ---------------------------------
|
|
|
273
|
|
|
274 function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean is
|
|
|
275 Typ : Entity_Id;
|
|
|
276
|
|
|
277 begin
|
|
|
278 case Ekind (Op) is
|
|
|
279 when E_Function
|
|
|
280 | E_Procedure
|
|
|
281 =>
|
|
|
282 Typ := Find_Dispatching_Type (Op);
|
|
|
283
|
|
|
284 return
|
|
|
285 Present (Typ)
|
|
|
286 and then Is_RACW_Stub_Type (Typ)
|
|
|
287 and then not Is_Internal (Op);
|
|
|
288
|
|
|
289 when others =>
|
|
|
290 return False;
|
|
|
291 end case;
|
|
|
292 end Is_RACW_Stub_Type_Operation;
|
|
|
293
|
|
|
294 ---------------------------------
|
|
|
295 -- Is_Valid_Remote_Object_Type --
|
|
|
296 ---------------------------------
|
|
|
297
|
|
|
298 function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean is
|
|
|
299 P : constant Node_Id := Parent (E);
|
|
|
300
|
|
|
301 begin
|
|
|
302 pragma Assert (Is_Tagged_Type (E));
|
|
|
303
|
|
|
304 -- Simple case: a limited private type
|
|
|
305
|
|
|
306 if Nkind (P) = N_Private_Type_Declaration
|
|
|
307 and then Is_Limited_Record (E)
|
|
|
308 then
|
|
|
309 return True;
|
|
|
310
|
|
|
311 -- AI05-0060 (Binding Interpretation): A limited interface is a legal
|
|
|
312 -- ancestor for the designated type of an RACW type.
|
|
|
313
|
|
|
314 elsif Is_Limited_Record (E) and then Is_Limited_Interface (E) then
|
|
|
315 return True;
|
|
|
316
|
|
|
317 -- A generic tagged limited type is a valid candidate. Limitedness will
|
|
|
318 -- be checked again on the actual at instantiation point.
|
|
|
319
|
|
|
320 elsif Nkind (P) = N_Formal_Type_Declaration
|
|
|
321 and then Ekind (E) = E_Record_Type_With_Private
|
|
|
322 and then Is_Generic_Type (E)
|
|
|
323 and then Is_Limited_Record (E)
|
|
|
324 then
|
|
|
325 return True;
|
|
|
326
|
|
|
327 -- A private extension declaration is a valid candidate if its parent
|
|
|
328 -- type is.
|
|
|
329
|
|
|
330 elsif Nkind (P) = N_Private_Extension_Declaration then
|
|
|
331 return Is_Valid_Remote_Object_Type (Etype (E));
|
|
|
332
|
|
|
333 else
|
|
|
334 return False;
|
|
|
335 end if;
|
|
|
336 end Is_Valid_Remote_Object_Type;
|
|
|
337
|
|
|
338 ------------------------------------
|
|
|
339 -- Package_Specification_Of_Scope --
|
|
|
340 ------------------------------------
|
|
|
341
|
|
|
342 function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is
|
|
|
343 N : Node_Id;
|
|
|
344
|
|
|
345 begin
|
|
|
346 N := Parent (E);
|
|
|
347 while Nkind (N) /= N_Package_Specification loop
|
|
|
348 N := Parent (N);
|
|
|
349 end loop;
|
|
|
350
|
|
|
351 return N;
|
|
|
352 end Package_Specification_Of_Scope;
|
|
|
353
|
|
|
354 --------------------------
|
|
|
355 -- Process_Partition_ID --
|
|
|
356 --------------------------
|
|
|
357
|
|
|
358 procedure Process_Partition_Id (N : Node_Id) is
|
|
|
359 Loc : constant Source_Ptr := Sloc (N);
|
|
|
360 Ety : Entity_Id;
|
|
|
361 Get_Pt_Id : Node_Id;
|
|
|
362 Get_Pt_Id_Call : Node_Id;
|
|
|
363 Prefix_String : String_Id;
|
|
|
364 Typ : constant Entity_Id := Etype (N);
|
|
|
365
|
|
|
366 begin
|
|
|
367 -- In case prefix is not a library unit entity, get the entity
|
|
|
368 -- of library unit.
|
|
|
369
|
|
|
370 Ety := Entity (Prefix (N));
|
|
|
371 while (Present (Scope (Ety))
|
|
|
372 and then Scope (Ety) /= Standard_Standard)
|
|
|
373 and not Is_Child_Unit (Ety)
|
|
|
374 loop
|
|
|
375 Ety := Scope (Ety);
|
|
|
376 end loop;
|
|
|
377
|
|
|
378 -- Retrieve the proper function to call
|
|
|
379
|
|
|
380 if Is_Remote_Call_Interface (Ety) then
|
|
|
381 Get_Pt_Id := New_Occurrence_Of
|
|
|
382 (RTE (RE_Get_Active_Partition_Id), Loc);
|
|
|
383
|
|
|
384 elsif Is_Shared_Passive (Ety) then
|
|
|
385 Get_Pt_Id := New_Occurrence_Of
|
|
|
386 (RTE (RE_Get_Passive_Partition_Id), Loc);
|
|
|
387
|
|
|
388 else
|
|
|
389 Get_Pt_Id := New_Occurrence_Of
|
|
|
390 (RTE (RE_Get_Local_Partition_Id), Loc);
|
|
|
391 end if;
|
|
|
392
|
|
|
393 -- Get and store the String_Id corresponding to the name of the
|
|
|
394 -- library unit whose Partition_Id is needed.
|
|
|
395
|
|
|
396 Get_Library_Unit_Name_String (Unit_Declaration_Node (Ety));
|
|
|
397 Prefix_String := String_From_Name_Buffer;
|
|
|
398
|
|
|
399 -- Build the function call which will replace the attribute
|
|
|
400
|
|
|
401 if Is_Remote_Call_Interface (Ety) or else Is_Shared_Passive (Ety) then
|
|
|
402 Get_Pt_Id_Call :=
|
|
|
403 Make_Function_Call (Loc,
|
|
|
404 Name => Get_Pt_Id,
|
|
|
405 Parameter_Associations =>
|
|
|
406 New_List (Make_String_Literal (Loc, Prefix_String)));
|
|
|
407
|
|
|
408 else
|
|
|
409 Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id);
|
|
|
410 end if;
|
|
|
411
|
|
|
412 -- Replace the attribute node by a conversion of the function call
|
|
|
413 -- to the target type.
|
|
|
414
|
|
|
415 Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call));
|
|
|
416 Analyze_And_Resolve (N, Typ);
|
|
|
417 end Process_Partition_Id;
|
|
|
418
|
|
|
419 ----------------------------------
|
|
|
420 -- Process_Remote_AST_Attribute --
|
|
|
421 ----------------------------------
|
|
|
422
|
|
|
423 procedure Process_Remote_AST_Attribute
|
|
|
424 (N : Node_Id;
|
|
|
425 New_Type : Entity_Id)
|
|
|
426 is
|
|
|
427 Loc : constant Source_Ptr := Sloc (N);
|
|
|
428 Remote_Subp : Entity_Id;
|
|
|
429 Tick_Access_Conv_Call : Node_Id;
|
|
|
430 Remote_Subp_Decl : Node_Id;
|
|
|
431 RS_Pkg_Specif : Node_Id;
|
|
|
432 RS_Pkg_E : Entity_Id;
|
|
|
433 RAS_Type : Entity_Id := New_Type;
|
|
|
434 Async_E : Entity_Id;
|
|
|
435 All_Calls_Remote_E : Entity_Id;
|
|
|
436 Attribute_Subp : Entity_Id;
|
|
|
437
|
|
|
438 begin
|
|
|
439 -- Check if we have to expand the access attribute
|
|
|
440
|
|
|
441 Remote_Subp := Entity (Prefix (N));
|
|
|
442
|
|
|
443 if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
|
|
|
444 return;
|
|
|
445 end if;
|
|
|
446
|
|
|
447 if Ekind (RAS_Type) /= E_Record_Type then
|
|
|
448 RAS_Type := Equivalent_Type (RAS_Type);
|
|
|
449 end if;
|
|
|
450
|
|
|
451 Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access);
|
|
|
452 pragma Assert (Present (Attribute_Subp));
|
|
|
453 Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
|
|
|
454
|
|
|
455 if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then
|
|
|
456 Remote_Subp := Corresponding_Spec (Remote_Subp_Decl);
|
|
|
457 Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
|
|
|
458 end if;
|
|
|
459
|
|
|
460 RS_Pkg_Specif := Parent (Remote_Subp_Decl);
|
|
|
461 RS_Pkg_E := Defining_Entity (RS_Pkg_Specif);
|
|
|
462
|
|
|
463 Async_E :=
|
|
|
464 Boolean_Literals (Ekind (Remote_Subp) = E_Procedure
|
|
|
465 and then Is_Asynchronous (Remote_Subp));
|
|
|
466
|
|
|
467 All_Calls_Remote_E :=
|
|
|
468 Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E));
|
|
|
469
|
|
|
470 Tick_Access_Conv_Call :=
|
|
|
471 Make_Function_Call (Loc,
|
|
|
472 Name => New_Occurrence_Of (Attribute_Subp, Loc),
|
|
|
473 Parameter_Associations =>
|
|
|
474 New_List (
|
|
|
475 Make_String_Literal (Loc,
|
|
|
476 Strval => Full_Qualified_Name (RS_Pkg_E)),
|
|
|
477 Build_Subprogram_Id (Loc, Remote_Subp),
|
|
|
478 New_Occurrence_Of (Async_E, Loc),
|
|
|
479 New_Occurrence_Of (All_Calls_Remote_E, Loc)));
|
|
|
480
|
|
|
481 Rewrite (N, Tick_Access_Conv_Call);
|
|
|
482 Analyze_And_Resolve (N, RAS_Type);
|
|
|
483 end Process_Remote_AST_Attribute;
|
|
|
484
|
|
|
485 ------------------------------------
|
|
|
486 -- Process_Remote_AST_Declaration --
|
|
|
487 ------------------------------------
|
|
|
488
|
|
|
489 procedure Process_Remote_AST_Declaration (N : Node_Id) is
|
|
|
490 Loc : constant Source_Ptr := Sloc (N);
|
|
|
491 User_Type : constant Node_Id := Defining_Identifier (N);
|
|
|
492 Scop : constant Entity_Id := Scope (User_Type);
|
|
|
493 Is_RCI : constant Boolean := Is_Remote_Call_Interface (Scop);
|
|
|
494 Is_RT : constant Boolean := Is_Remote_Types (Scop);
|
|
|
495 Type_Def : constant Node_Id := Type_Definition (N);
|
|
|
496 Parameter : Node_Id;
|
|
|
497
|
|
|
498 Is_Degenerate : Boolean;
|
|
|
499 -- True iff this RAS has an access formal parameter (see
|
|
|
500 -- Exp_Dist.Add_RAS_Dereference_TSS for details).
|
|
|
501
|
|
|
502 Subpkg : constant Entity_Id := Make_Temporary (Loc, 'S');
|
|
|
503 Subpkg_Decl : Node_Id;
|
|
|
504 Subpkg_Body : Node_Id;
|
|
|
505 Vis_Decls : constant List_Id := New_List;
|
|
|
506 Priv_Decls : constant List_Id := New_List;
|
|
|
507
|
|
|
508 Obj_Type : constant Entity_Id :=
|
|
|
509 Make_Defining_Identifier (Loc,
|
|
|
510 New_External_Name (Chars (User_Type), 'R'));
|
|
|
511
|
|
|
512 Full_Obj_Type : constant Entity_Id :=
|
|
|
513 Make_Defining_Identifier (Loc, Chars (Obj_Type));
|
|
|
514
|
|
|
515 RACW_Type : constant Entity_Id :=
|
|
|
516 Make_Defining_Identifier (Loc,
|
|
|
517 New_External_Name (Chars (User_Type), 'P'));
|
|
|
518
|
|
|
519 Fat_Type : constant Entity_Id :=
|
|
|
520 Make_Defining_Identifier (Loc, Chars (User_Type));
|
|
|
521
|
|
|
522 Fat_Type_Decl : Node_Id;
|
|
|
523
|
|
|
524 begin
|
|
|
525 Is_Degenerate := False;
|
|
|
526 Parameter := First (Parameter_Specifications (Type_Def));
|
|
|
527 while Present (Parameter) loop
|
|
|
528 if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
|
|
|
529 Error_Msg_N
|
|
|
530 ("formal parameter& has anonymous access type??",
|
|
|
531 Defining_Identifier (Parameter));
|
|
|
532 Is_Degenerate := True;
|
|
|
533 exit;
|
|
|
534 end if;
|
|
|
535
|
|
|
536 Next (Parameter);
|
|
|
537 end loop;
|
|
|
538
|
|
|
539 if Is_Degenerate then
|
|
|
540 Error_Msg_NE
|
|
|
541 ("remote access-to-subprogram type& can only be null??",
|
|
|
542 Defining_Identifier (Parameter), User_Type);
|
|
|
543
|
|
|
544 -- The only legal value for a RAS with a formal parameter of an
|
|
|
545 -- anonymous access type is null, because it cannot be subtype-
|
|
|
546 -- conformant with any legal remote subprogram declaration. In this
|
|
|
547 -- case, we cannot generate a corresponding primitive operation.
|
|
|
548
|
|
|
549 end if;
|
|
|
550
|
|
|
551 if Get_PCS_Name = Name_No_DSA then
|
|
|
552 return;
|
|
|
553 end if;
|
|
|
554
|
|
|
555 -- The tagged private type, primitive operation and RACW type associated
|
|
|
556 -- with a RAS need to all be declared in a subpackage of the one that
|
|
|
557 -- contains the RAS declaration, because the primitive of the object
|
|
|
558 -- type, and the associated primitive of the stub type, need to be
|
|
|
559 -- dispatching operations of these types, and the profile of the RAS
|
|
|
560 -- might contain tagged types declared in the same scope.
|
|
|
561
|
|
|
562 Append_To (Vis_Decls,
|
|
|
563 Make_Private_Type_Declaration (Loc,
|
|
|
564 Defining_Identifier => Obj_Type,
|
|
|
565 Abstract_Present => True,
|
|
|
566 Tagged_Present => True,
|
|
|
567 Limited_Present => True));
|
|
|
568
|
|
|
569 Append_To (Priv_Decls,
|
|
|
570 Make_Full_Type_Declaration (Loc,
|
|
|
571 Defining_Identifier => Full_Obj_Type,
|
|
|
572 Type_Definition =>
|
|
|
573 Make_Record_Definition (Loc,
|
|
|
574 Abstract_Present => True,
|
|
|
575 Tagged_Present => True,
|
|
|
576 Limited_Present => True,
|
|
|
577 Null_Present => True,
|
|
|
578 Component_List => Empty)));
|
|
|
579
|
|
|
580 -- Trick semantic analysis into swapping the public and full view when
|
|
|
581 -- freezing the public view.
|
|
|
582
|
|
|
583 Set_Comes_From_Source (Full_Obj_Type, True);
|
|
|
584
|
|
|
585 if not Is_Degenerate then
|
|
|
586 Append_To (Vis_Decls,
|
|
|
587 Make_Abstract_Subprogram_Declaration (Loc,
|
|
|
588 Specification => Build_RAS_Primitive_Specification (
|
|
|
589 Subp_Spec => Type_Def,
|
|
|
590 Remote_Object_Type => Obj_Type)));
|
|
|
591 end if;
|
|
|
592
|
|
|
593 Append_To (Vis_Decls,
|
|
|
594 Make_Full_Type_Declaration (Loc,
|
|
|
595 Defining_Identifier => RACW_Type,
|
|
|
596 Type_Definition =>
|
|
|
597 Make_Access_To_Object_Definition (Loc,
|
|
|
598 All_Present => True,
|
|
|
599 Subtype_Indication =>
|
|
|
600 Make_Attribute_Reference (Loc,
|
|
|
601 Prefix => New_Occurrence_Of (Obj_Type, Loc),
|
|
|
602 Attribute_Name => Name_Class))));
|
|
|
603
|
|
|
604 Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI);
|
|
|
605 Set_Is_Remote_Types (RACW_Type, Is_RT);
|
|
|
606
|
|
|
607 Subpkg_Decl :=
|
|
|
608 Make_Package_Declaration (Loc,
|
|
|
609 Make_Package_Specification (Loc,
|
|
|
610 Defining_Unit_Name => Subpkg,
|
|
|
611 Visible_Declarations => Vis_Decls,
|
|
|
612 Private_Declarations => Priv_Decls,
|
|
|
613 End_Label => New_Occurrence_Of (Subpkg, Loc)));
|
|
|
614
|
|
|
615 Set_Is_Remote_Call_Interface (Subpkg, Is_RCI);
|
|
|
616 Set_Is_Remote_Types (Subpkg, Is_RT);
|
|
|
617 Insert_After_And_Analyze (N, Subpkg_Decl);
|
|
|
618
|
|
|
619 -- Generate package body to receive RACW calling stubs
|
|
|
620
|
|
|
621 -- Note: Analyze_Declarations has an absolute requirement that the
|
|
|
622 -- declaration list be non-empty, so provide dummy null statement here.
|
|
|
623
|
|
|
624 Subpkg_Body :=
|
|
|
625 Make_Package_Body (Loc,
|
|
|
626 Defining_Unit_Name => Make_Defining_Identifier (Loc, Chars (Subpkg)),
|
|
|
627 Declarations => New_List (Make_Null_Statement (Loc)));
|
|
|
628 Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body);
|
|
|
629
|
|
|
630 -- Many parts of the analyzer and expander expect
|
|
|
631 -- that the fat pointer type used to implement remote
|
|
|
632 -- access to subprogram types be a record.
|
|
|
633 -- Note: The structure of this type must be kept consistent
|
|
|
634 -- with the code generated by Remote_AST_Null_Value for the
|
|
|
635 -- corresponding 'null' expression.
|
|
|
636
|
|
|
637 Fat_Type_Decl := Make_Full_Type_Declaration (Loc,
|
|
|
638 Defining_Identifier => Fat_Type,
|
|
|
639 Type_Definition =>
|
|
|
640 Make_Record_Definition (Loc,
|
|
|
641 Component_List =>
|
|
|
642 Make_Component_List (Loc,
|
|
|
643 Component_Items => New_List (
|
|
|
644 Make_Component_Declaration (Loc,
|
|
|
645 Defining_Identifier =>
|
|
|
646 Make_Defining_Identifier (Loc, Name_Ras),
|
|
|
647 Component_Definition =>
|
|
|
648 Make_Component_Definition (Loc,
|
|
|
649 Aliased_Present => False,
|
|
|
650 Subtype_Indication =>
|
|
|
651 New_Occurrence_Of (RACW_Type, Loc)))))));
|
|
|
652
|
|
|
653 Set_Equivalent_Type (User_Type, Fat_Type);
|
|
|
654
|
|
|
655 -- Set Fat_Type's Etype early so that we can use its
|
|
|
656 -- Corresponding_Remote_Type attribute, whose presence indicates that
|
|
|
657 -- this is the record type used to implement a RAS.
|
|
|
658
|
|
|
659 Set_Ekind (Fat_Type, E_Record_Type);
|
|
|
660 Set_Corresponding_Remote_Type (Fat_Type, User_Type);
|
|
|
661
|
|
|
662 Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl);
|
|
|
663
|
|
|
664 -- The reason we suppress the initialization procedure is that we know
|
|
|
665 -- that no initialization is required (even if Initialize_Scalars mode
|
|
|
666 -- is active), and there are order of elaboration problems if we do try
|
|
|
667 -- to generate an init proc for this created record type.
|
|
|
668
|
|
|
669 Set_Suppress_Initialization (Fat_Type);
|
|
|
670
|
|
|
671 if Expander_Active then
|
|
|
672 Add_RAST_Features (Parent (User_Type));
|
|
|
673 end if;
|
|
|
674 end Process_Remote_AST_Declaration;
|
|
|
675
|
|
|
676 -----------------------
|
|
|
677 -- RAS_E_Dereference --
|
|
|
678 -----------------------
|
|
|
679
|
|
|
680 procedure RAS_E_Dereference (Pref : Node_Id) is
|
|
|
681 Loc : constant Source_Ptr := Sloc (Pref);
|
|
|
682 Call_Node : Node_Id;
|
|
|
683 New_Type : constant Entity_Id := Etype (Pref);
|
|
|
684 Explicit_Deref : constant Node_Id := Parent (Pref);
|
|
|
685 Deref_Subp_Call : constant Node_Id := Parent (Explicit_Deref);
|
|
|
686 Deref_Proc : Entity_Id;
|
|
|
687 Params : List_Id;
|
|
|
688
|
|
|
689 begin
|
|
|
690 if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then
|
|
|
691 Params := Parameter_Associations (Deref_Subp_Call);
|
|
|
692
|
|
|
693 if Present (Params) then
|
|
|
694 Prepend (Pref, Params);
|
|
|
695 else
|
|
|
696 Params := New_List (Pref);
|
|
|
697 end if;
|
|
|
698
|
|
|
699 elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then
|
|
|
700 Params := Expressions (Deref_Subp_Call);
|
|
|
701
|
|
|
702 if Present (Params) then
|
|
|
703 Prepend (Pref, Params);
|
|
|
704 else
|
|
|
705 Params := New_List (Pref);
|
|
|
706 end if;
|
|
|
707
|
|
|
708 else
|
|
|
709 -- Context is not a call
|
|
|
710
|
|
|
711 return;
|
|
|
712 end if;
|
|
|
713
|
|
|
714 if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
|
|
|
715 return;
|
|
|
716 end if;
|
|
|
717
|
|
|
718 Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
|
|
|
719 pragma Assert (Present (Deref_Proc));
|
|
|
720
|
|
|
721 if Ekind (Deref_Proc) = E_Function then
|
|
|
722 Call_Node :=
|
|
|
723 Make_Function_Call (Loc,
|
|
|
724 Name => New_Occurrence_Of (Deref_Proc, Loc),
|
|
|
725 Parameter_Associations => Params);
|
|
|
726 else
|
|
|
727 Call_Node :=
|
|
|
728 Make_Procedure_Call_Statement (Loc,
|
|
|
729 Name => New_Occurrence_Of (Deref_Proc, Loc),
|
|
|
730 Parameter_Associations => Params);
|
|
|
731 end if;
|
|
|
732
|
|
|
733 Rewrite (Deref_Subp_Call, Call_Node);
|
|
|
734 Analyze (Deref_Subp_Call);
|
|
|
735 end RAS_E_Dereference;
|
|
|
736
|
|
|
737 ------------------------------
|
|
|
738 -- Remote_AST_E_Dereference --
|
|
|
739 ------------------------------
|
|
|
740
|
|
|
741 function Remote_AST_E_Dereference (P : Node_Id) return Boolean is
|
|
|
742 ET : constant Entity_Id := Etype (P);
|
|
|
743
|
|
|
744 begin
|
|
|
745 -- Perform the changes only on original dereferences, and only if
|
|
|
746 -- we are generating code.
|
|
|
747
|
|
|
748 if Comes_From_Source (P)
|
|
|
749 and then Is_Record_Type (ET)
|
|
|
750 and then (Is_Remote_Call_Interface (ET)
|
|
|
751 or else Is_Remote_Types (ET))
|
|
|
752 and then Present (Corresponding_Remote_Type (ET))
|
|
|
753 and then Nkind_In (Parent (Parent (P)), N_Procedure_Call_Statement,
|
|
|
754 N_Indexed_Component)
|
|
|
755 and then Expander_Active
|
|
|
756 then
|
|
|
757 RAS_E_Dereference (P);
|
|
|
758 return True;
|
|
|
759 else
|
|
|
760 return False;
|
|
|
761 end if;
|
|
|
762 end Remote_AST_E_Dereference;
|
|
|
763
|
|
|
764 ------------------------------
|
|
|
765 -- Remote_AST_I_Dereference --
|
|
|
766 ------------------------------
|
|
|
767
|
|
|
768 function Remote_AST_I_Dereference (P : Node_Id) return Boolean is
|
|
|
769 ET : constant Entity_Id := Etype (P);
|
|
|
770 Deref : Node_Id;
|
|
|
771
|
|
|
772 begin
|
|
|
773 if Comes_From_Source (P)
|
|
|
774 and then (Is_Remote_Call_Interface (ET)
|
|
|
775 or else Is_Remote_Types (ET))
|
|
|
776 and then Present (Corresponding_Remote_Type (ET))
|
|
|
777 and then Ekind (Entity (P)) /= E_Function
|
|
|
778 then
|
|
|
779 Deref :=
|
|
|
780 Make_Explicit_Dereference (Sloc (P),
|
|
|
781 Prefix => Relocate_Node (P));
|
|
|
782 Rewrite (P, Deref);
|
|
|
783 Set_Etype (P, ET);
|
|
|
784 RAS_E_Dereference (Prefix (P));
|
|
|
785 return True;
|
|
|
786 end if;
|
|
|
787
|
|
|
788 return False;
|
|
|
789 end Remote_AST_I_Dereference;
|
|
|
790
|
|
|
791 ---------------------------
|
|
|
792 -- Remote_AST_Null_Value --
|
|
|
793 ---------------------------
|
|
|
794
|
|
|
795 function Remote_AST_Null_Value
|
|
|
796 (N : Node_Id;
|
|
|
797 Typ : Entity_Id) return Boolean
|
|
|
798 is
|
|
|
799 Loc : constant Source_Ptr := Sloc (N);
|
|
|
800 Target_Type : Entity_Id;
|
|
|
801
|
|
|
802 begin
|
|
|
803 if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
|
|
|
804 return False;
|
|
|
805
|
|
|
806 elsif Ekind (Typ) = E_Access_Subprogram_Type
|
|
|
807 and then (Is_Remote_Call_Interface (Typ)
|
|
|
808 or else Is_Remote_Types (Typ))
|
|
|
809 and then Comes_From_Source (N)
|
|
|
810 and then Expander_Active
|
|
|
811 then
|
|
|
812 -- Any null that comes from source and is of the RAS type must
|
|
|
813 -- be expanded, except if expansion is not active (nothing
|
|
|
814 -- gets expanded into the equivalent record type).
|
|
|
815
|
|
|
816 Target_Type := Equivalent_Type (Typ);
|
|
|
817
|
|
|
818 elsif Ekind (Typ) = E_Record_Type
|
|
|
819 and then Present (Corresponding_Remote_Type (Typ))
|
|
|
820 then
|
|
|
821 -- This is a record type representing a RAS type, this must be
|
|
|
822 -- expanded.
|
|
|
823
|
|
|
824 Target_Type := Typ;
|
|
|
825
|
|
|
826 else
|
|
|
827 -- We do not have to handle this case
|
|
|
828
|
|
|
829 return False;
|
|
|
830 end if;
|
|
|
831
|
|
|
832 Rewrite (N,
|
|
|
833 Make_Aggregate (Loc,
|
|
|
834 Component_Associations => New_List (
|
|
|
835 Make_Component_Association (Loc,
|
|
|
836 Choices => New_List (Make_Identifier (Loc, Name_Ras)),
|
|
|
837 Expression => Make_Null (Loc)))));
|
|
|
838 Analyze_And_Resolve (N, Target_Type);
|
|
|
839 return True;
|
|
|
840 end Remote_AST_Null_Value;
|
|
|
841
|
|
|
842 end Sem_Dist;
|
