OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sem_dist.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
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-2012, 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_In (N, N_Function_Call, N_Procedure_Call_Statement)
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 ("formal parameter& has anonymous access type?",
526
              Defining_Identifier (Parameter));
527
            Is_Degenerate := True;
528
            exit;
529
         end if;
530
 
531
         Next (Parameter);
532
      end loop;
533
 
534
      if Is_Degenerate then
535
         Error_Msg_NE
536
           ("remote access-to-subprogram type& can only be null?",
537
            Defining_Identifier (Parameter), User_Type);
538
 
539
         --  The only legal value for a RAS with a formal parameter of an
540
         --  anonymous access type is null, because it cannot be subtype-
541
         --  conformant with any legal remote subprogram declaration. In this
542
         --  case, we cannot generate a corresponding primitive operation.
543
 
544
      end if;
545
 
546
      if Get_PCS_Name = Name_No_DSA then
547
         return;
548
      end if;
549
 
550
      --  The tagged private type, primitive operation and RACW type associated
551
      --  with a RAS need to all be declared in a subpackage of the one that
552
      --  contains the RAS declaration, because the primitive of the object
553
      --  type, and the associated primitive of the stub type, need to be
554
      --  dispatching operations of these types, and the profile of the RAS
555
      --  might contain tagged types declared in the same scope.
556
 
557
      Append_To (Vis_Decls,
558
        Make_Private_Type_Declaration (Loc,
559
          Defining_Identifier => Obj_Type,
560
          Abstract_Present => True,
561
          Tagged_Present   => True,
562
          Limited_Present  => True));
563
 
564
      Append_To (Priv_Decls,
565
        Make_Full_Type_Declaration (Loc,
566
          Defining_Identifier => Full_Obj_Type,
567
          Type_Definition     =>
568
            Make_Record_Definition (Loc,
569
              Abstract_Present => True,
570
              Tagged_Present   => True,
571
              Limited_Present  => True,
572
              Null_Present     => True,
573
              Component_List   => Empty)));
574
 
575
      --  Trick semantic analysis into swapping the public and full view when
576
      --  freezing the public view.
577
 
578
      Set_Comes_From_Source (Full_Obj_Type, True);
579
 
580
      if not Is_Degenerate then
581
         Append_To (Vis_Decls,
582
           Make_Abstract_Subprogram_Declaration (Loc,
583
             Specification => Build_RAS_Primitive_Specification (
584
               Subp_Spec          => Type_Def,
585
               Remote_Object_Type => Obj_Type)));
586
      end if;
587
 
588
      Append_To (Vis_Decls,
589
        Make_Full_Type_Declaration (Loc,
590
          Defining_Identifier => RACW_Type,
591
          Type_Definition     =>
592
            Make_Access_To_Object_Definition (Loc,
593
              All_Present => True,
594
              Subtype_Indication =>
595
                Make_Attribute_Reference (Loc,
596
                  Prefix         => New_Occurrence_Of (Obj_Type, Loc),
597
                  Attribute_Name => Name_Class))));
598
 
599
      Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI);
600
      Set_Is_Remote_Types (RACW_Type, Is_RT);
601
 
602
      Subpkg_Decl :=
603
        Make_Package_Declaration (Loc,
604
          Make_Package_Specification (Loc,
605
            Defining_Unit_Name   => Subpkg,
606
            Visible_Declarations => Vis_Decls,
607
            Private_Declarations => Priv_Decls,
608
            End_Label            => New_Occurrence_Of (Subpkg, Loc)));
609
 
610
      Set_Is_Remote_Call_Interface (Subpkg, Is_RCI);
611
      Set_Is_Remote_Types (Subpkg, Is_RT);
612
      Insert_After_And_Analyze (N, Subpkg_Decl);
613
 
614
      --  Generate package body to receive RACW calling stubs
615
 
616
      --  Note: Analyze_Declarations has an absolute requirement that the
