gcc/ada/exp_atag.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ A T A G                              --
   6 --                                                                          --
   7 --                                 S p e c                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2006-2007, 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 Einfo;    use Einfo;
  27 with Elists;   use Elists;
  28 with Exp_Util; use Exp_Util;
  29 with Nlists;   use Nlists;
  30 with Nmake;    use Nmake;
  31 with Rtsfind;  use Rtsfind;
  32 with Sem_Util; use Sem_Util;
  33 with Stand;    use Stand;
  34 with Snames;   use Snames;
  35 with Tbuild;   use Tbuild;
  36
  37 package body Exp_Atag is
  38
  39    -----------------------
  40    -- Local Subprograms --
  41    -----------------------
  42
  43    function Build_DT
  44      (Loc      : Source_Ptr;
  45       Tag_Node : Node_Id) return Node_Id;
  46    --  Build code that displaces the Tag to reference the base of the wrapper
  47    --  record
  48    --
  49    --  Generates:
  50    --    To_Dispatch_Table_Ptr
  51    --      (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position);
  52
  53    function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id;
  54    --  Build code that retrieves the address of the record containing the Type
  55    --  Specific Data generated by GNAT.
  56    --
  57    --  Generate: To_Type_Specific_Data_Ptr
  58    --              (To_Addr_Ptr (To_Address (Tag) - Typeinfo_Offset).all);
  59
  60    function Build_Predef_Prims
  61      (Loc      : Source_Ptr;
  62       Tag_Node : Node_Id) return Node_Id;
  63    --  Build code that retrieves the address of the dispatch table containing
  64    --  the predefined Ada primitives:
  65    --
  66    --  Generate: To_Predef_Prims_Table_Ptr
  67    --              (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
  68
  69    ------------------------------------------------
  70    -- Build_Common_Dispatching_Select_Statements --
  71    ------------------------------------------------
  72
  73    procedure Build_Common_Dispatching_Select_Statements
  74      (Loc    : Source_Ptr;
  75       DT_Ptr : Entity_Id;
  76       Stmts  : List_Id)
  77    is
  78    begin
  79       --  Generate:
  80       --    C := get_prim_op_kind (tag! (<type>VP), S);
  81
  82       --  where C is the out parameter capturing the call kind and S is the
  83       --  dispatch table slot number.
  84
  85       Append_To (Stmts,
  86         Make_Assignment_Statement (Loc,
  87           Name =>
  88             Make_Identifier (Loc, Name_uC),
  89           Expression =>
  90             Make_Function_Call (Loc,
  91               Name => New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc),
  92               Parameter_Associations => New_List (
  93                 Unchecked_Convert_To (RTE (RE_Tag),
  94                   New_Reference_To (DT_Ptr, Loc)),
  95                 Make_Identifier (Loc, Name_uS)))));
  96
  97       --  Generate:
  98
  99       --    if C = POK_Procedure
 100       --      or else C = POK_Protected_Procedure
 101       --      or else C = POK_Task_Procedure;
 102       --    then
 103       --       F := True;
 104       --       return;
 105
 106       --  where F is the out parameter capturing the status of a potential
 107       --  entry call.
 108
 109       Append_To (Stmts,
 110         Make_If_Statement (Loc,
 111
 112           Condition =>
 113             Make_Or_Else (Loc,
 114               Left_Opnd =>
 115                 Make_Op_Eq (Loc,
 116                   Left_Opnd =>
 117                     Make_Identifier (Loc, Name_uC),
 118                   Right_Opnd =>
 119                     New_Reference_To (RTE (RE_POK_Procedure), Loc)),
 120               Right_Opnd =>
 121                 Make_Or_Else (Loc,
 122                   Left_Opnd =>
 123                     Make_Op_Eq (Loc,
 124                       Left_Opnd =>
 125                         Make_Identifier (Loc, Name_uC),
 126                       Right_Opnd =>
 127                         New_Reference_To (RTE (
 128                           RE_POK_Protected_Procedure), Loc)),
 129                   Right_Opnd =>
 130                     Make_Op_Eq (Loc,
 131                       Left_Opnd =>
 132                         Make_Identifier (Loc, Name_uC),
 133                       Right_Opnd =>
 134                         New_Reference_To (RTE (
 135                           RE_POK_Task_Procedure), Loc)))),
 136
 137           Then_Statements =>
 138             New_List (
 139               Make_Assignment_Statement (Loc,
 140                 Name       => Make_Identifier (Loc, Name_uF),
 141                 Expression => New_Reference_To (Standard_True, Loc)),
 142               Make_Simple_Return_Statement (Loc))));
 143    end Build_Common_Dispatching_Select_Statements;
 144
 145    -------------------------
 146    -- Build_CW_Membership --
 147    -------------------------
 148
 149    function Build_CW_Membership
 150      (Loc          : Source_Ptr;
 151       Obj_Tag_Node : Node_Id;
 152       Typ_Tag_Node : Node_Id) return Node_Id
 153    is
 154       function Build_Pos return Node_Id;
 155       --  Generate TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
 156
 157       function Build_Pos return Node_Id is
 158       begin
 159          return
 160             Make_Op_Subtract (Loc,
 161               Left_Opnd =>
 162                 Make_Selected_Component (Loc,
 163                   Prefix => Build_TSD (Loc, Duplicate_Subexpr (Obj_Tag_Node)),
 164                   Selector_Name =>
 165                     New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)),
 166
 167               Right_Opnd =>
 168                 Make_Selected_Component (Loc,
 169                   Prefix => Build_TSD (Loc, Duplicate_Subexpr (Typ_Tag_Node)),
 170                   Selector_Name =>
 171                     New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)));
 172       end Build_Pos;
 173
 174    --  Start of processing for Build_CW_Membership
 175
 176    begin
 177       return
 178         Make_And_Then (Loc,
 179           Left_Opnd =>
 180             Make_Op_Ge (Loc,
 181               Left_Opnd  => Build_Pos,
 182               Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
 183
 184           Right_Opnd =>
 185             Make_Op_Eq (Loc,
 186               Left_Opnd =>
 187                 Make_Indexed_Component (Loc,
 188                   Prefix =>
 189                     Make_Selected_Component (Loc,
 190                       Prefix => Build_TSD (Loc, Obj_Tag_Node),
 191                       Selector_Name =>
 192                         New_Reference_To
 193                           (RTE_Record_Component (RE_Tags_Table), Loc)),
 194                   Expressions =>
 195                     New_List (Build_Pos)),
 196
 197               Right_Opnd => Typ_Tag_Node));
 198    end Build_CW_Membership;
 199
 200    --------------
 201    -- Build_DT --
 202    --------------
 203
 204    function Build_DT
 205      (Loc      : Source_Ptr;
 206       Tag_Node : Node_Id) return Node_Id is
 207    begin
 208       return
 209         Make_Function_Call (Loc,
 210           Name => New_Reference_To (RTE (RE_DT), Loc),
 211           Parameter_Associations => New_List (
 212             Unchecked_Convert_To (RTE (RE_Tag), Tag_Node)));
 213    end Build_DT;
 214
 215    ----------------------------
 216    -- Build_Get_Access_Level --
 217    ----------------------------
 218
 219    function Build_Get_Access_Level
 220      (Loc      : Source_Ptr;
 221       Tag_Node : Node_Id) return Node_Id
 222    is
 223    begin
 224       return
 225         Make_Selected_Component (Loc,
 226           Prefix => Build_TSD (Loc, Tag_Node),
 227           Selector_Name =>
 228             New_Reference_To
 229               (RTE_Record_Component (RE_Access_Level), Loc));
 230    end Build_Get_Access_Level;
 231
 232    ------------------------------------------
 233    -- Build_Get_Predefined_Prim_Op_Address --
 234    ------------------------------------------
 235
 236    function Build_Get_Predefined_Prim_Op_Address
 237      (Loc      : Source_Ptr;
 238       Tag_Node : Node_Id;
 239       Position : Uint) return Node_Id
 240    is
 241    begin
 242       return
 243         Make_Indexed_Component (Loc,
 244           Prefix =>
 245             Build_Predef_Prims (Loc, Tag_Node),
 246           Expressions =>
 247             New_List (Make_Integer_Literal (Loc, Position)));
 248    end Build_Get_Predefined_Prim_Op_Address;
 249
 250    -------------------------
 251    -- Build_Inherit_Prims --
 252    -------------------------
 253
 254    function Build_Inherit_Prims
 255      (Loc          : Source_Ptr;
 256       Typ          : Entity_Id;
 257       Old_Tag_Node : Node_Id;
 258       New_Tag_Node : Node_Id;
 259       Num_Prims    : Nat) return Node_Id
 260    is
 261    begin
 262       if RTE_Available (RE_DT) then
 263          return
 264            Make_Assignment_Statement (Loc,
 265              Name =>
 266                Make_Slice (Loc,
 267                  Prefix =>
 268                    Make_Selected_Component (Loc,
 269                      Prefix =>
 270                        Build_DT (Loc, New_Tag_Node),
 271                      Selector_Name =>
 272                        New_Reference_To
 273                          (RTE_Record_Component (RE_Prims_Ptr), Loc)),
 274                  Discrete_Range =>
 275                    Make_Range (Loc,
 276                    Low_Bound  => Make_Integer_Literal (Loc, 1),
 277                    High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
 278
 279              Expression =>
 280                Make_Slice (Loc,
 281                  Prefix =>
 282                    Make_Selected_Component (Loc,
 283                      Prefix =>
 284                        Build_DT (Loc, Old_Tag_Node),
 285                      Selector_Name =>
 286                        New_Reference_To
 287                          (RTE_Record_Component (RE_Prims_Ptr), Loc)),
 288                  Discrete_Range =>
 289                    Make_Range (Loc,
 290                      Low_Bound  => Make_Integer_Literal (Loc, 1),
 291                      High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
 292       else
 293          return
 294            Make_Assignment_Statement (Loc,
 295              Name =>
 296                Make_Slice (Loc,
 297                  Prefix =>
 298                    Unchecked_Convert_To
 299                      (Node (Last_Elmt (Access_Disp_Table (Typ))),
 300                       New_Tag_Node),
 301                  Discrete_Range =>
 302                    Make_Range (Loc,
 303                    Low_Bound  => Make_Integer_Literal (Loc, 1),
 304                    High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
 305
 306              Expression =>
 307                Make_Slice (Loc,
 308                  Prefix =>
 309                    Unchecked_Convert_To
 310                      (Node (Last_Elmt (Access_Disp_Table (Typ))),
 311                       Old_Tag_Node),
 312                  Discrete_Range =>
 313                    Make_Range (Loc,
 314                      Low_Bound  => Make_Integer_Literal (Loc, 1),
 315                      High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
 316       end if;
 317    end Build_Inherit_Prims;
 318
 319    -------------------------------
 320    -- Build_Get_Prim_Op_Address --
 321    -------------------------------
 322
 323    function Build_Get_Prim_Op_Address
 324      (Loc      : Source_Ptr;
 325       Typ      : Entity_Id;
 326       Tag_Node : Node_Id;
 327       Position : Uint) return Node_Id
 328    is
 329    begin
 330       pragma Assert
 331         (Position <= DT_Entry_Count (First_Tag_Component (Typ)));
 332
 333       --  At the end of the Access_Disp_Table list we have the type
 334       --  declaration required to convert the tag into a pointer to
 335       --  the prims_ptr table (see Freeze_Record_Type).
 336
 337       return
 338         Make_Indexed_Component (Loc,
 339           Prefix =>
 340             Unchecked_Convert_To
 341               (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node),
 342           Expressions => New_List (Make_Integer_Literal (Loc, Position)));
 343    end Build_Get_Prim_Op_Address;
 344
 345    -----------------------------
 346    -- Build_Get_Transportable --
 347    -----------------------------
 348
 349    function Build_Get_Transportable
 350      (Loc      : Source_Ptr;
 351       Tag_Node : Node_Id) return Node_Id
 352    is
 353    begin
 354       return
 355         Make_Selected_Component (Loc,
 356           Prefix => Build_TSD (Loc, Tag_Node),
 357           Selector_Name =>
 358             New_Reference_To
 359               (RTE_Record_Component (RE_Transportable), Loc));
 360    end Build_Get_Transportable;
 361
 362    ------------------------------------
 363    -- Build_Inherit_Predefined_Prims --
 364    ------------------------------------
 365
 366    function Build_Inherit_Predefined_Prims
 367      (Loc          : Source_Ptr;
 368       Old_Tag_Node : Node_Id;
 369       New_Tag_Node : Node_Id) return Node_Id
 370    is
 371    begin
 372       return
 373         Make_Assignment_Statement (Loc,
 374           Name =>
 375             Make_Slice (Loc,
 376               Prefix =>
 377                 Make_Explicit_Dereference (Loc,
 378                   Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 379                     Make_Explicit_Dereference (Loc,
 380                       Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 381                         New_Tag_Node)))),
 382               Discrete_Range => Make_Range (Loc,
 383                 Make_Integer_Literal (Loc, Uint_1),
 384                 New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
 385
 386           Expression =>
 387             Make_Slice (Loc,
 388               Prefix =>
 389                 Make_Explicit_Dereference (Loc,
 390                   Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 391                     Make_Explicit_Dereference (Loc,
 392                       Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 393                         Old_Tag_Node)))),
 394               Discrete_Range =>
 395                 Make_Range (Loc,
 396                   Make_Integer_Literal (Loc, 1),
 397                   New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
 398    end Build_Inherit_Predefined_Prims;
 399
 400    ------------------------
 401    -- Build_Predef_Prims --
 402    ------------------------
 403
 404    function Build_Predef_Prims
 405      (Loc      : Source_Ptr;
 406       Tag_Node : Node_Id) return Node_Id
 407    is
 408    begin
 409       return
 410         Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 411           Make_Explicit_Dereference (Loc,
 412             Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 413               Make_Function_Call (Loc,
 414                 Name =>
 415                   Make_Expanded_Name (Loc,
 416                     Chars => Name_Op_Subtract,
 417                     Prefix =>
 418                       New_Reference_To
 419                         (RTU_Entity (System_Storage_Elements), Loc),
 420                     Selector_Name =>
 421                       Make_Identifier (Loc,
 422                         Chars => Name_Op_Subtract)),
 423
 424                 Parameter_Associations => New_List (
 425                   Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
 426                   New_Reference_To (RTE (RE_DT_Predef_Prims_Offset),
 427                                     Loc))))));
 428    end Build_Predef_Prims;
 429
 430    ------------------------------------------
 431    -- Build_Set_Predefined_Prim_Op_Address --
 432    ------------------------------------------
 433
 434    function Build_Set_Predefined_Prim_Op_Address
 435      (Loc          : Source_Ptr;
 436       Tag_Node     : Node_Id;
 437       Position     : Uint;
 438       Address_Node : Node_Id) return Node_Id
 439    is
 440    begin
 441       return
 442          Make_Assignment_Statement (Loc,
 443            Name =>
 444              Make_Indexed_Component (Loc,
 445                Prefix =>
 446                  Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 447                    Make_Explicit_Dereference (Loc,
 448                      Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))),
 449                Expressions =>
 450                  New_List (Make_Integer_Literal (Loc, Position))),
 451
 452            Expression => Address_Node);
 453    end Build_Set_Predefined_Prim_Op_Address;
 454
 455    -------------------------------
 456    -- Build_Set_Prim_Op_Address --
 457    -------------------------------
 458
 459    function Build_Set_Prim_Op_Address
 460      (Loc          : Source_Ptr;
 461       Typ          : Entity_Id;
 462       Tag_Node     : Node_Id;
 463       Position     : Uint;
 464       Address_Node : Node_Id) return Node_Id
 465    is
 466    begin
 467       return
 468         Make_Assignment_Statement (Loc,
 469           Name       => Build_Get_Prim_Op_Address
 470                           (Loc, Typ, Tag_Node, Position),
 471           Expression => Address_Node);
 472    end Build_Set_Prim_Op_Address;
 473
 474    ---------------
 475    -- Build_TSD --
 476    ---------------
 477
 478    function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id is
 479    begin
 480       return
 481         Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
 482           Make_Explicit_Dereference (Loc,
 483             Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 484               Make_Function_Call (Loc,
 485                 Name =>
 486                   Make_Expanded_Name (Loc,
 487                     Chars => Name_Op_Subtract,
 488                     Prefix =>
 489                       New_Reference_To
 490                         (RTU_Entity (System_Storage_Elements), Loc),
 491                     Selector_Name =>
 492                       Make_Identifier (Loc,
 493                         Chars => Name_Op_Subtract)),
 494
 495                 Parameter_Associations => New_List (
 496                   Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
 497                     New_Reference_To
 498                       (RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
 499    end Build_TSD;
 500
 501 end Exp_Atag;