summaryrefslogtreecommitdiff
path: root/gcc/ada/sem_dist.adb
blob: f9a3c2ae9a99a4e0e268e77772c9ffb4bb5650bd (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             S E M _ D I S T                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Atree;    use Atree;
with Casing;   use Casing;
with Einfo;    use Einfo;
with Errout;   use Errout;
with Exp_Dist; use Exp_Dist;
with Exp_Tss;  use Exp_Tss;
with Nlists;   use Nlists;
with Nmake;    use Nmake;
with Namet;    use Namet;
with Opt;      use Opt;
with Rtsfind;  use Rtsfind;
with Sem;      use Sem;
with Sem_Aux;  use Sem_Aux;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Res;  use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo;    use Sinfo;
with Stand;    use Stand;
with Stringt;  use Stringt;
with Tbuild;   use Tbuild;
with Uintp;    use Uintp;

package body Sem_Dist is

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure RAS_E_Dereference (Pref : Node_Id);
   --  Handles explicit dereference of Remote Access to Subprograms

   function Full_Qualified_Name (E : Entity_Id) return String_Id;
   --  returns the full qualified name of the entity in lower case

   -------------------------
   -- Add_Stub_Constructs --
   -------------------------

   procedure Add_Stub_Constructs (N : Node_Id) is
      U    : constant Node_Id := Unit (N);
      Spec : Entity_Id        := Empty;

      Exp : Node_Id := U;
      --  Unit that will be expanded

   begin
      pragma Assert (Distribution_Stub_Mode /= No_Stubs);

      if Nkind (U) = N_Package_Declaration then
         Spec := Defining_Entity (Specification (U));

      elsif Nkind (U) = N_Package_Body then
         Spec := Corresponding_Spec (U);

      else pragma Assert (Nkind (U) = N_Package_Instantiation);
         Exp  := Instance_Spec (U);
         Spec := Defining_Entity (Specification (Exp));
      end if;

      pragma Assert (Is_Shared_Passive (Spec)
        or else Is_Remote_Call_Interface (Spec));

      if Distribution_Stub_Mode = Generate_Caller_Stub_Body then
         if Is_Shared_Passive (Spec) then
            null;
         elsif Nkind (U) = N_Package_Body then
            Error_Msg_N
              ("Specification file expected from command line", U);
         else
            Expand_Calling_Stubs_Bodies (Exp);
         end if;

      else
         if Is_Shared_Passive (Spec) then
            Build_Passive_Partition_Stub (Exp);
         else
            Expand_Receiving_Stubs_Bodies (Exp);
         end if;

      end if;
   end Add_Stub_Constructs;

   ---------------------------------------
   -- Build_RAS_Primitive_Specification --
   ---------------------------------------

   function Build_RAS_Primitive_Specification
     (Subp_Spec          : Node_Id;
      Remote_Object_Type : Node_Id) return Node_Id
   is
      Loc : constant Source_Ptr := Sloc (Subp_Spec);

      Primitive_Spec : constant Node_Id :=
                         Copy_Specification (Loc,
                           Spec     => Subp_Spec,
                           New_Name => Name_uCall);

      Subtype_Mark_For_Self : Node_Id;

   begin
      if No (Parameter_Specifications (Primitive_Spec)) then
         Set_Parameter_Specifications (Primitive_Spec, New_List);
      end if;

      if Nkind (Remote_Object_Type) in N_Entity then
         Subtype_Mark_For_Self :=
           New_Occurrence_Of (Remote_Object_Type, Loc);
      else
         Subtype_Mark_For_Self := Remote_Object_Type;
      end if;

      Prepend_To (
        Parameter_Specifications (Primitive_Spec),
        Make_Parameter_Specification (Loc,
          Defining_Identifier =>
            Make_Defining_Identifier (Loc, Name_uS),
          Parameter_Type      =>
            Make_Access_Definition (Loc,
              Subtype_Mark =>
                Subtype_Mark_For_Self)));

      --  Trick later semantic analysis into considering this operation as a
      --  primitive (dispatching) operation of tagged type Obj_Type.

      Set_Comes_From_Source (
        Defining_Unit_Name (Primitive_Spec), True);

      return Primitive_Spec;
   end Build_RAS_Primitive_Specification;

   -------------------------
   -- Full_Qualified_Name --
   -------------------------

   function Full_Qualified_Name (E : Entity_Id) return String_Id is
      Ent         : Entity_Id := E;
      Parent_Name : String_Id := No_String;

   begin
      --  Deals properly with child units

      if Nkind (Ent) = N_Defining_Program_Unit_Name then
         Ent := Defining_Identifier (Ent);
      end if;

      --  Compute recursively the qualification (only "Standard" has no scope)

      if Present (Scope (Scope (Ent))) then
         Parent_Name := Full_Qualified_Name (Scope (Ent));
      end if;

      --  Every entity should have a name except some expanded blocks. Do not
      --  bother about those.

      if Chars (Ent) = No_Name then
         return Parent_Name;
      end if;

      --  Add a period between Name and qualification

      if Parent_Name /= No_String then
         Start_String (Parent_Name);
         Store_String_Char (Get_Char_Code ('.'));
      else
         Start_String;
      end if;

      --  Generates the entity name in upper case

      Get_Name_String (Chars (Ent));
      Set_Casing (All_Lower_Case);
      Store_String_Chars (Name_Buffer (1 .. Name_Len));
      return End_String;
   end Full_Qualified_Name;

   ------------------
   -- Get_PCS_Name --
   ------------------

   function Get_PCS_Name return PCS_Names is
   begin
      return
        Chars (Entity (Expression (Parent (RTE (RE_DSA_Implementation)))));
   end Get_PCS_Name;

   ---------------------
   -- Get_PCS_Version --
   ---------------------

   function Get_PCS_Version return Int is
      PCS_Version_Entity : Entity_Id;
      PCS_Version        : Int;

   begin
      if RTE_Available (RE_PCS_Version) then
         PCS_Version_Entity := RTE (RE_PCS_Version);
         pragma Assert (Ekind (PCS_Version_Entity) = E_Named_Integer);
         PCS_Version :=
           UI_To_Int (Expr_Value (Constant_Value (PCS_Version_Entity)));

      else
         --  Case of System.Partition_Interface.PCS_Version not found:
         --  return a null version.

         PCS_Version := 0;
      end if;

      return PCS_Version;
   end Get_PCS_Version;

   ------------------------
   -- Is_All_Remote_Call --
   ------------------------

   function Is_All_Remote_Call (N : Node_Id) return Boolean is
      Par : Node_Id;

   begin
      if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
        and then Nkind (Name (N)) in N_Has_Entity
        and then Is_Remote_Call_Interface (Entity (Name (N)))
        and then Has_All_Calls_Remote (Scope (Entity (Name (N))))
        and then Comes_From_Source (N)
      then
         Par := Parent (Entity (Name (N)));
         while Present (Par)
           and then (Nkind (Par) /= N_Package_Specification
                       or else Is_Wrapper_Package (Defining_Entity (Par)))
         loop
            Par := Parent (Par);
         end loop;

         if Present (Par) then
            return
              not Scope_Within_Or_Same (Current_Scope, Defining_Entity (Par));
         else
            return False;
         end if;
      else
         return False;
      end if;
   end Is_All_Remote_Call;

   ---------------------------------
   -- Is_RACW_Stub_Type_Operation --
   ---------------------------------

   function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean is
      Dispatching_Type : Entity_Id;

   begin
      case Ekind (Op) is
         when E_Function | E_Procedure =>
            Dispatching_Type := Find_Dispatching_Type (Op);
            return Present (Dispatching_Type)
                     and then Is_RACW_Stub_Type (Dispatching_Type)
                     and then not Is_Internal (Op);

         when others =>
            return False;
      end case;
   end Is_RACW_Stub_Type_Operation;

   ------------------------------------
   -- Package_Specification_Of_Scope --
   ------------------------------------

   function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is
      N : Node_Id;

   begin
      N := Parent (E);
      while Nkind (N) /= N_Package_Specification loop
         N := Parent (N);
      end loop;

      return N;
   end Package_Specification_Of_Scope;

   --------------------------
   -- Process_Partition_ID --
   --------------------------

   procedure Process_Partition_Id (N : Node_Id) is
      Loc            : constant Source_Ptr := Sloc (N);
      Ety            : Entity_Id;
      Get_Pt_Id      : Node_Id;
      Get_Pt_Id_Call : Node_Id;
      Prefix_String  : String_Id;
      Typ            : constant Entity_Id := Etype (N);

   begin
      --  In case prefix is not a library unit entity, get the entity
      --  of library unit.

      Ety := Entity (Prefix (N));
      while (Present (Scope (Ety))
        and then Scope (Ety) /= Standard_Standard)
        and not Is_Child_Unit (Ety)
      loop
         Ety := Scope (Ety);
      end loop;

      --  Retrieve the proper function to call

      if Is_Remote_Call_Interface (Ety) then
         Get_Pt_Id := New_Occurrence_Of
           (RTE (RE_Get_Active_Partition_Id), Loc);

      elsif Is_Shared_Passive (Ety) then
         Get_Pt_Id := New_Occurrence_Of
           (RTE (RE_Get_Passive_Partition_Id), Loc);

      else
         Get_Pt_Id := New_Occurrence_Of
           (RTE (RE_Get_Local_Partition_Id), Loc);
      end if;

      --  Get and store the String_Id corresponding to the name of the
      --  library unit whose Partition_Id is needed.

      Get_Library_Unit_Name_String (Unit_Declaration_Node (Ety));
      Prefix_String := String_From_Name_Buffer;

      --  Build the function call which will replace the attribute

      if Is_Remote_Call_Interface (Ety) or else Is_Shared_Passive (Ety) then
         Get_Pt_Id_Call :=
           Make_Function_Call (Loc,
             Name => Get_Pt_Id,
             Parameter_Associations =>
               New_List (Make_String_Literal (Loc, Prefix_String)));

      else
         Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id);
      end if;

      --  Replace the attribute node by a conversion of the function call
      --  to the target type.

      Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call));
      Analyze_And_Resolve (N, Typ);
   end Process_Partition_Id;

   ----------------------------------
   -- Process_Remote_AST_Attribute --
   ----------------------------------

   procedure Process_Remote_AST_Attribute
     (N        : Node_Id;
      New_Type : Entity_Id)
   is
      Loc                   : constant Source_Ptr := Sloc (N);
      Remote_Subp           : Entity_Id;
      Tick_Access_Conv_Call : Node_Id;
      Remote_Subp_Decl      : Node_Id;
      RS_Pkg_Specif         : Node_Id;
      RS_Pkg_E              : Entity_Id;
      RAS_Type              : Entity_Id := New_Type;
      Async_E               : Entity_Id;
      All_Calls_Remote_E    : Entity_Id;
      Attribute_Subp        : Entity_Id;

   begin
      --  Check if we have to expand the access attribute

      Remote_Subp := Entity (Prefix (N));

      if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
         return;
      end if;

      if Ekind (RAS_Type) /= E_Record_Type then
         RAS_Type := Equivalent_Type (RAS_Type);
      end if;

      Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access);
      pragma Assert (Present (Attribute_Subp));
      Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);

      if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then
         Remote_Subp := Corresponding_Spec (Remote_Subp_Decl);
         Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
      end if;

      RS_Pkg_Specif := Parent (Remote_Subp_Decl);
      RS_Pkg_E := Defining_Entity (RS_Pkg_Specif);

      Async_E :=
        Boolean_Literals (Ekind (Remote_Subp) = E_Procedure
                            and then Is_Asynchronous (Remote_Subp));

      All_Calls_Remote_E :=
        Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E));

      Tick_Access_Conv_Call :=
        Make_Function_Call (Loc,
          Name                   => New_Occurrence_Of (Attribute_Subp, Loc),
          Parameter_Associations =>
            New_List (
              Make_String_Literal (Loc,
                Strval => Full_Qualified_Name (RS_Pkg_E)),
              Build_Subprogram_Id (Loc, Remote_Subp),
              New_Occurrence_Of (Async_E, Loc),
              New_Occurrence_Of (All_Calls_Remote_E, Loc)));

      Rewrite (N, Tick_Access_Conv_Call);
      Analyze_And_Resolve (N, RAS_Type);
   end Process_Remote_AST_Attribute;

   ------------------------------------
   -- Process_Remote_AST_Declaration --
   ------------------------------------

   procedure Process_Remote_AST_Declaration (N : Node_Id) is
      Loc       : constant Source_Ptr := Sloc (N);
      User_Type : constant Node_Id    := Defining_Identifier (N);
      Scop      : constant Entity_Id  := Scope (User_Type);
      Is_RCI    : constant Boolean    := Is_Remote_Call_Interface (Scop);
      Is_RT     : constant Boolean    := Is_Remote_Types (Scop);
      Type_Def  : constant Node_Id    := Type_Definition (N);
      Parameter : Node_Id;

      Is_Degenerate : Boolean;
      --  True iff this RAS has an access formal parameter (see
      --  Exp_Dist.Add_RAS_Dereference_TSS for details).

      Subpkg      : constant Entity_Id := Make_Temporary (Loc, 'S');
      Subpkg_Decl : Node_Id;
      Subpkg_Body : Node_Id;
      Vis_Decls   : constant List_Id := New_List;
      Priv_Decls  : constant List_Id := New_List;

      Obj_Type : constant Entity_Id :=
                    Make_Defining_Identifier (Loc,
                      New_External_Name (Chars (User_Type), 'R'));

      Full_Obj_Type : constant Entity_Id :=
                        Make_Defining_Identifier (Loc, Chars (Obj_Type));

      RACW_Type : constant Entity_Id :=
                    Make_Defining_Identifier (Loc,
                      New_External_Name (Chars (User_Type), 'P'));

      Fat_Type : constant Entity_Id :=
                   Make_Defining_Identifier (Loc, Chars (User_Type));

      Fat_Type_Decl : Node_Id;

   begin
      Is_Degenerate := False;
      Parameter := First (Parameter_Specifications (Type_Def));
      while Present (Parameter) loop
         if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
            Error_Msg_N ("formal parameter& has anonymous access type?",
              Defining_Identifier (Parameter));
            Is_Degenerate := True;
            exit;
         end if;

         Next (Parameter);
      end loop;

      if Is_Degenerate then
         Error_Msg_NE
           ("remote access-to-subprogram type& can only be null?",
            Defining_Identifier (Parameter), User_Type);

         --  The only legal value for a RAS with a formal parameter of an
         --  anonymous access type is null, because it cannot be subtype-
         --  conformant with any legal remote subprogram declaration. In this
         --  case, we cannot generate a corresponding primitive operation.

      end if;

      if Get_PCS_Name = Name_No_DSA then
         return;
      end if;

      --  The tagged private type, primitive operation and RACW type associated
      --  with a RAS need to all be declared in a subpackage of the one that
      --  contains the RAS declaration, because the primitive of the object
      --  type, and the associated primitive of the stub type, need to be
      --  dispatching operations of these types, and the profile of the RAS
      --  might contain tagged types declared in the same scope.

      Append_To (Vis_Decls,
        Make_Private_Type_Declaration (Loc,
          Defining_Identifier => Obj_Type,
          Abstract_Present => True,
          Tagged_Present   => True,
          Limited_Present  => True));

      Append_To (Priv_Decls,
        Make_Full_Type_Declaration (Loc,
          Defining_Identifier => Full_Obj_Type,
          Type_Definition     =>
            Make_Record_Definition (Loc,
              Abstract_Present => True,
              Tagged_Present   => True,
              Limited_Present  => True,
              Null_Present     => True,
              Component_List   => Empty)));

      --  Trick semantic analysis into swapping the public and full view when
      --  freezing the public view.

      Set_Comes_From_Source (Full_Obj_Type, True);

      if not Is_Degenerate then
         Append_To (Vis_Decls,
           Make_Abstract_Subprogram_Declaration (Loc,
             Specification => Build_RAS_Primitive_Specification (
               Subp_Spec          => Type_Def,
               Remote_Object_Type => Obj_Type)));
      end if;

      Append_To (Vis_Decls,
        Make_Full_Type_Declaration (Loc,
          Defining_Identifier => RACW_Type,
          Type_Definition     =>
            Make_Access_To_Object_Definition (Loc,
              All_Present => True,
              Subtype_Indication =>
                Make_Attribute_Reference (Loc,
                  Prefix         => New_Occurrence_Of (Obj_Type, Loc),
                  Attribute_Name => Name_Class))));

      Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI);
      Set_Is_Remote_Types (RACW_Type, Is_RT);

      Subpkg_Decl :=
        Make_Package_Declaration (Loc,
          Make_Package_Specification (Loc,
            Defining_Unit_Name   => Subpkg,
            Visible_Declarations => Vis_Decls,
            Private_Declarations => Priv_Decls,
            End_Label            => New_Occurrence_Of (Subpkg, Loc)));

      Set_Is_Remote_Call_Interface (Subpkg, Is_RCI);
      Set_Is_Remote_Types (Subpkg, Is_RT);
      Insert_After_And_Analyze (N, Subpkg_Decl);

      --  Generate package body to receive RACW calling stubs

      --  Note: Analyze_Declarations has an absolute requirement that the
      --  declaration list be non-empty, so provide dummy null statement here.

      Subpkg_Body :=
        Make_Package_Body (Loc,
          Defining_Unit_Name => Make_Defining_Identifier (Loc, Chars (Subpkg)),
          Declarations       => New_List (Make_Null_Statement (Loc)));
      Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body);

      --  Many parts of the analyzer and expander expect
      --  that the fat pointer type used to implement remote
      --  access to subprogram types be a record.
      --  Note: The structure of this type must be kept consistent
      --  with the code generated by Remote_AST_Null_Value for the
      --  corresponding 'null' expression.

      Fat_Type_Decl := Make_Full_Type_Declaration (Loc,
        Defining_Identifier => Fat_Type,
        Type_Definition     =>
          Make_Record_Definition (Loc,
            Component_List =>
              Make_Component_List (Loc,
                Component_Items => New_List (
                  Make_Component_Declaration (Loc,
                    Defining_Identifier =>
                      Make_Defining_Identifier (Loc, Name_Ras),
                    Component_Definition =>
                      Make_Component_Definition (Loc,
                        Aliased_Present     => False,
                        Subtype_Indication  =>
                          New_Occurrence_Of (RACW_Type, Loc)))))));

      Set_Equivalent_Type (User_Type, Fat_Type);
      Set_Corresponding_Remote_Type (Fat_Type, User_Type);
      Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl);

      --  The reason we suppress the initialization procedure is that we know
      --  that no initialization is required (even if Initialize_Scalars mode
      --  is active), and there are order of elaboration problems if we do try
      --  to generate an init proc for this created record type.

      Set_Suppress_Init_Proc (Fat_Type);

      if Expander_Active then
         Add_RAST_Features (Parent (User_Type));
      end if;
   end Process_Remote_AST_Declaration;

   -----------------------
   -- RAS_E_Dereference --
   -----------------------

   procedure RAS_E_Dereference (Pref : Node_Id) is
      Loc             : constant Source_Ptr := Sloc (Pref);
      Call_Node       : Node_Id;
      New_Type        : constant Entity_Id := Etype (Pref);
      Explicit_Deref  : constant Node_Id   := Parent (Pref);
      Deref_Subp_Call : constant Node_Id   := Parent (Explicit_Deref);
      Deref_Proc      : Entity_Id;
      Params          : List_Id;

   begin
      if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then
         Params := Parameter_Associations (Deref_Subp_Call);

         if Present (Params) then
            Prepend (Pref, Params);
         else
            Params := New_List (Pref);
         end if;

      elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then
         Params := Expressions (Deref_Subp_Call);

         if Present (Params) then
            Prepend (Pref, Params);
         else
            Params := New_List (Pref);
         end if;

      else
         --  Context is not a call

         return;
      end if;

      if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
         return;
      end if;

      Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
      pragma Assert (Present (Deref_Proc));

      if Ekind (Deref_Proc) = E_Function then
         Call_Node :=
           Make_Function_Call (Loc,
              Name                   => New_Occurrence_Of (Deref_Proc, Loc),
              Parameter_Associations => Params);
      else
         Call_Node :=
           Make_Procedure_Call_Statement (Loc,
              Name                   => New_Occurrence_Of (Deref_Proc, Loc),
              Parameter_Associations => Params);
      end if;

      Rewrite (Deref_Subp_Call, Call_Node);
      Analyze (Deref_Subp_Call);
   end RAS_E_Dereference;

   ------------------------------
   -- Remote_AST_E_Dereference --
   ------------------------------

   function Remote_AST_E_Dereference (P : Node_Id) return Boolean is
      ET : constant Entity_Id  := Etype (P);

   begin
      --  Perform the changes only on original dereferences, and only if
      --  we are generating code.

      if Comes_From_Source (P)
        and then Is_Record_Type (ET)
        and then (Is_Remote_Call_Interface (ET)
                   or else Is_Remote_Types (ET))
        and then Present (Corresponding_Remote_Type (ET))
        and then Nkind_In (Parent (Parent (P)), N_Procedure_Call_Statement,
                                                N_Indexed_Component)
        and then Expander_Active
      then
         RAS_E_Dereference (P);
         return True;
      else
         return False;
      end if;
   end Remote_AST_E_Dereference;

   ------------------------------
   -- Remote_AST_I_Dereference --
   ------------------------------

   function Remote_AST_I_Dereference (P : Node_Id) return Boolean is
      ET     : constant Entity_Id  := Etype (P);
      Deref  : Node_Id;

   begin
      if Comes_From_Source (P)
        and then (Is_Remote_Call_Interface (ET)
                   or else Is_Remote_Types (ET))
        and then Present (Corresponding_Remote_Type (ET))
        and then Ekind (Entity (P)) /= E_Function
      then
         Deref :=
           Make_Explicit_Dereference (Sloc (P),
             Prefix => Relocate_Node (P));
         Rewrite (P, Deref);
         Set_Etype (P, ET);
         RAS_E_Dereference (Prefix (P));
         return True;
      end if;

      return False;
   end Remote_AST_I_Dereference;

   ---------------------------
   -- Remote_AST_Null_Value --
   ---------------------------

   function Remote_AST_Null_Value
     (N   : Node_Id;
      Typ : Entity_Id) return Boolean
   is
      Loc         : constant Source_Ptr := Sloc (N);
      Target_Type : Entity_Id;

   begin
      if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
         return False;

      elsif Ekind (Typ) = E_Access_Subprogram_Type
        and then (Is_Remote_Call_Interface (Typ)
                    or else Is_Remote_Types (Typ))
        and then Comes_From_Source (N)
        and then Expander_Active
      then
         --  Any null that comes from source and is of the RAS type must
         --  be expanded, except if expansion is not active (nothing
         --  gets expanded into the equivalent record type).

         Target_Type := Equivalent_Type (Typ);

      elsif Ekind (Typ) = E_Record_Type
        and then Present (Corresponding_Remote_Type (Typ))
      then
         --  This is a record type representing a RAS type, this must be
         --  expanded.

         Target_Type := Typ;

      else
         --  We do not have to handle this case

         return False;
      end if;

      Rewrite (N,
        Make_Aggregate (Loc,
          Component_Associations => New_List (
            Make_Component_Association (Loc,
              Choices    => New_List (Make_Identifier (Loc, Name_Ras)),
              Expression => Make_Null (Loc)))));
      Analyze_And_Resolve (N, Target_Type);
      return True;
   end Remote_AST_Null_Value;

end Sem_Dist;