617
      --  declaration list be non-empty, so provide dummy null statement here.
618
 
619
      Subpkg_Body :=
620
        Make_Package_Body (Loc,
621
          Defining_Unit_Name => Make_Defining_Identifier (Loc, Chars (Subpkg)),
622
          Declarations       => New_List (Make_Null_Statement (Loc)));
623
      Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body);
624
 
625
      --  Many parts of the analyzer and expander expect
626
      --  that the fat pointer type used to implement remote
627
      --  access to subprogram types be a record.
628
      --  Note: The structure of this type must be kept consistent
629
      --  with the code generated by Remote_AST_Null_Value for the
630
      --  corresponding 'null' expression.
631
 
632
      Fat_Type_Decl := Make_Full_Type_Declaration (Loc,
633
        Defining_Identifier => Fat_Type,
634
        Type_Definition     =>
635
          Make_Record_Definition (Loc,
636
            Component_List =>
637
              Make_Component_List (Loc,
638
                Component_Items => New_List (
639
                  Make_Component_Declaration (Loc,
640
                    Defining_Identifier =>
641
                      Make_Defining_Identifier (Loc, Name_Ras),
642
                    Component_Definition =>
643
                      Make_Component_Definition (Loc,
644
                        Aliased_Present     => False,
645
                        Subtype_Indication  =>
646
                          New_Occurrence_Of (RACW_Type, Loc)))))));
647
 
648
      Set_Equivalent_Type (User_Type, Fat_Type);
649
      Set_Corresponding_Remote_Type (Fat_Type, User_Type);
650
      Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl);
651
 
652
      --  The reason we suppress the initialization procedure is that we know
653
      --  that no initialization is required (even if Initialize_Scalars mode
654
      --  is active), and there are order of elaboration problems if we do try
655
      --  to generate an init proc for this created record type.
656
 
657
      Set_Suppress_Initialization (Fat_Type);
658
 
659
      if Expander_Active then
660
         Add_RAST_Features (Parent (User_Type));
661
      end if;
662
   end Process_Remote_AST_Declaration;
663
 
664
   -----------------------
665
   -- RAS_E_Dereference --
666
   -----------------------
667
 
668
   procedure RAS_E_Dereference (Pref : Node_Id) is
669
      Loc             : constant Source_Ptr := Sloc (Pref);
670
      Call_Node       : Node_Id;
671
      New_Type        : constant Entity_Id := Etype (Pref);
672
      Explicit_Deref  : constant Node_Id   := Parent (Pref);
673
      Deref_Subp_Call : constant Node_Id   := Parent (Explicit_Deref);
674
      Deref_Proc      : Entity_Id;
675
      Params          : List_Id;
676
 
677
   begin
678
      if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then
679
         Params := Parameter_Associations (Deref_Subp_Call);
680
 
681
         if Present (Params) then
682
            Prepend (Pref, Params);
683
         else
684
            Params := New_List (Pref);
685
         end if;
686
 
687
      elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then
688
         Params := Expressions (Deref_Subp_Call);
689
 
690
         if Present (Params) then
691
            Prepend (Pref, Params);
692
         else
693
            Params := New_List (Pref);
694
         end if;
695
 
696
      else
697
         --  Context is not a call
698
 
699
         return;
700
      end if;
701
 
702
      if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
703
         return;
704
      end if;
705
 
706
      Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
707
      pragma Assert (Present (Deref_Proc));
708
 
709
      if Ekind (Deref_Proc) = E_Function then
710
         Call_Node :=
711
           Make_Function_Call (Loc,
712
              Name                   => New_Occurrence_Of (Deref_Proc, Loc),
713
              Parameter_Associations => Params);
714
      else
715
         Call_Node :=
716
           Make_Procedure_Call_Statement (Loc,
717
              Name                   => New_Occurrence_Of (Deref_Proc, Loc),
718
              Parameter_Associations => Params);
719
      end if;
720
 
