gcc/ada/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-2004, 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Casing;   use Casing;
  29 with Einfo;    use Einfo;
  30 with Errout;   use Errout;
  31 with Exp_Dist; use Exp_Dist;
  32 with Exp_Tss;  use Exp_Tss;
  33 with Nlists;   use Nlists;
  34 with Nmake;    use Nmake;
  35 with Namet;    use Namet;
  36 with Opt;      use Opt;
  37 with Rtsfind;  use Rtsfind;
  38 with Sem;      use Sem;
  39 with Sem_Res;  use Sem_Res;
  40 with Sem_Util; use Sem_Util;
  41 with Sinfo;    use Sinfo;
  42 with Snames;   use Snames;
  43 with Stand;    use Stand;
  44 with Stringt;  use Stringt;
  45 with Tbuild;   use Tbuild;
  46 with Uname;    use Uname;
  47
  48 package body Sem_Dist is
  49
  50    -----------------------
  51    -- Local Subprograms --
  52    -----------------------
  53
  54    procedure RAS_E_Dereference (Pref : Node_Id);
  55    --  Handles explicit dereference of Remote Access to Subprograms.
  56
  57    function Full_Qualified_Name (E : Entity_Id) return String_Id;
  58    --  returns the full qualified name of the entity in lower case.
  59
  60    -------------------------
  61    -- Add_Stub_Constructs --
  62    -------------------------
  63
  64    procedure Add_Stub_Constructs (N : Node_Id) is
  65       U    : constant Node_Id := Unit (N);
  66       Spec : Entity_Id        := Empty;
  67       Exp  : Node_Id          := U;         --  Unit that will be expanded
  68
  69    begin
  70       pragma Assert (Distribution_Stub_Mode /= No_Stubs);
  71
  72       if Nkind (U) = N_Package_Declaration then
  73          Spec := Defining_Entity (Specification (U));
  74
  75       elsif Nkind (U) = N_Package_Body then
  76          Spec := Corresponding_Spec (U);
  77
  78       else pragma Assert (Nkind (U) = N_Package_Instantiation);
  79          Exp  := Instance_Spec (U);
  80          Spec := Defining_Entity (Specification (Exp));
  81       end if;
  82
  83       pragma Assert (Is_Shared_Passive (Spec)
  84         or else Is_Remote_Call_Interface (Spec));
  85
  86       if Distribution_Stub_Mode = Generate_Caller_Stub_Body then
  87
  88          if Is_Shared_Passive (Spec) then
  89             null;
  90          elsif Nkind (U) = N_Package_Body then
  91             Error_Msg_N
  92               ("Specification file expected from command line", U);
  93          else
  94             Expand_Calling_Stubs_Bodies (Exp);
  95          end if;
  96
  97       else
  98
  99          if Is_Shared_Passive (Spec) then
 100             Build_Passive_Partition_Stub (Exp);
 101          else
 102             Expand_Receiving_Stubs_Bodies (Exp);
 103          end if;
 104
 105       end if;
 106    end Add_Stub_Constructs;
 107
 108    -------------------------
 109    -- Full_Qualified_Name --
 110    -------------------------
 111
 112    function Full_Qualified_Name (E : Entity_Id) return String_Id is
 113       Ent         : Entity_Id := E;
 114       Parent_Name : String_Id := No_String;
 115
 116    begin
 117       --  Deals properly with child units
 118
 119       if Nkind (Ent) = N_Defining_Program_Unit_Name then
 120          Ent := Defining_Identifier (Ent);
 121       end if;
 122
 123       --  Compute recursively the qualification. Only "Standard" has no scope.
 124
 125       if Present (Scope (Scope (Ent))) then
 126          Parent_Name := Full_Qualified_Name (Scope (Ent));
 127       end if;
 128
 129       --  Every entity should have a name except some expanded blocks
 130       --  don't bother about those.
 131
 132       if Chars (Ent) = No_Name then
 133          return Parent_Name;
 134       end if;
 135
 136       --  Add a period between Name and qualification
 137
 138       if Parent_Name /= No_String then
 139          Start_String (Parent_Name);
 140          Store_String_Char (Get_Char_Code ('.'));
 141
 142       else
 143          Start_String;
 144       end if;
 145
 146       --  Generates the entity name in upper case
 147
 148       Get_Name_String (Chars (Ent));
 149       Set_Casing (All_Lower_Case);
 150       Store_String_Chars (Name_Buffer (1 .. Name_Len));
 151       return End_String;
 152    end Full_Qualified_Name;
 153
 154    ------------------------
 155    -- Is_All_Remote_Call --
 156    ------------------------
 157
 158    function Is_All_Remote_Call (N : Node_Id) return Boolean is
 159       Par : Node_Id;
 160
 161    begin
 162       if (Nkind (N) = N_Function_Call
 163               or else Nkind (N) = N_Procedure_Call_Statement)
 164         and then Nkind (Name (N)) in N_Has_Entity
 165         and then Is_Remote_Call_Interface (Entity (Name (N)))
 166         and then Has_All_Calls_Remote (Scope (Entity (Name (N))))
 167         and then Comes_From_Source (N)
 168       then
 169          Par := Parent (Entity (Name (N)));
 170
 171          while Present (Par)
 172            and then (Nkind (Par) /= N_Package_Specification
 173                        or else Is_Wrapper_Package (Defining_Entity (Par)))
 174          loop
 175             Par := Parent (Par);
 176          end loop;
 177
 178          if Present (Par) then
 179             return
 180               not Scope_Within_Or_Same (Current_Scope, Defining_Entity (Par));
 181          else
 182             return False;
 183          end if;
 184       else
 185          return False;
 186       end if;
 187    end Is_All_Remote_Call;
 188
 189    ------------------------------------
 190    -- Package_Specification_Of_Scope --
 191    ------------------------------------
 192
 193    function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is
 194       N : Node_Id := Parent (E);
 195    begin
 196       while Nkind (N) /= N_Package_Specification loop
 197          N := Parent (N);
 198       end loop;
 199
 200       return N;
 201    end Package_Specification_Of_Scope;
 202
 203    --------------------------
 204    -- Process_Partition_ID --
 205    --------------------------
 206
 207    procedure Process_Partition_Id (N : Node_Id) is
 208       Loc            : constant Source_Ptr := Sloc (N);
 209       Ety            : Entity_Id;
 210       Get_Pt_Id      : Node_Id;
 211       Get_Pt_Id_Call : Node_Id;
 212       Prefix_String  : String_Id;
 213       Typ            : constant Entity_Id := Etype (N);
 214
 215    begin
 216       Ety := Entity (Prefix (N));
 217
 218       --  In case prefix is not a library unit entity, get the entity
 219       --  of library unit.
 220
 221       while (Present (Scope (Ety))
 222         and then Scope (Ety) /= Standard_Standard)
 223         and not Is_Child_Unit (Ety)
 224       loop
 225          Ety := Scope (Ety);
 226       end loop;
 227
 228       --  Retrieve the proper function to call.
 229
 230       if Is_Remote_Call_Interface (Ety) then
 231          Get_Pt_Id := New_Occurrence_Of
 232            (RTE (RE_Get_Active_Partition_Id), Loc);
 233
 234       elsif Is_Shared_Passive (Ety) then
 235          Get_Pt_Id := New_Occurrence_Of
 236            (RTE (RE_Get_Passive_Partition_Id), Loc);
 237
 238       else
 239          Get_Pt_Id := New_Occurrence_Of
 240            (RTE (RE_Get_Local_Partition_Id), Loc);
 241       end if;
 242
 243       --  Get and store the String_Id corresponding to the name of the
 244       --  library unit whose Partition_Id is needed
 245
 246       Get_Unit_Name_String (Get_Unit_Name (Unit_Declaration_Node (Ety)));
 247
 248       --  Remove seven last character ("(spec)" or " (body)").
 249       --  (this is a bit nasty, should have interface for this ???)
 250
 251       Name_Len := Name_Len - 7;
 252
 253       Start_String;
 254       Store_String_Chars (Name_Buffer (1 .. Name_Len));
 255       Prefix_String := End_String;
 256
 257       --  Build the function call which will replace the attribute
 258
 259       if Is_Remote_Call_Interface (Ety)
 260         or else Is_Shared_Passive (Ety)
 261       then
 262          Get_Pt_Id_Call :=
 263            Make_Function_Call (Loc,
 264              Name => Get_Pt_Id,
 265              Parameter_Associations =>
 266                New_List (Make_String_Literal (Loc, Prefix_String)));
 267
 268       else
 269          Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id);
 270
 271       end if;
 272
 273       --  Replace the attribute node by a conversion of the function call
 274       --  to the target type.
 275
 276       Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call));
 277       Analyze_And_Resolve (N, Typ);
 278    end Process_Partition_Id;
 279
 280    ----------------------------------
 281    -- Process_Remote_AST_Attribute --
 282    ----------------------------------
 283
 284    procedure Process_Remote_AST_Attribute
 285      (N        : Node_Id;
 286       New_Type : Entity_Id)
 287    is
 288       Loc                   : constant Source_Ptr := Sloc (N);
 289       Remote_Subp           : Entity_Id;
 290       Tick_Access_Conv_Call : Node_Id;
 291       Remote_Subp_Decl      : Node_Id;
 292       RS_Pkg_Specif         : Node_Id;
 293       RS_Pkg_E              : Entity_Id;
 294       RAS_Type              : Entity_Id := New_Type;
 295       Async_E               : Entity_Id;
 296       All_Calls_Remote_E    : Entity_Id;
 297       Attribute_Subp        : Entity_Id;
 298       Local_Addr            : Node_Id;
 299
 300    begin
 301       --  Check if we have to expand the access attribute
 302
 303       Remote_Subp := Entity (Prefix (N));
 304
 305       if not Expander_Active then
 306          return;
 307       end if;
 308
 309       if Ekind (RAS_Type) /= E_Record_Type then
 310          RAS_Type := Equivalent_Type (RAS_Type);
 311       end if;
 312
 313       Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access);
 314       pragma Assert (Present (Attribute_Subp));
 315       Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
 316
 317       if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then
 318          Remote_Subp := Corresponding_Spec (Remote_Subp_Decl);
 319          Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
 320       end if;
 321
 322       RS_Pkg_Specif := Parent (Remote_Subp_Decl);
 323       RS_Pkg_E := Defining_Entity (RS_Pkg_Specif);
 324
 325       Async_E :=
 326         Boolean_Literals (Ekind (Remote_Subp) = E_Procedure
 327                             and then Is_Asynchronous (Remote_Subp));
 328
 329       All_Calls_Remote_E :=
 330         Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E));
 331
 332       Local_Addr :=
 333         Make_Attribute_Reference (Loc,
 334           Prefix         => New_Occurrence_Of (Remote_Subp, Loc),
 335           Attribute_Name => Name_Address);
 336
 337       Tick_Access_Conv_Call :=
 338         Make_Function_Call (Loc,
 339           Name => New_Occurrence_Of (Attribute_Subp, Loc),
 340           Parameter_Associations =>
 341             New_List (
 342               Local_Addr,
 343               Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)),
 344               Build_Subprogram_Id (Loc, Remote_Subp),
 345               New_Occurrence_Of (Async_E, Loc),
 346               New_Occurrence_Of (All_Calls_Remote_E, Loc)));
 347
 348       Rewrite (N, Tick_Access_Conv_Call);
 349       Analyze_And_Resolve (N, RAS_Type);
 350    end Process_Remote_AST_Attribute;
 351
 352    ------------------------------------
 353    -- Process_Remote_AST_Declaration --
 354    ------------------------------------
 355
 356    procedure Process_Remote_AST_Declaration (N : Node_Id) is
 357       Loc           : constant Source_Ptr := Sloc (N);
 358       User_Type     : constant Node_Id := Defining_Identifier (N);
 359       Fat_Type      : constant Entity_Id :=
 360                         Make_Defining_Identifier
 361                           (Loc, Chars (User_Type));
 362       New_Type_Decl : Node_Id;
 363
 364    begin
 365       --  We add a record type declaration for the equivalent fat pointer type
 366
 367       New_Type_Decl :=
 368         Make_Full_Type_Declaration (Loc,
 369           Defining_Identifier => Fat_Type,
 370           Type_Definition =>
 371             Make_Record_Definition (Loc,
 372               Component_List =>
 373                 Make_Component_List (Loc,
 374                   Component_Items => New_List (
 375
 376                     Make_Component_Declaration (Loc,
 377                       Defining_Identifier =>
 378                         Make_Defining_Identifier (Loc,
 379                           Chars => Name_Ras),
 380                       Component_Definition =>
 381                         Make_Component_Definition (Loc,
 382                           Aliased_Present    => False,
 383                           Subtype_Indication =>
 384                             New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
 385
 386                     Make_Component_Declaration (Loc,
 387                       Defining_Identifier =>
 388                         Make_Defining_Identifier (Loc,
 389                           Chars => Name_Origin),
 390                       Component_Definition =>
 391                         Make_Component_Definition (Loc,
 392                           Aliased_Present    => False,
 393                           Subtype_Indication =>
 394                             New_Reference_To (Standard_Integer, Loc))),
 395
 396                     Make_Component_Declaration (Loc,
 397                       Defining_Identifier =>
 398                         Make_Defining_Identifier (Loc,
 399                           Chars => Name_Receiver),
 400                       Component_Definition =>
 401                         Make_Component_Definition (Loc,
 402                           Aliased_Present    => False,
 403                           Subtype_Indication =>
 404                             New_Reference_To (RTE (RE_Unsigned_64), Loc))),
 405
 406                     Make_Component_Declaration (Loc,
 407                       Defining_Identifier =>
 408                         Make_Defining_Identifier (Loc,
 409                           Chars => Name_Subp_Id),
 410                       Component_Definition =>
 411                         Make_Component_Definition (Loc,
 412                           Aliased_Present    => False,
 413                           Subtype_Indication =>
 414                             New_Reference_To (Standard_Natural, Loc))),
 415
 416                     Make_Component_Declaration (Loc,
 417                       Defining_Identifier =>
 418                         Make_Defining_Identifier (Loc,
 419                           Chars => Name_Async),
 420                       Component_Definition =>
 421                         Make_Component_Definition (Loc,
 422                           Aliased_Present    => False,
 423                           Subtype_Indication =>
 424                             New_Reference_To (Standard_Boolean, Loc)))))));
 425
 426       Insert_After (N, New_Type_Decl);
 427       Set_Equivalent_Type (User_Type, Fat_Type);
 428       Set_Corresponding_Remote_Type (Fat_Type, User_Type);
 429
 430       --  The reason we suppress the initialization procedure is that we know
 431       --  that no initialization is required (even if Initialize_Scalars mode
 432       --  is active), and there are order of elaboration problems if we do try
 433       --  to generate an init proc for this created record type.
 434
 435       Set_Suppress_Init_Proc (Fat_Type);
 436
 437       if Expander_Active then
 438          Add_RAST_Features (Parent (User_Type));
 439       end if;
 440    end Process_Remote_AST_Declaration;
 441
 442    -----------------------
 443    -- RAS_E_Dereference --
 444    -----------------------
 445
 446    procedure RAS_E_Dereference (Pref : Node_Id) is
 447       Loc             : constant Source_Ptr := Sloc (Pref);
 448       Call_Node       : Node_Id;
 449       New_Type        : constant Entity_Id := Etype (Pref);
 450       Explicit_Deref  : constant Node_Id   := Parent (Pref);
 451       Deref_Subp_Call : constant Node_Id   := Parent (Explicit_Deref);
 452       Deref_Proc      : Entity_Id;
 453       Params          : List_Id;
 454
 455    begin
 456       if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then
 457          Params := Parameter_Associations (Deref_Subp_Call);
 458
 459          if Present (Params) then
 460             Prepend (Pref, Params);
 461          else
 462             Params := New_List (Pref);
 463          end if;
 464
 465       elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then
 466
 467          Params := Expressions (Deref_Subp_Call);
 468
 469          if Present (Params) then
 470             Prepend (Pref, Params);
 471          else
 472             Params := New_List (Pref);
 473          end if;
 474
 475       else
 476          --  Context is not a call.
 477
 478          return;
 479       end if;
 480
 481       if not Expander_Active then
 482          return;
 483       end if;
 484
 485       Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
 486       pragma Assert (Present (Deref_Proc));
 487
 488       if Ekind (Deref_Proc) = E_Function then
 489          Call_Node :=
 490            Make_Function_Call (Loc,
 491               Name => New_Occurrence_Of (Deref_Proc, Loc),
 492               Parameter_Associations => Params);
 493
 494       else
 495          Call_Node :=
 496            Make_Procedure_Call_Statement (Loc,
 497               Name => New_Occurrence_Of (Deref_Proc, Loc),
 498               Parameter_Associations => Params);
 499       end if;
 500
 501       Rewrite (Deref_Subp_Call, Call_Node);
 502       Analyze (Deref_Subp_Call);
 503    end RAS_E_Dereference;
 504
 505    ------------------------------
 506    -- Remote_AST_E_Dereference --
 507    ------------------------------
 508
 509    function Remote_AST_E_Dereference (P : Node_Id) return Boolean
 510    is
 511       ET : constant Entity_Id  := Etype (P);
 512
 513    begin
 514       --  Perform the changes only on original dereferences, and only if
 515       --  we are generating code.
 516
 517       if Comes_From_Source (P)
 518         and then Is_Record_Type (ET)
 519         and then (Is_Remote_Call_Interface (ET)
 520                    or else Is_Remote_Types (ET))
 521         and then Present (Corresponding_Remote_Type (ET))
 522         and then (Nkind (Parent (Parent (P))) = N_Procedure_Call_Statement
 523                    or else Nkind (Parent (Parent (P))) = N_Indexed_Component)
 524         and then Expander_Active
 525       then
 526          RAS_E_Dereference (P);
 527          return True;
 528       else
 529          return False;
 530       end if;
 531    end Remote_AST_E_Dereference;
 532
 533    ------------------------------
 534    -- Remote_AST_I_Dereference --
 535    ------------------------------
 536
 537    function Remote_AST_I_Dereference (P : Node_Id) return Boolean
 538    is
 539       ET     : constant Entity_Id  := Etype (P);
 540       Deref  : Node_Id;
 541    begin
 542
 543       if Comes_From_Source (P)
 544         and then (Is_Remote_Call_Interface (ET)
 545                    or else Is_Remote_Types (ET))
 546         and then Present (Corresponding_Remote_Type (ET))
 547         and then Ekind (Entity (P)) /= E_Function
 548       then
 549          Deref :=
 550            Make_Explicit_Dereference (Sloc (P),
 551              Prefix => Relocate_Node (P));
 552          Rewrite (P, Deref);
 553          Set_Etype (P, ET);
 554          RAS_E_Dereference (Prefix (P));
 555          return True;
 556       end if;
 557
 558       return False;
 559    end Remote_AST_I_Dereference;
 560
 561    ---------------------------
 562    -- Remote_AST_Null_Value --
 563    ---------------------------
 564
 565    function Remote_AST_Null_Value
 566      (N    : Node_Id;
 567       Typ  : Entity_Id)
 568       return Boolean
 569    is
 570       Loc         : constant Source_Ptr := Sloc (N);
 571       Target_Type : Entity_Id;
 572
 573    begin
 574       if not Expander_Active then
 575          return False;
 576
 577       elsif Ekind (Typ) = E_Access_Subprogram_Type
 578         and then (Is_Remote_Call_Interface (Typ)
 579                     or else Is_Remote_Types (Typ))
 580         and then Comes_From_Source (N)
 581         and then Expander_Active
 582       then
 583          --  Any null that comes from source and is of the RAS type must
 584          --  be expanded, except if expansion is not active (nothing
 585          --  gets expanded into the equivalent record type).
 586
 587          Target_Type := Equivalent_Type (Typ);
 588
 589       elsif Ekind (Typ) = E_Record_Type
 590         and then Present (Corresponding_Remote_Type (Typ))
 591       then
 592          --  This is a record type representing a RAS type, this must be
 593          --  expanded.
 594
 595          Target_Type := Typ;
 596
 597       else
 598          --  We do not have to handle this case
 599
 600          return False;
 601
 602       end if;
 603
 604       Rewrite (N,
 605         Make_Aggregate (Loc,
 606           Expressions => New_List (
 607             Make_Integer_Literal (Loc, 0),                  -- Ras
 608             Make_Integer_Literal (Loc, 0),                  -- Origin
 609             Make_Integer_Literal (Loc, 0),                  -- Receiver
 610             Make_Integer_Literal (Loc, 0),                  -- Subp_Id
 611             New_Occurrence_Of (Standard_False, Loc))));     -- Asyn
 612       Analyze_And_Resolve (N, Target_Type);
 613       return True;
 614    end Remote_AST_Null_Value;
 615
 616 end Sem_Dist;