gcc/ada/aspects.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              A S P E C T S                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2010-2023, 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 Einfo;          use Einfo;
  28 with Einfo.Entities; use Einfo.Entities;
  29 with Einfo.Utils;    use Einfo.Utils;
  30 with Nlists;         use Nlists;
  31 with Sinfo;          use Sinfo;
  32 with Sinfo.Nodes;    use Sinfo.Nodes;
  33 with Sinfo.Utils;    use Sinfo.Utils;
  34
  35 with GNAT.HTable;
  36
  37 package body Aspects is
  38
  39    --  The following array indicates aspects that a subtype inherits from its
  40    --  base type. True means that the subtype inherits the aspect from its base
  41    --  type. False means it is not inherited.
  42
  43    Base_Aspect : constant array (Aspect_Id) of Boolean :=
  44      (Aspect_Atomic                 => True,
  45       Aspect_Atomic_Components      => True,
  46       Aspect_Constant_Indexing      => True,
  47       Aspect_Default_Iterator       => True,
  48       Aspect_Discard_Names          => True,
  49       Aspect_Independent_Components => True,
  50       Aspect_Iterator_Element       => True,
  51       Aspect_Stable_Properties      => True,
  52       Aspect_Type_Invariant         => True,
  53       Aspect_Unchecked_Union        => True,
  54       Aspect_Variable_Indexing      => True,
  55       Aspect_Volatile               => True,
  56       Aspect_Volatile_Full_Access   => True,
  57       others                        => False);
  58
  59    --  The following array indicates type aspects that are inherited and apply
  60    --  to the class-wide type as well.
  61
  62    Inherited_Aspect : constant array (Aspect_Id) of Boolean :=
  63      (Aspect_Constant_Indexing    => True,
  64       Aspect_Default_Iterator     => True,
  65       Aspect_Implicit_Dereference => True,
  66       Aspect_Iterator_Element     => True,
  67       Aspect_Remote_Types         => True,
  68       Aspect_Variable_Indexing    => True,
  69       others                      => False);
  70
  71    -------------------------------------
  72    -- Hash Table for Aspect Id Values --
  73    -------------------------------------
  74
  75    type AI_Hash_Range is range 0 .. 112;
  76    --  Size of hash table headers
  77
  78    function AI_Hash (F : Name_Id) return AI_Hash_Range;
  79    --  Hash function for hash table
  80
  81    function AI_Hash (F : Name_Id) return AI_Hash_Range is
  82    begin
  83       return AI_Hash_Range (F mod 113);
  84    end AI_Hash;
  85
  86    package Aspect_Id_Hash_Table is new
  87      GNAT.HTable.Simple_HTable
  88        (Header_Num => AI_Hash_Range,
  89         Element    => Aspect_Id,
  90         No_Element => No_Aspect,
  91         Key        => Name_Id,
  92         Hash       => AI_Hash,
  93         Equal      => "=");
  94
  95    --------------------------------
  96    -- Aspects_On_Body_Or_Stub_OK --
  97    --------------------------------
  98
  99    function Aspects_On_Body_Or_Stub_OK (N : Node_Id) return Boolean is
 100       Aspect  : Node_Id;
 101       Aspects : List_Id;
 102
 103    begin
 104       --  The routine should be invoked on a body [stub] with aspects
 105
 106       pragma Assert (Has_Aspects (N));
 107       pragma Assert
 108         (Nkind (N) in N_Body_Stub      | N_Entry_Body      | N_Package_Body |
 109                       N_Protected_Body | N_Subprogram_Body | N_Task_Body);
 110
 111       --  Look through all aspects and see whether they can be applied to a
 112       --  body [stub].
 113
 114       Aspects := Aspect_Specifications (N);
 115       Aspect  := First (Aspects);
 116       while Present (Aspect) loop
 117          if not Aspect_On_Body_Or_Stub_OK (Get_Aspect_Id (Aspect)) then
 118             return False;
 119          end if;
 120
 121          Next (Aspect);
 122       end loop;
 123
 124       return True;
 125    end Aspects_On_Body_Or_Stub_OK;
 126
 127    -----------------
 128    -- Find_Aspect --
 129    -----------------
 130
 131    function Find_Aspect
 132      (Id            : Entity_Id;
 133       A             : Aspect_Id;
 134       Class_Present : Boolean := False;
 135       Or_Rep_Item   : Boolean := False) return Node_Id
 136    is
 137       Decl                 : Node_Id;
 138       Item                 : Node_Id;
 139       Owner                : Entity_Id;
 140       Spec                 : Node_Id;
 141       Alternative_Rep_Item : Node_Id := Empty;
 142    begin
 143       Owner := Id;
 144
 145       --  Handle various cases of base or inherited aspects for types
 146
 147       if Is_Type (Id) then
 148          if Base_Aspect (A) then
 149             Owner := Base_Type (Owner);
 150          end if;
 151
 152          if Is_Class_Wide_Type (Owner) and then Inherited_Aspect (A) then
 153             Owner := Root_Type (Owner);
 154          end if;
 155
 156          if Is_Private_Type (Owner)
 157            and then Present (Full_View (Owner))
 158            and then not Operational_Aspect (A)
 159          then
 160             Owner := Full_View (Owner);
 161          end if;
 162       end if;
 163
 164       --  Search the representation items for the desired aspect
 165
 166       Item := First_Rep_Item (Owner);
 167       while Present (Item) loop
 168          if Nkind (Item) = N_Aspect_Specification
 169            and then Get_Aspect_Id (Item) = A
 170            and then Class_Present = Sinfo.Nodes.Class_Present (Item)
 171          then
 172             return Item;
 173
 174          --  We could do something similar here for an N_Pragma node
 175          --  when Get_Aspect_Id (Pragma_Name (Item)) = A, but let's
 176          --  wait for a demonstrated need.
 177
 178          elsif Or_Rep_Item
 179            and then not Class_Present
 180            and then Nkind (Item) = N_Attribute_Definition_Clause
 181            and then Get_Aspect_Id (Chars (Item)) = A
 182          then
 183             --  Remember this candidate in case we don't find anything better
 184             Alternative_Rep_Item := Item;
 185          end if;
 186
 187          Next_Rep_Item (Item);
 188       end loop;
 189
 190       --  Note that not all aspects are added to the chain of representation
 191       --  items. In such cases, search the list of aspect specifications. First
 192       --  find the declaration node where the aspects reside. This is usually
 193       --  the parent or the parent of the parent.
 194
 195       if No (Parent (Owner)) then
 196          return Empty;
 197       end if;
 198
 199       Decl := Parent (Owner);
 200       if not Permits_Aspect_Specifications (Decl) then
 201          Decl := Parent (Decl);
 202
 203          if No (Decl) then
 204             --  Perhaps this happens because the tree is under construction
 205             --  and Parent (Decl) has not been set yet?
 206
 207             return Empty;
 208          end if;
 209       end if;
 210
 211       --  Search the list of aspect specifications for the desired aspect
 212
 213       if Permits_Aspect_Specifications (Decl) then
 214          Spec := First (Aspect_Specifications (Decl));
 215          while Present (Spec) loop
 216             if Get_Aspect_Id (Spec) = A
 217               and then Class_Present = Sinfo.Nodes.Class_Present (Spec)
 218             then
 219                return Spec;
 220             end if;
 221
 222             declare
 223                use User_Aspect_Support;
 224             begin
 225                if Get_Aspect_Id (Spec) = Aspect_User_Aspect
 226                   and then not Analyzed (Spec)
 227                   and then
 228                     Analyze_User_Aspect_Aspect_Specification_Hook /= null
 229                then
 230                   Analyze_User_Aspect_Aspect_Specification_Hook.all (Spec);
 231                end if;
 232             end;
 233
 234             Next (Spec);
 235          end loop;
 236       end if;
 237
 238       --  The entity does not carry any aspects or the desired aspect was not
 239       --  found. We have no N_Aspect_Specification node to return, but
 240       --  Alternative_Rep_Item may have been set (if Or_Rep_Item is True).
 241
 242       return Alternative_Rep_Item;
 243    end Find_Aspect;
 244
 245    --------------------------
 246    -- Find_Value_Of_Aspect --
 247    --------------------------
 248
 249    function Find_Value_Of_Aspect
 250      (Id            : Entity_Id;
 251       A             : Aspect_Id;
 252       Class_Present : Boolean := False) return Node_Id
 253    is
 254       Spec : constant Node_Id := Find_Aspect (Id, A,
 255                                               Class_Present => Class_Present);
 256
 257    begin
 258       if Present (Spec) then
 259          if A = Aspect_Default_Iterator
 260            and then Present (Aspect_Rep_Item (Spec))
 261          then
 262             return Expression (Aspect_Rep_Item (Spec));
 263          else
 264             return Expression (Spec);
 265          end if;
 266       end if;
 267
 268       return Empty;
 269    end Find_Value_Of_Aspect;
 270
 271    -------------------
 272    -- Get_Aspect_Id --
 273    -------------------
 274
 275    function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is
 276    begin
 277       return Aspect_Id_Hash_Table.Get (Name);
 278    end Get_Aspect_Id;
 279
 280    function Get_Aspect_Id (Aspect : Node_Id) return Aspect_Id is
 281    begin
 282       pragma Assert (Nkind (Aspect) = N_Aspect_Specification);
 283       return Aspect_Id_Hash_Table.Get (Chars (Identifier (Aspect)));
 284    end Get_Aspect_Id;
 285
 286    ----------------
 287    -- Has_Aspect --
 288    ----------------
 289
 290    function Has_Aspect
 291      (Id            : Entity_Id;
 292       A             : Aspect_Id;
 293       Class_Present : Boolean := False) return Boolean
 294    is
 295    begin
 296       return Present (Find_Aspect (Id, A, Class_Present => Class_Present));
 297    end Has_Aspect;
 298
 299    function Has_Aspects (N : Node_Id) return Boolean
 300    is (Atree.Present (N) and then
 301        Permits_Aspect_Specifications (N) and then
 302        Nlists.Present (Sinfo.Nodes.Aspect_Specifications (N)) and then
 303        Nlists.Is_Non_Empty_List (Sinfo.Nodes.Aspect_Specifications (N)));
 304
 305    ------------------
 306    -- Is_Aspect_Id --
 307    ------------------
 308
 309    function Is_Aspect_Id (Aspect : Name_Id) return Boolean is
 310      (Get_Aspect_Id (Aspect) /= No_Aspect);
 311
 312    function Is_Aspect_Id (Aspect : Node_Id) return Boolean is
 313      (Get_Aspect_Id (Aspect) /= No_Aspect);
 314
 315    ------------------
 316    -- Move_Aspects --
 317    ------------------
 318
 319    procedure Move_Aspects (From : Node_Id; To : Node_Id) is
 320       pragma Assert (not Has_Aspects (To));
 321    begin
 322       if Has_Aspects (From) then
 323          Set_Aspect_Specifications (To, Aspect_Specifications (From));
 324          Set_Aspect_Specifications (From, No_List);
 325       end if;
 326    end Move_Aspects;
 327
 328    ---------------------------
 329    -- Move_Or_Merge_Aspects --
 330    ---------------------------
 331
 332    procedure Move_Or_Merge_Aspects (From : Node_Id; To : Node_Id) is
 333       procedure Relocate_Aspect (Asp : Node_Id);
 334       --  Move aspect specification Asp to the aspect specifications of node To
 335
 336       ---------------------
 337       -- Relocate_Aspect --
 338       ---------------------
 339
 340       procedure Relocate_Aspect (Asp : Node_Id) is
 341          Asps : List_Id;
 342
 343       begin
 344          if Has_Aspects (To) then
 345             Asps := Aspect_Specifications (To);
 346
 347          --  Create a new aspect specification list for node To
 348
 349          else
 350             Asps := New_List;
 351             Set_Aspect_Specifications (To, Asps);
 352          end if;
 353
 354          --  Remove the aspect from its original owner and relocate it to node
 355          --  To.
 356
 357          Remove (Asp);
 358          Append (Asp, Asps);
 359       end Relocate_Aspect;
 360
 361       --  Local variables
 362
 363       Asp      : Node_Id;
 364       Asp_Id   : Aspect_Id;
 365       Next_Asp : Node_Id;
 366
 367    --  Start of processing for Move_Or_Merge_Aspects
 368
 369    begin
 370       if Has_Aspects (From) then
 371          Asp := First (Aspect_Specifications (From));
 372          while Present (Asp) loop
 373
 374             --  Store the next aspect now as a potential relocation will alter
 375             --  the contents of the list.
 376
 377             Next_Asp := Next (Asp);
 378
 379             --  When moving or merging aspects from a subprogram body stub that
 380             --  also acts as a spec, relocate only those aspects that may apply
 381             --  to a body [stub]. Note that a precondition must also be moved
 382             --  to the proper body as the pre/post machinery expects it to be
 383             --  there.
 384
 385             if Nkind (From) = N_Subprogram_Body_Stub
 386               and then No (Corresponding_Spec_Of_Stub (From))
 387             then
 388                Asp_Id := Get_Aspect_Id (Asp);
 389
 390                if Aspect_On_Body_Or_Stub_OK (Asp_Id)
 391                  or else Asp_Id = Aspect_Pre
 392                  or else Asp_Id = Aspect_Precondition
 393                then
 394                   Relocate_Aspect (Asp);
 395                end if;
 396
 397             --  When moving or merging aspects from a single concurrent type
 398             --  declaration, relocate only those aspects that may apply to the
 399             --  anonymous object created for the type.
 400
 401             --  Note: It is better to use Is_Single_Concurrent_Type_Declaration
 402             --  here, but Aspects and Sem_Util have incompatible licenses.
 403
 404             elsif Nkind (Original_Node (From)) in
 405                     N_Single_Protected_Declaration | N_Single_Task_Declaration
 406             then
 407                Asp_Id := Get_Aspect_Id (Asp);
 408
 409                if Aspect_On_Anonymous_Object_OK (Asp_Id) then
 410                   Relocate_Aspect (Asp);
 411                end if;
 412
 413             --  Default case - relocate the aspect to its new owner
 414
 415             else
 416                Relocate_Aspect (Asp);
 417             end if;
 418
 419             Asp := Next_Asp;
 420          end loop;
 421
 422          --  The relocations may have left node From's aspect specifications
 423          --  list empty. If this is the case, simply remove the aspects.
 424
 425          if Is_Empty_List (Aspect_Specifications (From)) then
 426             Remove_Aspects (From);
 427          end if;
 428       end if;
 429    end Move_Or_Merge_Aspects;
 430
 431    -------------------
 432    --  Copy_Aspects --
 433    -------------------
 434
 435    procedure Copy_Aspects (From : Node_Id; To : Node_Id) is
 436
 437    begin
 438       if not Has_Aspects (From) then
 439          return;
 440       end if;
 441
 442       Set_Aspect_Specifications
 443          (To, New_Copy_List (Aspect_Specifications (From)));
 444    end Copy_Aspects;
 445
 446    -----------------------------------
 447    -- Permits_Aspect_Specifications --
 448    -----------------------------------
 449
 450    Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean :=
 451      (N_Abstract_Subprogram_Declaration        => True,
 452       N_Component_Declaration                  => True,
 453       N_Entry_Body                             => True,
 454       N_Entry_Declaration                      => True,
 455       N_Exception_Declaration                  => True,
 456       N_Exception_Renaming_Declaration         => True,
 457       N_Expression_Function                    => True,
 458       N_Formal_Abstract_Subprogram_Declaration => True,
 459       N_Formal_Concrete_Subprogram_Declaration => True,
 460       N_Formal_Object_Declaration              => True,
 461       N_Formal_Package_Declaration             => True,
 462       N_Formal_Type_Declaration                => True,
 463       N_Full_Type_Declaration                  => True,
 464       N_Function_Instantiation                 => True,
 465       N_Generic_Package_Declaration            => True,
 466       N_Generic_Renaming_Declaration           => True,
 467       N_Generic_Subprogram_Declaration         => True,
 468       N_Object_Declaration                     => True,
 469       N_Object_Renaming_Declaration            => True,
 470       N_Package_Body                           => True,
 471       N_Package_Body_Stub                      => True,
 472       N_Package_Declaration                    => True,
 473       N_Package_Instantiation                  => True,
 474       N_Package_Specification                  => True,
 475       N_Package_Renaming_Declaration           => True,
 476       N_Parameter_Specification                => True,
 477       N_Private_Extension_Declaration          => True,
 478       N_Private_Type_Declaration               => True,
 479       N_Procedure_Instantiation                => True,
 480       N_Protected_Body                         => True,
 481       N_Protected_Body_Stub                    => True,
 482       N_Protected_Type_Declaration             => True,
 483       N_Single_Protected_Declaration           => True,
 484       N_Single_Task_Declaration                => True,
 485       N_Subprogram_Body                        => True,
 486       N_Subprogram_Body_Stub                   => True,
 487       N_Subprogram_Declaration                 => True,
 488       N_Subprogram_Renaming_Declaration        => True,
 489       N_Subtype_Declaration                    => True,
 490       N_Task_Body                              => True,
 491       N_Task_Body_Stub                         => True,
 492       N_Task_Type_Declaration                  => True,
 493       others                                   => False);
 494
 495    function Permits_Aspect_Specifications (N : Node_Id) return Boolean is
 496    begin
 497       pragma Assert (Present (N));
 498       return Has_Aspect_Specifications_Flag (Nkind (N));
 499    end Permits_Aspect_Specifications;
 500
 501    --------------------
 502    -- Remove_Aspects --
 503    --------------------
 504
 505    procedure Remove_Aspects (N : Node_Id) is
 506    begin
 507       if Has_Aspects (N) then
 508          Set_Aspect_Specifications (N, No_List);
 509       end if;
 510    end Remove_Aspects;
 511
 512    -----------------
 513    -- Same_Aspect --
 514    -----------------
 515
 516    --  Table used for Same_Aspect, maps aspect to canonical aspect
 517
 518    type Aspect_To_Aspect_Mapping is array (Aspect_Id) of Aspect_Id;
 519
 520    function Init_Canonical_Aspect return Aspect_To_Aspect_Mapping;
 521    --  Initialize the Canonical_Aspect mapping below
 522
 523    function Init_Canonical_Aspect return Aspect_To_Aspect_Mapping is
 524       Result : Aspect_To_Aspect_Mapping;
 525    begin
 526       --  They all map to themselves...
 527
 528       for Aspect in Aspect_Id loop
 529          Result (Aspect) := Aspect;
 530       end loop;
 531
 532       --  ...except for these:
 533
 534       Result (Aspect_Dynamic_Predicate)  := Aspect_Predicate;
 535       Result (Aspect_Ghost_Predicate)    := Aspect_Predicate;
 536       Result (Aspect_Inline_Always)      := Aspect_Inline;
 537       Result (Aspect_Interrupt_Priority) := Aspect_Priority;
 538       Result (Aspect_Postcondition)      := Aspect_Post;
 539       Result (Aspect_Precondition)       := Aspect_Pre;
 540       Result (Aspect_Shared)             := Aspect_Atomic;
 541       Result (Aspect_Static_Predicate)   := Aspect_Predicate;
 542       Result (Aspect_Type_Invariant)     := Aspect_Invariant;
 543
 544       return Result;
 545    end Init_Canonical_Aspect;
 546
 547    Canonical_Aspect : constant Aspect_To_Aspect_Mapping :=
 548      Init_Canonical_Aspect;
 549
 550    function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is
 551    begin
 552       return Canonical_Aspect (A1) = Canonical_Aspect (A2);
 553    end Same_Aspect;
 554
 555    package body User_Aspect_Support is
 556
 557       --  This is similar to the way that user-defined check names are
 558       --  managed via package Checks.Check_Names; simple global state.
 559
 560       UAD_Pragma_Map_Size : constant := 511;
 561
 562       subtype UAD_Pragma_Map_Header is
 563         Integer range 0 .. UAD_Pragma_Map_Size - 1;
 564
 565       function UAD_Pragma_Map_Hash (Chars : Name_Id)
 566         return UAD_Pragma_Map_Header
 567       is (UAD_Pragma_Map_Header (Chars mod UAD_Pragma_Map_Size));
 568
 569       package UAD_Pragma_Map is new GNAT.Htable.Simple_Htable
 570         (Header_Num => UAD_Pragma_Map_Header,
 571          Key        => Name_Id,
 572          Element    => Opt_N_Pragma_Id,
 573          No_Element => Empty,
 574          Hash       => UAD_Pragma_Map_Hash,
 575          Equal      => "=");
 576
 577       procedure Register_UAD_Pragma (UAD_Pragma : Node_Id) is
 578          Aspect_Name : constant Name_Id :=
 579            Chars (Expression
 580                     (First (Pragma_Argument_Associations (UAD_Pragma))));
 581       begin
 582          UAD_Pragma_Map.Set (Aspect_Name, UAD_Pragma);
 583       end Register_UAD_Pragma;
 584
 585       function Registered_UAD_Pragma (Aspect_Name : Name_Id) return Node_Id is
 586       begin
 587          return UAD_Pragma_Map.Get (Aspect_Name);
 588       end Registered_UAD_Pragma;
 589    end User_Aspect_Support;
 590
 591 --  Package initialization sets up Aspect Id hash table
 592
 593 begin
 594    for J in Aspect_Id loop
 595       Aspect_Id_Hash_Table.Set (Aspect_Names (J), J);
 596    end loop;
 597 end Aspects;