721
      Rewrite (Deref_Subp_Call, Call_Node);
722
      Analyze (Deref_Subp_Call);
723
   end RAS_E_Dereference;
724
 
725
   ------------------------------
726
   -- Remote_AST_E_Dereference --
727
   ------------------------------
728
 
729
   function Remote_AST_E_Dereference (P : Node_Id) return Boolean is
730
      ET : constant Entity_Id  := Etype (P);
731
 
732
   begin
733
      --  Perform the changes only on original dereferences, and only if
734
      --  we are generating code.
735
 
736
      if Comes_From_Source (P)
737
        and then Is_Record_Type (ET)
738
        and then (Is_Remote_Call_Interface (ET)
739
                   or else Is_Remote_Types (ET))
740
        and then Present (Corresponding_Remote_Type (ET))
741
        and then Nkind_In (Parent (Parent (P)), N_Procedure_Call_Statement,
742
                                                N_Indexed_Component)
743
        and then Expander_Active
744
      then
745
         RAS_E_Dereference (P);
746
         return True;
747
      else
748
         return False;
749
      end if;
750
   end Remote_AST_E_Dereference;
751
 
752
   ------------------------------
753
   -- Remote_AST_I_Dereference --
754
   ------------------------------
755
 
756
   function Remote_AST_I_Dereference (P : Node_Id) return Boolean is
757
      ET     : constant Entity_Id  := Etype (P);
758
      Deref  : Node_Id;
759
 
760
   begin
761
      if Comes_From_Source (P)
762
        and then (Is_Remote_Call_Interface (ET)
763
                   or else Is_Remote_Types (ET))
764
        and then Present (Corresponding_Remote_Type (ET))
765
        and then Ekind (Entity (P)) /= E_Function
766
      then
767
         Deref :=
768
           Make_Explicit_Dereference (Sloc (P),
769
             Prefix => Relocate_Node (P));
770
         Rewrite (P, Deref);
771
         Set_Etype (P, ET);
772
         RAS_E_Dereference (Prefix (P));
773
         return True;
774
      end if;
775
 
776
      return False;
777
   end Remote_AST_I_Dereference;
778
 
779
   ---------------------------
780
   -- Remote_AST_Null_Value --
781
   ---------------------------
782
 
783
   function Remote_AST_Null_Value
784
     (N   : Node_Id;
785
      Typ : Entity_Id) return Boolean
786
   is
787
      Loc         : constant Source_Ptr := Sloc (N);
788
      Target_Type : Entity_Id;
789
 
790
   begin
791
      if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
792
         return False;
793
 
794
      elsif Ekind (Typ) = E_Access_Subprogram_Type
795
        and then (Is_Remote_Call_Interface (Typ)
796
                    or else Is_Remote_Types (Typ))
797
        and then Comes_From_Source (N)
798
        and then Expander_Active
799
      then
800
         --  Any null that comes from source and is of the RAS type must
801
         --  be expanded, except if expansion is not active (nothing
802
         --  gets expanded into the equivalent record type).
803
 
804
         Target_Type := Equivalent_Type (Typ);
805
 
806
      elsif Ekind (Typ) = E_Record_Type
807
        and then Present (Corresponding_Remote_Type (Typ))
808
      then
809
         --  This is a record type representing a RAS type, this must be
810
         --  expanded.
811
 
812
         Target_Type := Typ;
813
 
814
      else
815
         --  We do not have to handle this case
816
 
817
         return False;
818
      end if;
819
 
820
      Rewrite (N,
821
        Make_Aggregate (Loc,
822
          Component_Associations => New_List (
823
            Make_Component_Association (Loc,
824
              Choices    => New_List (Make_Identifier (Loc, Name_Ras)),
825
              Expression => Make_Null (Loc)))));
826
      Analyze_And_Resolve (N, Target_Type);
827
      return True;
828
   end Remote_AST_Null_Value;
829
 
830
end Sem_Dist;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.