File : sem_dist.adb
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-2014, 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 Dispatching_Type : Entity_Id;
276
277 begin
278 case Ekind (Op) is
279 when E_Function | E_Procedure =>
280 Dispatching_Type := Find_Dispatching_Type (Op);
281 return Present (Dispatching_Type)
282 and then Is_RACW_Stub_Type (Dispatching_Type)
283 and then not Is_Internal (Op);
284
285 when others =>
286 return False;
287 end case;
288 end Is_RACW_Stub_Type_Operation;
289
290 ---------------------------------
291 -- Is_Valid_Remote_Object_Type --
292 ---------------------------------
293
294 function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean is
295 P : constant Node_Id := Parent (E);
296
297 begin
298 pragma Assert (Is_Tagged_Type (E));
299
300 -- Simple case: a limited private type
301
302 if Nkind (P) = N_Private_Type_Declaration
303 and then Is_Limited_Record (E)
304 then
305 return True;
306
307 -- AI05-0060 (Binding Interpretation): A limited interface is a legal
308 -- ancestor for the designated type of an RACW type.
309
310 elsif Is_Limited_Record (E) and then Is_Limited_Interface (E) then
311 return True;
312
313 -- A generic tagged limited type is a valid candidate. Limitedness will
314 -- be checked again on the actual at instantiation point.
315
316 elsif Nkind (P) = N_Formal_Type_Declaration
317 and then Ekind (E) = E_Record_Type_With_Private
318 and then Is_Generic_Type (E)
319 and then Is_Limited_Record (E)
320 then
321 return True;
322
323 -- A private extension declaration is a valid candidate if its parent
324 -- type is.
325
326 elsif Nkind (P) = N_Private_Extension_Declaration then
327 return Is_Valid_Remote_Object_Type (Etype (E));
328
329 else
330 return False;
331 end if;
332 end Is_Valid_Remote_Object_Type;
333
334 ------------------------------------
335 -- Package_Specification_Of_Scope --
336 ------------------------------------
337
338 function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is
339 N : Node_Id;
340
341 begin
342 N := Parent (E);
343 while Nkind (N) /= N_Package_Specification loop
344 N := Parent (N);
345 end loop;
346
347 return N;
348 end Package_Specification_Of_Scope;
349
350 --------------------------
351 -- Process_Partition_ID --
352 --------------------------
353
354 procedure Process_Partition_Id (N : Node_Id) is
355 Loc : constant Source_Ptr := Sloc (N);
356 Ety : Entity_Id;
357 Get_Pt_Id : Node_Id;
358 Get_Pt_Id_Call : Node_Id;
359 Prefix_String : String_Id;
360 Typ : constant Entity_Id := Etype (N);
361
362 begin
363 -- In case prefix is not a library unit entity, get the entity
364 -- of library unit.
365
366 Ety := Entity (Prefix (N));
367 while (Present (Scope (Ety))
368 and then Scope (Ety) /= Standard_Standard)
369 and not Is_Child_Unit (Ety)
370 loop
371 Ety := Scope (Ety);
372 end loop;
373
374 -- Retrieve the proper function to call
375
376 if Is_Remote_Call_Interface (Ety) then
377 Get_Pt_Id := New_Occurrence_Of
378 (RTE (RE_Get_Active_Partition_Id), Loc);
379
380 elsif Is_Shared_Passive (Ety) then
381 Get_Pt_Id := New_Occurrence_Of
382 (RTE (RE_Get_Passive_Partition_Id), Loc);
383
384 else
385 Get_Pt_Id := New_Occurrence_Of
386 (RTE (RE_Get_Local_Partition_Id), Loc);
387 end if;
388
389 -- Get and store the String_Id corresponding to the name of the
390 -- library unit whose Partition_Id is needed.
391
392 Get_Library_Unit_Name_String (Unit_Declaration_Node (Ety));
393 Prefix_String := String_From_Name_Buffer;
394
395 -- Build the function call which will replace the attribute
396
397 if Is_Remote_Call_Interface (Ety) or else Is_Shared_Passive (Ety) then
398 Get_Pt_Id_Call :=
399 Make_Function_Call (Loc,
400 Name => Get_Pt_Id,
401 Parameter_Associations =>
402 New_List (Make_String_Literal (Loc, Prefix_String)));
403
404 else
405 Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id);
406 end if;
407
408 -- Replace the attribute node by a conversion of the function call
409 -- to the target type.
410
411 Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call));
412 Analyze_And_Resolve (N, Typ);
413 end Process_Partition_Id;
414
415 ----------------------------------
416 -- Process_Remote_AST_Attribute --
417 ----------------------------------
418
419 procedure Process_Remote_AST_Attribute
420 (N : Node_Id;
421 New_Type : Entity_Id)
422 is
423 Loc : constant Source_Ptr := Sloc (N);
424 Remote_Subp : Entity_Id;
425 Tick_Access_Conv_Call : Node_Id;
426 Remote_Subp_Decl : Node_Id;
427 RS_Pkg_Specif : Node_Id;
428 RS_Pkg_E : Entity_Id;
429 RAS_Type : Entity_Id := New_Type;
430 Async_E : Entity_Id;
431 All_Calls_Remote_E : Entity_Id;
432 Attribute_Subp : Entity_Id;
433
434 begin
435 -- Check if we have to expand the access attribute
436
437 Remote_Subp := Entity (Prefix (N));
438
439 if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
440 return;
441 end if;
442
443 if Ekind (RAS_Type) /= E_Record_Type then
444 RAS_Type := Equivalent_Type (RAS_Type);
445 end if;
446
447 Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access);
448 pragma Assert (Present (Attribute_Subp));
449 Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
450
451 if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then
452 Remote_Subp := Corresponding_Spec (Remote_Subp_Decl);
453 Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
454 end if;
455
456 RS_Pkg_Specif := Parent (Remote_Subp_Decl);
457 RS_Pkg_E := Defining_Entity (RS_Pkg_Specif);
458
459 Async_E :=
460 Boolean_Literals (Ekind (Remote_Subp) = E_Procedure
461 and then Is_Asynchronous (Remote_Subp));
462
463 All_Calls_Remote_E :=
464 Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E));
465
466 Tick_Access_Conv_Call :=
467 Make_Function_Call (Loc,
468 Name => New_Occurrence_Of (Attribute_Subp, Loc),
469 Parameter_Associations =>
470 New_List (
471 Make_String_Literal (Loc,
472 Strval => Full_Qualified_Name (RS_Pkg_E)),
473 Build_Subprogram_Id (Loc, Remote_Subp),
474 New_Occurrence_Of (Async_E, Loc),
475 New_Occurrence_Of (All_Calls_Remote_E, Loc)));
476
477 Rewrite (N, Tick_Access_Conv_Call);
478 Analyze_And_Resolve (N, RAS_Type);
479 end Process_Remote_AST_Attribute;
480
481 ------------------------------------
482 -- Process_Remote_AST_Declaration --
483 ------------------------------------
484
485 procedure Process_Remote_AST_Declaration (N : Node_Id) is
486 Loc : constant Source_Ptr := Sloc (N);
487 User_Type : constant Node_Id := Defining_Identifier (N);
488 Scop : constant Entity_Id := Scope (User_Type);
489 Is_RCI : constant Boolean := Is_Remote_Call_Interface (Scop);
490 Is_RT : constant Boolean := Is_Remote_Types (Scop);
491 Type_Def : constant Node_Id := Type_Definition (N);
492 Parameter : Node_Id;
493
494 Is_Degenerate : Boolean;
495 -- True iff this RAS has an access formal parameter (see
496 -- Exp_Dist.Add_RAS_Dereference_TSS for details).
497
498 Subpkg : constant Entity_Id := Make_Temporary (Loc, 'S');
499 Subpkg_Decl : Node_Id;
500 Subpkg_Body : Node_Id;
501 Vis_Decls : constant List_Id := New_List;
502 Priv_Decls : constant List_Id := New_List;
503
504 Obj_Type : constant Entity_Id :=
505 Make_Defining_Identifier (Loc,
506 New_External_Name (Chars (User_Type), 'R'));
507
508 Full_Obj_Type : constant Entity_Id :=
509 Make_Defining_Identifier (Loc, Chars (Obj_Type));
510
511 RACW_Type : constant Entity_Id :=
512 Make_Defining_Identifier (Loc,
513 New_External_Name (Chars (User_Type), 'P'));
514
515 Fat_Type : constant Entity_Id :=
516 Make_Defining_Identifier (Loc, Chars (User_Type));
517
518 Fat_Type_Decl : Node_Id;
519
520 begin
521 Is_Degenerate := False;
522 Parameter := First (Parameter_Specifications (Type_Def));
523 while Present (Parameter) loop
524 if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
525 Error_Msg_N
526 ("formal parameter& has anonymous access type??",
527 Defining_Identifier (Parameter));
528 Is_Degenerate := True;
529 exit;
530 end if;
531
532 Next (Parameter);
533 end loop;
534
535 if Is_Degenerate then
536 Error_Msg_NE
537 ("remote access-to-subprogram type& can only be null??",
538 Defining_Identifier (Parameter), User_Type);
539
540 -- The only legal value for a RAS with a formal parameter of an
541 -- anonymous access type is null, because it cannot be subtype-
542 -- conformant with any legal remote subprogram declaration. In this
543 -- case, we cannot generate a corresponding primitive operation.
544
545 end if;
546
547 if Get_PCS_Name = Name_No_DSA then
548 return;
549 end if;
550
551 -- The tagged private type, primitive operation and RACW type associated
552 -- with a RAS need to all be declared in a subpackage of the one that
553 -- contains the RAS declaration, because the primitive of the object
554 -- type, and the associated primitive of the stub type, need to be
555 -- dispatching operations of these types, and the profile of the RAS
556 -- might contain tagged types declared in the same scope.
557
558 Append_To (Vis_Decls,
559 Make_Private_Type_Declaration (Loc,
560 Defining_Identifier => Obj_Type,
561 Abstract_Present => True,
562 Tagged_Present => True,
563 Limited_Present => True));
564
565 Append_To (Priv_Decls,
566 Make_Full_Type_Declaration (Loc,
567 Defining_Identifier => Full_Obj_Type,
568 Type_Definition =>
569 Make_Record_Definition (Loc,
570 Abstract_Present => True,
571 Tagged_Present => True,
572 Limited_Present => True,
573 Null_Present => True,
574 Component_List => Empty)));
575
576 -- Trick semantic analysis into swapping the public and full view when
577 -- freezing the public view.
578
579 Set_Comes_From_Source (Full_Obj_Type, True);
580
581 if not Is_Degenerate then
582 Append_To (Vis_Decls,
583 Make_Abstract_Subprogram_Declaration (Loc,
584 Specification => Build_RAS_Primitive_Specification (
585 Subp_Spec => Type_Def,
586 Remote_Object_Type => Obj_Type)));
587 end if;
588
589 Append_To (Vis_Decls,
590 Make_Full_Type_Declaration (Loc,
591 Defining_Identifier => RACW_Type,
592 Type_Definition =>
593 Make_Access_To_Object_Definition (Loc,
594 All_Present => True,
595 Subtype_Indication =>
596 Make_Attribute_Reference (Loc,
597 Prefix => New_Occurrence_Of (Obj_Type, Loc),
598 Attribute_Name => Name_Class))));
599
600 Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI);
601 Set_Is_Remote_Types (RACW_Type, Is_RT);
602
603 Subpkg_Decl :=
604 Make_Package_Declaration (Loc,
605 Make_Package_Specification (Loc,
606 Defining_Unit_Name => Subpkg,
607 Visible_Declarations => Vis_Decls,
608 Private_Declarations => Priv_Decls,
609 End_Label => New_Occurrence_Of (Subpkg, Loc)));
610
611 Set_Is_Remote_Call_Interface (Subpkg, Is_RCI);
612 Set_Is_Remote_Types (Subpkg, Is_RT);
613 Insert_After_And_Analyze (N, Subpkg_Decl);
614
615 -- Generate package body to receive RACW calling stubs
616
617 -- Note: Analyze_Declarations has an absolute requirement that the
618 -- declaration list be non-empty, so provide dummy null statement here.
619
620 Subpkg_Body :=
621 Make_Package_Body (Loc,
622 Defining_Unit_Name => Make_Defining_Identifier (Loc, Chars (Subpkg)),
623 Declarations => New_List (Make_Null_Statement (Loc)));
624 Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body);
625
626 -- Many parts of the analyzer and expander expect
627 -- that the fat pointer type used to implement remote
628 -- access to subprogram types be a record.
629 -- Note: The structure of this type must be kept consistent
630 -- with the code generated by Remote_AST_Null_Value for the
631 -- corresponding 'null' expression.
632
633 Fat_Type_Decl := Make_Full_Type_Declaration (Loc,
634 Defining_Identifier => Fat_Type,
635 Type_Definition =>
636 Make_Record_Definition (Loc,
637 Component_List =>
638 Make_Component_List (Loc,
639 Component_Items => New_List (
640 Make_Component_Declaration (Loc,
641 Defining_Identifier =>
642 Make_Defining_Identifier (Loc, Name_Ras),
643 Component_Definition =>
644 Make_Component_Definition (Loc,
645 Aliased_Present => False,
646 Subtype_Indication =>
647 New_Occurrence_Of (RACW_Type, Loc)))))));
648
649 Set_Equivalent_Type (User_Type, Fat_Type);
650
651 -- Set Fat_Type's Etype early so that we can use its
652 -- Corresponding_Remote_Type attribute, whose presence indicates that
653 -- this is the record type used to implement a RAS.
654
655 Set_Ekind (Fat_Type, E_Record_Type);
656 Set_Corresponding_Remote_Type (Fat_Type, User_Type);
657
658 Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl);
659
660 -- The reason we suppress the initialization procedure is that we know
661 -- that no initialization is required (even if Initialize_Scalars mode
662 -- is active), and there are order of elaboration problems if we do try
663 -- to generate an init proc for this created record type.
664
665 Set_Suppress_Initialization (Fat_Type);
666
667 if Expander_Active then
668 Add_RAST_Features (Parent (User_Type));
669 end if;
670 end Process_Remote_AST_Declaration;
671
672 -----------------------
673 -- RAS_E_Dereference --
674 -----------------------
675
676 procedure RAS_E_Dereference (Pref : Node_Id) is
677 Loc : constant Source_Ptr := Sloc (Pref);
678 Call_Node : Node_Id;
679 New_Type : constant Entity_Id := Etype (Pref);
680 Explicit_Deref : constant Node_Id := Parent (Pref);
681 Deref_Subp_Call : constant Node_Id := Parent (Explicit_Deref);
682 Deref_Proc : Entity_Id;
683 Params : List_Id;
684
685 begin
686 if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then
687 Params := Parameter_Associations (Deref_Subp_Call);
688
689 if Present (Params) then
690 Prepend (Pref, Params);
691 else
692 Params := New_List (Pref);
693 end if;
694
695 elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then
696 Params := Expressions (Deref_Subp_Call);
697
698 if Present (Params) then
699 Prepend (Pref, Params);
700 else
701 Params := New_List (Pref);
702 end if;
703
704 else
705 -- Context is not a call
706
707 return;
708 end if;
709
710 if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
711 return;
712 end if;
713
714 Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
715 pragma Assert (Present (Deref_Proc));
716
717 if Ekind (Deref_Proc) = E_Function then
718 Call_Node :=
719 Make_Function_Call (Loc,
720 Name => New_Occurrence_Of (Deref_Proc, Loc),
721 Parameter_Associations => Params);
722 else
723 Call_Node :=
724 Make_Procedure_Call_Statement (Loc,
725 Name => New_Occurrence_Of (Deref_Proc, Loc),
726 Parameter_Associations => Params);
727 end if;
728
729 Rewrite (Deref_Subp_Call, Call_Node);
730 Analyze (Deref_Subp_Call);
731 end RAS_E_Dereference;
732
733 ------------------------------
734 -- Remote_AST_E_Dereference --
735 ------------------------------
736
737 function Remote_AST_E_Dereference (P : Node_Id) return Boolean is
738 ET : constant Entity_Id := Etype (P);
739
740 begin
741 -- Perform the changes only on original dereferences, and only if
742 -- we are generating code.
743
744 if Comes_From_Source (P)
745 and then Is_Record_Type (ET)
746 and then (Is_Remote_Call_Interface (ET)
747 or else Is_Remote_Types (ET))
748 and then Present (Corresponding_Remote_Type (ET))
749 and then Nkind_In (Parent (Parent (P)), N_Procedure_Call_Statement,
750 N_Indexed_Component)
751 and then Expander_Active
752 then
753 RAS_E_Dereference (P);
754 return True;
755 else
756 return False;
757 end if;
758 end Remote_AST_E_Dereference;
759
760 ------------------------------
761 -- Remote_AST_I_Dereference --
762 ------------------------------
763
764 function Remote_AST_I_Dereference (P : Node_Id) return Boolean is
765 ET : constant Entity_Id := Etype (P);
766 Deref : Node_Id;
767
768 begin
769 if Comes_From_Source (P)
770 and then (Is_Remote_Call_Interface (ET)
771 or else Is_Remote_Types (ET))
772 and then Present (Corresponding_Remote_Type (ET))
773 and then Ekind (Entity (P)) /= E_Function
774 then
775 Deref :=
776 Make_Explicit_Dereference (Sloc (P),
777 Prefix => Relocate_Node (P));
778 Rewrite (P, Deref);
779 Set_Etype (P, ET);
780 RAS_E_Dereference (Prefix (P));
781 return True;
782 end if;
783
784 return False;
785 end Remote_AST_I_Dereference;
786
787 ---------------------------
788 -- Remote_AST_Null_Value --
789 ---------------------------
790
791 function Remote_AST_Null_Value
792 (N : Node_Id;
793 Typ : Entity_Id) return Boolean
794 is
795 Loc : constant Source_Ptr := Sloc (N);
796 Target_Type : Entity_Id;
797
798 begin
799 if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
800 return False;
801
802 elsif Ekind (Typ) = E_Access_Subprogram_Type
803 and then (Is_Remote_Call_Interface (Typ)
804 or else Is_Remote_Types (Typ))
805 and then Comes_From_Source (N)
806 and then Expander_Active
807 then
808 -- Any null that comes from source and is of the RAS type must
809 -- be expanded, except if expansion is not active (nothing
810 -- gets expanded into the equivalent record type).
811
812 Target_Type := Equivalent_Type (Typ);
813
814 elsif Ekind (Typ) = E_Record_Type
815 and then Present (Corresponding_Remote_Type (Typ))
816 then
817 -- This is a record type representing a RAS type, this must be
818 -- expanded.
819
820 Target_Type := Typ;
821
822 else
823 -- We do not have to handle this case
824
825 return False;
826 end if;
827
828 Rewrite (N,
829 Make_Aggregate (Loc,
830 Component_Associations => New_List (
831 Make_Component_Association (Loc,
832 Choices => New_List (Make_Identifier (Loc, Name_Ras)),
833 Expression => Make_Null (Loc)))));
834 Analyze_And_Resolve (N, Target_Type);
835 return True;
836 end Remote_AST_Null_Value;
837
838 end Sem_Dist;