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