]>
Commit | Line | Data |
---|---|---|
996ae0b0 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S E M _ D I S T -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
1d005acc | 9 | -- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- |
996ae0b0 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- -- |
996ae0b0 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. -- | |
996ae0b0 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. -- |
996ae0b0 RK |
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; | |
a4100e55 | 38 | with Sem_Aux; use Sem_Aux; |
4b1c6354 | 39 | with Sem_Disp; use Sem_Disp; |
33c423c8 | 40 | with Sem_Eval; use Sem_Eval; |
996ae0b0 RK |
41 | with Sem_Res; use Sem_Res; |
42 | with Sem_Util; use Sem_Util; | |
43 | with Sinfo; use Sinfo; | |
996ae0b0 RK |
44 | with Stand; use Stand; |
45 | with Stringt; use Stringt; | |
46 | with Tbuild; use Tbuild; | |
33c423c8 | 47 | with Uintp; use Uintp; |
996ae0b0 RK |
48 | |
49 | package body Sem_Dist is | |
50 | ||
51 | ----------------------- | |
52 | -- Local Subprograms -- | |
53 | ----------------------- | |
54 | ||
55 | procedure RAS_E_Dereference (Pref : Node_Id); | |
dfbe160a | 56 | -- Handles explicit dereference of Remote Access to Subprograms |
996ae0b0 RK |
57 | |
58 | function Full_Qualified_Name (E : Entity_Id) return String_Id; | |
dfbe160a | 59 | -- returns the full qualified name of the entity in lower case |
996ae0b0 RK |
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; | |
d693e39d TQ |
68 | |
69 | Exp : Node_Id := U; | |
70 | -- Unit that will be expanded | |
996ae0b0 RK |
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 | |
996ae0b0 RK |
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 | |
996ae0b0 RK |
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 | ||
c885d7a1 AC |
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, | |
13bbad84 | 122 | New_Name => Name_uCall); |
c885d7a1 AC |
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 | ||
13bbad84 ES |
148 | -- Trick later semantic analysis into considering this operation as a |
149 | -- primitive (dispatching) operation of tagged type Obj_Type. | |
c885d7a1 AC |
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 | ||
996ae0b0 RK |
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 | ||
dfbe160a | 172 | -- Compute recursively the qualification (only "Standard" has no scope) |
996ae0b0 RK |
173 | |
174 | if Present (Scope (Scope (Ent))) then | |
175 | Parent_Name := Full_Qualified_Name (Scope (Ent)); | |
176 | end if; | |
177 | ||
dfbe160a ES |
178 | -- Every entity should have a name except some expanded blocks. Do not |
179 | -- bother about those. | |
996ae0b0 RK |
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 ('.')); | |
996ae0b0 RK |
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 | ||
a77842bd TQ |
202 | ------------------ |
203 | -- Get_PCS_Name -- | |
204 | ------------------ | |
205 | ||
206 | function Get_PCS_Name return PCS_Names is | |
a77842bd | 207 | begin |
33c423c8 AC |
208 | return |
209 | Chars (Entity (Expression (Parent (RTE (RE_DSA_Implementation))))); | |
a77842bd TQ |
210 | end Get_PCS_Name; |
211 | ||
33c423c8 AC |
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 | ||
996ae0b0 RK |
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 | |
d3b00ce3 | 245 | if Nkind (N) in N_Subprogram_Call |
996ae0b0 RK |
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))); | |
996ae0b0 RK |
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 | ||
4b1c6354 TQ |
270 | --------------------------------- |
271 | -- Is_RACW_Stub_Type_Operation -- | |
272 | --------------------------------- | |
273 | ||
274 | function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean is | |
d8f43ee6 | 275 | Typ : Entity_Id; |
4b1c6354 TQ |
276 | |
277 | begin | |
278 | case Ekind (Op) is | |
d8f43ee6 HK |
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); | |
4b1c6354 TQ |
288 | |
289 | when others => | |
290 | return False; | |
291 | end case; | |
292 | end Is_RACW_Stub_Type_Operation; | |
293 | ||
25081892 AC |
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 | ||
996ae0b0 RK |
338 | ------------------------------------ |
339 | -- Package_Specification_Of_Scope -- | |
340 | ------------------------------------ | |
341 | ||
342 | function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is | |
d693e39d | 343 | N : Node_Id; |
4b1c6354 | 344 | |
996ae0b0 | 345 | begin |
d693e39d | 346 | N := Parent (E); |
996ae0b0 RK |
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 | -------------------------- | |
8016e567 | 355 | -- Process_Partition_Id -- |
996ae0b0 RK |
356 | -------------------------- |
357 | ||
358 | procedure Process_Partition_Id (N : Node_Id) is | |
359 | Loc : constant Source_Ptr := Sloc (N); | |
360 | Ety : Entity_Id; | |
996ae0b0 RK |
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 | |
996ae0b0 RK |
367 | -- In case prefix is not a library unit entity, get the entity |
368 | -- of library unit. | |
369 | ||
d693e39d | 370 | Ety := Entity (Prefix (N)); |
996ae0b0 RK |
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 | ||
dfbe160a | 378 | -- Retrieve the proper function to call |
996ae0b0 RK |
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 | |
1735e55d | 394 | -- library unit whose Partition_Id is needed. |
996ae0b0 | 395 | |
1735e55d AC |
396 | Get_Library_Unit_Name_String (Unit_Declaration_Node (Ety)); |
397 | Prefix_String := String_From_Name_Buffer; | |
996ae0b0 RK |
398 | |
399 | -- Build the function call which will replace the attribute | |
400 | ||
1be9633f | 401 | if Is_Remote_Call_Interface (Ety) or else Is_Shared_Passive (Ety) then |
996ae0b0 RK |
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); | |
996ae0b0 RK |
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); | |
996ae0b0 RK |
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; | |
996ae0b0 RK |
431 | RS_Pkg_Specif : Node_Id; |
432 | RS_Pkg_E : Entity_Id; | |
0da2c8ac | 433 | RAS_Type : Entity_Id := New_Type; |
996ae0b0 | 434 | Async_E : Entity_Id; |
cc4f0de1 | 435 | All_Calls_Remote_E : Entity_Id; |
996ae0b0 | 436 | Attribute_Subp : Entity_Id; |
996ae0b0 RK |
437 | |
438 | begin | |
439 | -- Check if we have to expand the access attribute | |
440 | ||
441 | Remote_Subp := Entity (Prefix (N)); | |
442 | ||
a77842bd | 443 | if not Expander_Active or else Get_PCS_Name = Name_No_DSA then |
996ae0b0 | 444 | return; |
0da2c8ac | 445 | end if; |
996ae0b0 | 446 | |
0da2c8ac AC |
447 | if Ekind (RAS_Type) /= E_Record_Type then |
448 | RAS_Type := Equivalent_Type (RAS_Type); | |
996ae0b0 RK |
449 | end if; |
450 | ||
fbf5a39b | 451 | Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access); |
0da2c8ac | 452 | pragma Assert (Present (Attribute_Subp)); |
996ae0b0 RK |
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 | ||
aa720a54 AC |
463 | Async_E := |
464 | Boolean_Literals (Ekind (Remote_Subp) = E_Procedure | |
465 | and then Is_Asynchronous (Remote_Subp)); | |
996ae0b0 | 466 | |
aa720a54 AC |
467 | All_Calls_Remote_E := |
468 | Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E)); | |
cc4f0de1 | 469 | |
996ae0b0 RK |
470 | Tick_Access_Conv_Call := |
471 | Make_Function_Call (Loc, | |
d693e39d | 472 | Name => New_Occurrence_Of (Attribute_Subp, Loc), |
996ae0b0 RK |
473 | Parameter_Associations => |
474 | New_List ( | |
d693e39d TQ |
475 | Make_String_Literal (Loc, |
476 | Strval => Full_Qualified_Name (RS_Pkg_E)), | |
7324bf49 | 477 | Build_Subprogram_Id (Loc, Remote_Subp), |
cc4f0de1 AC |
478 | New_Occurrence_Of (Async_E, Loc), |
479 | New_Occurrence_Of (All_Calls_Remote_E, Loc))); | |
996ae0b0 RK |
480 | |
481 | Rewrite (N, Tick_Access_Conv_Call); | |
482 | Analyze_And_Resolve (N, RAS_Type); | |
996ae0b0 RK |
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 | |
13bbad84 ES |
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; | |
c885d7a1 AC |
499 | -- True iff this RAS has an access formal parameter (see |
500 | -- Exp_Dist.Add_RAS_Dereference_TSS for details). | |
501 | ||
092ef350 | 502 | Subpkg : constant Entity_Id := Make_Temporary (Loc, 'S'); |
13bbad84 ES |
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')); | |
c885d7a1 | 511 | |
13bbad84 | 512 | Full_Obj_Type : constant Entity_Id := |
092ef350 | 513 | Make_Defining_Identifier (Loc, Chars (Obj_Type)); |
c885d7a1 | 514 | |
13bbad84 ES |
515 | RACW_Type : constant Entity_Id := |
516 | Make_Defining_Identifier (Loc, | |
517 | New_External_Name (Chars (User_Type), 'P')); | |
c885d7a1 | 518 | |
13bbad84 | 519 | Fat_Type : constant Entity_Id := |
092ef350 | 520 | Make_Defining_Identifier (Loc, Chars (User_Type)); |
c885d7a1 | 521 | |
13bbad84 | 522 | Fat_Type_Decl : Node_Id; |
996ae0b0 RK |
523 | |
524 | begin | |
a77842bd TQ |
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 | |
324ac540 AC |
529 | Error_Msg_N |
530 | ("formal parameter& has anonymous access type??", | |
531 | Defining_Identifier (Parameter)); | |
a77842bd TQ |
532 | Is_Degenerate := True; |
533 | exit; | |
534 | end if; | |
535 | ||
536 | Next (Parameter); | |
537 | end loop; | |
538 | ||
539 | if Is_Degenerate then | |
dfbe160a | 540 | Error_Msg_NE |
324ac540 | 541 | ("remote access-to-subprogram type& can only be null??", |
dfbe160a ES |
542 | Defining_Identifier (Parameter), User_Type); |
543 | ||
a77842bd | 544 | -- The only legal value for a RAS with a formal parameter of an |
dfbe160a ES |
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. | |
13bbad84 | 548 | |
a77842bd TQ |
549 | end if; |
550 | ||
551 | if Get_PCS_Name = Name_No_DSA then | |
552 | return; | |
553 | end if; | |
996ae0b0 | 554 | |
dfbe160a ES |
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. | |
c885d7a1 AC |
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, | |
996ae0b0 | 570 | Make_Full_Type_Declaration (Loc, |
d693e39d | 571 | Defining_Identifier => Full_Obj_Type, |
c885d7a1 | 572 | Type_Definition => |
996ae0b0 | 573 | Make_Record_Definition (Loc, |
c885d7a1 AC |
574 | Abstract_Present => True, |
575 | Tagged_Present => True, | |
576 | Limited_Present => True, | |
577 | Null_Present => True, | |
578 | Component_List => Empty))); | |
579 | ||
13bbad84 ES |
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 | ||
a77842bd | 585 | if not Is_Degenerate then |
c885d7a1 AC |
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, | |
d693e39d TQ |
601 | Prefix => New_Occurrence_Of (Obj_Type, Loc), |
602 | Attribute_Name => Name_Class)))); | |
603 | ||
c885d7a1 AC |
604 | Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI); |
605 | Set_Is_Remote_Types (RACW_Type, Is_RT); | |
c885d7a1 AC |
606 | |
607 | Subpkg_Decl := | |
608 | Make_Package_Declaration (Loc, | |
609 | Make_Package_Specification (Loc, | |
d693e39d TQ |
610 | Defining_Unit_Name => Subpkg, |
611 | Visible_Declarations => Vis_Decls, | |
612 | Private_Declarations => Priv_Decls, | |
613 | End_Label => New_Occurrence_Of (Subpkg, Loc))); | |
614 | ||
c885d7a1 AC |
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 | ||
13bbad84 | 619 | -- Generate package body to receive RACW calling stubs |
d693e39d TQ |
620 | |
621 | -- Note: Analyze_Declarations has an absolute requirement that the | |
622 | -- declaration list be non-empty, so provide dummy null statement here. | |
13bbad84 ES |
623 | |
624 | Subpkg_Body := | |
625 | Make_Package_Body (Loc, | |
d693e39d TQ |
626 | Defining_Unit_Name => Make_Defining_Identifier (Loc, Chars (Subpkg)), |
627 | Declarations => New_List (Make_Null_Statement (Loc))); | |
13bbad84 ES |
628 | Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body); |
629 | ||
c885d7a1 AC |
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, | |
d693e39d | 649 | Aliased_Present => False, |
c885d7a1 AC |
650 | Subtype_Indication => |
651 | New_Occurrence_Of (RACW_Type, Loc))))))); | |
d693e39d | 652 | |
996ae0b0 | 653 | Set_Equivalent_Type (User_Type, Fat_Type); |
4b03d946 AC |
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); | |
996ae0b0 | 660 | Set_Corresponding_Remote_Type (Fat_Type, User_Type); |
4b03d946 | 661 | |
13bbad84 | 662 | Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl); |
996ae0b0 RK |
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 | |
fbf5a39b | 667 | -- to generate an init proc for this created record type. |
996ae0b0 | 668 | |
5b1e6aca | 669 | Set_Suppress_Initialization (Fat_Type); |
996ae0b0 RK |
670 | |
671 | if Expander_Active then | |
672 | Add_RAST_Features (Parent (User_Type)); | |
673 | end if; | |
996ae0b0 RK |
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); | |
996ae0b0 RK |
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 | |
996ae0b0 RK |
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 | |
dfbe160a | 709 | -- Context is not a call |
996ae0b0 RK |
710 | |
711 | return; | |
712 | end if; | |
713 | ||
a77842bd | 714 | if not Expander_Active or else Get_PCS_Name = Name_No_DSA then |
996ae0b0 | 715 | return; |
996ae0b0 RK |
716 | end if; |
717 | ||
0da2c8ac AC |
718 | Deref_Proc := TSS (New_Type, TSS_RAS_Dereference); |
719 | pragma Assert (Present (Deref_Proc)); | |
720 | ||
996ae0b0 RK |
721 | if Ekind (Deref_Proc) = E_Function then |
722 | Call_Node := | |
723 | Make_Function_Call (Loc, | |
d693e39d | 724 | Name => New_Occurrence_Of (Deref_Proc, Loc), |
996ae0b0 | 725 | Parameter_Associations => Params); |
996ae0b0 RK |
726 | else |
727 | Call_Node := | |
728 | Make_Procedure_Call_Statement (Loc, | |
d693e39d | 729 | Name => New_Occurrence_Of (Deref_Proc, Loc), |
996ae0b0 RK |
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 | ||
c885d7a1 | 741 | function Remote_AST_E_Dereference (P : Node_Id) return Boolean is |
996ae0b0 RK |
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)) | |
d693e39d TQ |
753 | and then Nkind_In (Parent (Parent (P)), N_Procedure_Call_Statement, |
754 | N_Indexed_Component) | |
996ae0b0 RK |
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 | ||
c885d7a1 | 768 | function Remote_AST_I_Dereference (P : Node_Id) return Boolean is |
996ae0b0 RK |
769 | ET : constant Entity_Id := Etype (P); |
770 | Deref : Node_Id; | |
996ae0b0 | 771 | |
c885d7a1 | 772 | begin |
996ae0b0 RK |
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 | |
c885d7a1 AC |
796 | (N : Node_Id; |
797 | Typ : Entity_Id) return Boolean | |
996ae0b0 RK |
798 | is |
799 | Loc : constant Source_Ptr := Sloc (N); | |
800 | Target_Type : Entity_Id; | |
801 | ||
802 | begin | |
a77842bd | 803 | if not Expander_Active or else Get_PCS_Name = Name_No_DSA then |
996ae0b0 RK |
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 | |
996ae0b0 RK |
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; | |
996ae0b0 RK |
830 | end if; |
831 | ||
832 | Rewrite (N, | |
833 | Make_Aggregate (Loc, | |
c885d7a1 AC |
834 | Component_Associations => New_List ( |
835 | Make_Component_Association (Loc, | |
7675ad4f | 836 | Choices => New_List (Make_Identifier (Loc, Name_Ras)), |
d693e39d | 837 | Expression => Make_Null (Loc))))); |
996ae0b0 RK |
838 | Analyze_And_Resolve (N, Target_Type); |
839 | return True; | |
840 | end Remote_AST_Null_Value; | |
841 | ||
842 | end Sem_Dist; |