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 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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 Einfo;    use Einfo;
  28 with Elists;   use Elists;
  29 with Exp_Util; use Exp_Util;
  30 with Nlists;   use Nlists;
  31 with Nmake;    use Nmake;
  32 with Rtsfind;  use Rtsfind;
  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_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       Old_Tag_Node : Node_Id;
 257       New_Tag_Node : Node_Id;
 258       Num_Prims    : Nat) return Node_Id
 259    is
 260    begin
 261       return
 262         Make_Assignment_Statement (Loc,
 263           Name =>
 264             Make_Slice (Loc,
 265               Prefix =>
 266                 Make_Selected_Component (Loc,
 267                   Prefix =>
 268                     Build_DT (Loc, New_Tag_Node),
 269                   Selector_Name =>
 270                     New_Reference_To
 271                       (RTE_Record_Component (RE_Prims_Ptr), Loc)),
 272               Discrete_Range =>
 273                 Make_Range (Loc,
 274                 Low_Bound  => Make_Integer_Literal (Loc, 1),
 275                 High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
 276
 277           Expression =>
 278             Make_Slice (Loc,
 279               Prefix =>
 280                 Make_Selected_Component (Loc,
 281                   Prefix =>
 282                     Build_DT (Loc, Old_Tag_Node),
 283                   Selector_Name =>
 284                     New_Reference_To
 285                       (RTE_Record_Component (RE_Prims_Ptr), Loc)),
 286               Discrete_Range =>
 287                 Make_Range (Loc,
 288                 Low_Bound  => Make_Integer_Literal (Loc, 1),
 289                 High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
 290    end Build_Inherit_Prims;
 291
 292    -------------------------------
 293    -- Build_Get_Prim_Op_Address --
 294    -------------------------------
 295
 296    function Build_Get_Prim_Op_Address
 297      (Loc      : Source_Ptr;
 298       Typ      : Entity_Id;
 299       Tag_Node : Node_Id;
 300       Position : Uint) return Node_Id
 301    is
 302    begin
 303       pragma Assert
 304         (Position <= DT_Entry_Count (First_Tag_Component (Typ)));
 305
 306       --  At the end of the Access_Disp_Table list we have the type
 307       --  declaration required to convert the tag into a pointer to
 308       --  the prims_ptr table (see Freeze_Record_Type).
 309
 310       return
 311         Make_Indexed_Component (Loc,
 312           Prefix =>
 313             Unchecked_Convert_To
 314               (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node),
 315           Expressions => New_List (Make_Integer_Literal (Loc, Position)));
 316    end Build_Get_Prim_Op_Address;
 317
 318    -----------------------------
 319    -- Build_Get_Transportable --
 320    -----------------------------
 321
 322    function Build_Get_Transportable
 323      (Loc      : Source_Ptr;
 324       Tag_Node : Node_Id) return Node_Id
 325    is
 326    begin
 327       return
 328         Make_Selected_Component (Loc,
 329           Prefix => Build_TSD (Loc, Tag_Node),
 330           Selector_Name =>
 331             New_Reference_To
 332               (RTE_Record_Component (RE_Transportable), Loc));
 333    end Build_Get_Transportable;
 334
 335    ------------------------------------
 336    -- Build_Inherit_Predefined_Prims --
 337    ------------------------------------
 338
 339    function Build_Inherit_Predefined_Prims
 340      (Loc          : Source_Ptr;
 341       Old_Tag_Node : Node_Id;
 342       New_Tag_Node : Node_Id) return Node_Id
 343    is
 344    begin
 345       return
 346         Make_Assignment_Statement (Loc,
 347           Name =>
 348             Make_Slice (Loc,
 349               Prefix =>
 350                 Make_Explicit_Dereference (Loc,
 351                   Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 352                     Make_Selected_Component (Loc,
 353                       Prefix =>
 354                         Build_DT (Loc, New_Tag_Node),
 355                       Selector_Name =>
 356                         New_Reference_To
 357                           (RTE_Record_Component (RE_Predef_Prims), Loc)))),
 358               Discrete_Range => Make_Range (Loc,
 359                 Make_Integer_Literal (Loc, Uint_1),
 360                 New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc))),
 361
 362           Expression =>
 363             Make_Slice (Loc,
 364               Prefix =>
 365                 Make_Explicit_Dereference (Loc,
 366                   Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 367                     Make_Selected_Component (Loc,
 368                       Prefix =>
 369                         Build_DT (Loc, Old_Tag_Node),
 370                       Selector_Name =>
 371                         New_Reference_To
 372                           (RTE_Record_Component (RE_Predef_Prims), Loc)))),
 373               Discrete_Range =>
 374                 Make_Range (Loc,
 375                   Low_Bound  => Make_Integer_Literal (Loc, 1),
 376                   High_Bound =>
 377                     New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc))));
 378    end Build_Inherit_Predefined_Prims;
 379
 380    ------------------------
 381    -- Build_Predef_Prims --
 382    ------------------------
 383
 384    function Build_Predef_Prims
 385      (Loc      : Source_Ptr;
 386       Tag_Node : Node_Id) return Node_Id
 387    is
 388    begin
 389       return
 390         Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 391           Make_Explicit_Dereference (Loc,
 392             Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 393               Make_Function_Call (Loc,
 394                 Name =>
 395                   Make_Expanded_Name (Loc,
 396                     Chars => Name_Op_Subtract,
 397                     Prefix =>
 398                       New_Reference_To
 399                         (RTU_Entity (System_Storage_Elements), Loc),
 400                     Selector_Name =>
 401                       Make_Identifier (Loc,
 402                         Chars => Name_Op_Subtract)),
 403
 404                 Parameter_Associations => New_List (
 405                   Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
 406                   New_Reference_To (RTE (RE_DT_Predef_Prims_Offset),
 407                                     Loc))))));
 408    end Build_Predef_Prims;
 409
 410    ------------------------------------------
 411    -- Build_Set_Predefined_Prim_Op_Address --
 412    ------------------------------------------
 413
 414    function Build_Set_Predefined_Prim_Op_Address
 415      (Loc          : Source_Ptr;
 416       Tag_Node     : Node_Id;
 417       Position     : Uint;
 418       Address_Node : Node_Id) return Node_Id
 419    is
 420    begin
 421       return
 422          Make_Assignment_Statement (Loc,
 423            Name       => Build_Get_Predefined_Prim_Op_Address (Loc,
 424                            Tag_Node, Position),
 425            Expression => Address_Node);
 426    end Build_Set_Predefined_Prim_Op_Address;
 427
 428    -------------------------------
 429    -- Build_Set_Prim_Op_Address --
 430    -------------------------------
 431
 432    function Build_Set_Prim_Op_Address
 433      (Loc          : Source_Ptr;
 434       Typ          : Entity_Id;
 435       Tag_Node     : Node_Id;
 436       Position     : Uint;
 437       Address_Node : Node_Id) return Node_Id
 438    is
 439    begin
 440       return
 441         Make_Assignment_Statement (Loc,
 442           Name       => Build_Get_Prim_Op_Address
 443                           (Loc, Typ, Tag_Node, Position),
 444           Expression => Address_Node);
 445    end Build_Set_Prim_Op_Address;
 446
 447    ---------------
 448    -- Build_TSD --
 449    ---------------
 450
 451    function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id is
 452    begin
 453       return
 454         Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
 455           Make_Explicit_Dereference (Loc,
 456             Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 457               Make_Function_Call (Loc,
 458                 Name =>
 459                   Make_Expanded_Name (Loc,
 460                     Chars => Name_Op_Subtract,
 461                     Prefix =>
 462                       New_Reference_To
 463                         (RTU_Entity (System_Storage_Elements), Loc),
 464                     Selector_Name =>
 465                       Make_Identifier (Loc,
 466                         Chars => Name_Op_Subtract)),
 467
 468                 Parameter_Associations => New_List (
 469                   Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
 470                     New_Reference_To
 471                       (RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
 472    end Build_TSD;
 473
 474 end Exp_Atag;