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