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;
 197       Or_Rep_Item   : Boolean := False) return Node_Id
 198    is
 199       Decl                 : Node_Id;
 200       Item                 : Node_Id;
 201       Owner                : Entity_Id;
 202       Spec                 : Node_Id;
 203       Alternative_Rep_Item : Node_Id := Empty;
 204    begin
 205       Owner := Id;
 206
 207       --  Handle various cases of base or inherited aspects for types
 208
 209       if Is_Type (Id) then
 210          if Base_Aspect (A) then
 211             Owner := Base_Type (Owner);
 212          end if;
 213
 214          if Is_Class_Wide_Type (Owner) and then Inherited_Aspect (A) then
 215             Owner := Root_Type (Owner);
 216          end if;
 217
 218          if Is_Private_Type (Owner)
 219            and then Present (Full_View (Owner))
 220            and then not Operational_Aspect (A)
 221          then
 222             Owner := Full_View (Owner);
 223          end if;
 224       end if;
 225
 226       --  Search the representation items for the desired aspect
 227
 228       Item := First_Rep_Item (Owner);
 229       while Present (Item) loop
 230          if Nkind (Item) = N_Aspect_Specification
 231            and then Get_Aspect_Id (Item) = A
 232            and then Class_Present = Sinfo.Nodes.Class_Present (Item)
 233          then
 234             return Item;
 235
 236          --  We could do something similar here for an N_Pragma node
 237          --  when Get_Aspect_Id (Pragma_Name (Item)) = A, but let's
 238          --  wait for a demonstrated need.
 239
 240          elsif Or_Rep_Item
 241            and then not Class_Present
 242            and then Nkind (Item) = N_Attribute_Definition_Clause
 243            and then Get_Aspect_Id (Chars (Item)) = A
 244          then
 245             --  Remember this candidate in case we don't find anything better
 246             Alternative_Rep_Item := Item;
 247          end if;
 248
 249          Next_Rep_Item (Item);
 250       end loop;
 251
 252       --  Note that not all aspects are added to the chain of representation
 253       --  items. In such cases, search the list of aspect specifications. First
 254       --  find the declaration node where the aspects reside. This is usually
 255       --  the parent or the parent of the parent.
 256
 257       if No (Parent (Owner)) then
 258          return Empty;
 259       end if;
 260
 261       Decl := Parent (Owner);
 262       if not Permits_Aspect_Specifications (Decl) then
 263          Decl := Parent (Decl);
 264       end if;
 265
 266       --  Search the list of aspect specifications for the desired aspect
 267
 268       if Permits_Aspect_Specifications (Decl) then
 269          Spec := First (Aspect_Specifications (Decl));
 270          while Present (Spec) loop
 271             if Get_Aspect_Id (Spec) = A
 272               and then Class_Present = Sinfo.Nodes.Class_Present (Spec)
 273             then
 274                return Spec;
 275             end if;
 276
 277             Next (Spec);
 278          end loop;
 279       end if;
 280
 281       --  The entity does not carry any aspects or the desired aspect was not
 282       --  found. We have no N_Aspect_Specification node to return, but
 283       --  Alternative_Rep_Item may have been set (if Or_Rep_Item is True).
 284
 285       return Alternative_Rep_Item;
 286    end Find_Aspect;
 287
 288    --------------------------
 289    -- Find_Value_Of_Aspect --
 290    --------------------------
 291
 292    function Find_Value_Of_Aspect
 293      (Id            : Entity_Id;
 294       A             : Aspect_Id;
 295       Class_Present : Boolean := False) return Node_Id
 296    is
 297       Spec : constant Node_Id := Find_Aspect (Id, A,
 298                                               Class_Present => Class_Present);
 299
 300    begin
 301       if Present (Spec) then
 302          if A = Aspect_Default_Iterator
 303            and then Present (Aspect_Rep_Item (Spec))
 304          then
 305             return Expression (Aspect_Rep_Item (Spec));
 306          else
 307             return Expression (Spec);
 308          end if;
 309       end if;
 310
 311       return Empty;
 312    end Find_Value_Of_Aspect;
 313
 314    -------------------
 315    -- Get_Aspect_Id --
 316    -------------------
 317
 318    function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is
 319    begin
 320       return Aspect_Id_Hash_Table.Get (Name);
 321    end Get_Aspect_Id;
 322
 323    function Get_Aspect_Id (Aspect : Node_Id) return Aspect_Id is
 324    begin
 325       pragma Assert (Nkind (Aspect) = N_Aspect_Specification);
 326       return Aspect_Id_Hash_Table.Get (Chars (Identifier (Aspect)));
 327    end Get_Aspect_Id;
 328
 329    ----------------
 330    -- Has_Aspect --
 331    ----------------
 332
 333    function Has_Aspect
 334      (Id            : Entity_Id;
 335       A             : Aspect_Id;
 336       Class_Present : Boolean := False) return Boolean
 337    is
 338    begin
 339       return Present (Find_Aspect (Id, A, Class_Present => Class_Present));
 340    end Has_Aspect;
 341
 342    ------------------
 343    -- Is_Aspect_Id --
 344    ------------------
 345
 346    function Is_Aspect_Id (Aspect : Name_Id) return Boolean is
 347      (Get_Aspect_Id (Aspect) /= No_Aspect);
 348
 349    function Is_Aspect_Id (Aspect : Node_Id) return Boolean is
 350      (Get_Aspect_Id (Aspect) /= No_Aspect);
 351
 352    ------------------
 353    -- Move_Aspects --
 354    ------------------
 355
 356    procedure Move_Aspects (From : Node_Id; To : Node_Id) is
 357       pragma Assert (not Has_Aspects (To));
 358    begin
 359       if Has_Aspects (From) then
 360          Set_Aspect_Specifications (To, Aspect_Specifications (From));
 361          Aspect_Specifications_Hash_Table.Remove (From);
 362          Set_Has_Aspects (From, False);
 363       end if;
 364    end Move_Aspects;
 365
 366    ---------------------------
 367    -- Move_Or_Merge_Aspects --
 368    ---------------------------
 369
 370    procedure Move_Or_Merge_Aspects (From : Node_Id; To : Node_Id) is
 371       procedure Relocate_Aspect (Asp : Node_Id);
 372       --  Move aspect specification Asp to the aspect specifications of node To
 373
 374       ---------------------
 375       -- Relocate_Aspect --
 376       ---------------------
 377
 378       procedure Relocate_Aspect (Asp : Node_Id) is
 379          Asps : List_Id;
 380
 381       begin
 382          if Has_Aspects (To) then
 383             Asps := Aspect_Specifications (To);
 384
 385          --  Create a new aspect specification list for node To
 386
 387          else
 388             Asps := New_List;
 389             Set_Aspect_Specifications (To, Asps);
 390          end if;
 391
 392          --  Remove the aspect from its original owner and relocate it to node
 393          --  To.
 394
 395          Remove (Asp);
 396          Append (Asp, Asps);
 397       end Relocate_Aspect;
 398
 399       --  Local variables
 400
 401       Asp      : Node_Id;
 402       Asp_Id   : Aspect_Id;
 403       Next_Asp : Node_Id;
 404
 405    --  Start of processing for Move_Or_Merge_Aspects
 406
 407    begin
 408       if Has_Aspects (From) then
 409          Asp := First (Aspect_Specifications (From));
 410          while Present (Asp) loop
 411
 412             --  Store the next aspect now as a potential relocation will alter
 413             --  the contents of the list.
 414
 415             Next_Asp := Next (Asp);
 416
 417             --  When moving or merging aspects from a subprogram body stub that
 418             --  also acts as a spec, relocate only those aspects that may apply
 419             --  to a body [stub]. Note that a precondition must also be moved
 420             --  to the proper body as the pre/post machinery expects it to be
 421             --  there.
 422
 423             if Nkind (From) = N_Subprogram_Body_Stub
 424               and then No (Corresponding_Spec_Of_Stub (From))
 425             then
 426                Asp_Id := Get_Aspect_Id (Asp);
 427
 428                if Aspect_On_Body_Or_Stub_OK (Asp_Id)
 429                  or else Asp_Id = Aspect_Pre
 430                  or else Asp_Id = Aspect_Precondition
 431                then
 432                   Relocate_Aspect (Asp);
 433                end if;
 434
 435             --  When moving or merging aspects from a single concurrent type
 436             --  declaration, relocate only those aspects that may apply to the
 437             --  anonymous object created for the type.
 438
 439             --  Note: It is better to use Is_Single_Concurrent_Type_Declaration
 440             --  here, but Aspects and Sem_Util have incompatible licenses.
 441
 442             elsif Nkind (Original_Node (From)) in
 443                     N_Single_Protected_Declaration | N_Single_Task_Declaration
 444             then
 445                Asp_Id := Get_Aspect_Id (Asp);
 446
 447                if Aspect_On_Anonymous_Object_OK (Asp_Id) then
 448                   Relocate_Aspect (Asp);
 449                end if;
 450
 451             --  Default case - relocate the aspect to its new owner
 452
 453             else
 454                Relocate_Aspect (Asp);
 455             end if;
 456
 457             Asp := Next_Asp;
 458          end loop;
 459
 460          --  The relocations may have left node From's aspect specifications
 461          --  list empty. If this is the case, simply remove the aspects.
 462
 463          if Is_Empty_List (Aspect_Specifications (From)) then
 464             Remove_Aspects (From);
 465          end if;
 466       end if;
 467    end Move_Or_Merge_Aspects;
 468
 469    -----------------------------------
 470    -- Permits_Aspect_Specifications --
 471    -----------------------------------
 472
 473    Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean :=
 474      (N_Abstract_Subprogram_Declaration        => True,
 475       N_Component_Declaration                  => True,
 476       N_Entry_Body                             => True,
 477       N_Entry_Declaration                      => True,
 478       N_Exception_Declaration                  => True,
 479       N_Exception_Renaming_Declaration         => True,
 480       N_Expression_Function                    => True,
 481       N_Formal_Abstract_Subprogram_Declaration => True,
 482       N_Formal_Concrete_Subprogram_Declaration => True,
 483       N_Formal_Object_Declaration              => True,
 484       N_Formal_Package_Declaration             => True,
 485       N_Formal_Type_Declaration                => True,
 486       N_Full_Type_Declaration                  => True,
 487       N_Function_Instantiation                 => True,
 488       N_Generic_Package_Declaration            => True,
 489       N_Generic_Renaming_Declaration           => True,
 490       N_Generic_Subprogram_Declaration         => True,
 491       N_Object_Declaration                     => True,
 492       N_Object_Renaming_Declaration            => True,
 493       N_Package_Body                           => True,
 494       N_Package_Body_Stub                      => True,
 495       N_Package_Declaration                    => True,
 496       N_Package_Instantiation                  => True,
 497       N_Package_Specification                  => True,
 498       N_Package_Renaming_Declaration           => True,
 499       N_Parameter_Specification                => True,
 500       N_Private_Extension_Declaration          => True,
 501       N_Private_Type_Declaration               => True,
 502       N_Procedure_Instantiation                => True,
 503       N_Protected_Body                         => True,
 504       N_Protected_Body_Stub                    => True,
 505       N_Protected_Type_Declaration             => True,
 506       N_Single_Protected_Declaration           => True,
 507       N_Single_Task_Declaration                => True,
 508       N_Subprogram_Body                        => True,
 509       N_Subprogram_Body_Stub                   => True,
 510       N_Subprogram_Declaration                 => True,
 511       N_Subprogram_Renaming_Declaration        => True,
 512       N_Subtype_Declaration                    => True,
 513       N_Task_Body                              => True,
 514       N_Task_Body_Stub                         => True,
 515       N_Task_Type_Declaration                  => True,
 516       others                                   => False);
 517
 518    function Permits_Aspect_Specifications (N : Node_Id) return Boolean is
 519    begin
 520       pragma Assert (Present (N));
 521       return Has_Aspect_Specifications_Flag (Nkind (N));
 522    end Permits_Aspect_Specifications;
 523
 524    --------------------
 525    -- Remove_Aspects --
 526    --------------------
 527
 528    procedure Remove_Aspects (N : Node_Id) is
 529    begin
 530       if Has_Aspects (N) then
 531          Aspect_Specifications_Hash_Table.Remove (N);
 532          Set_Has_Aspects (N, False);
 533       end if;
 534    end Remove_Aspects;
 535
 536    -----------------
 537    -- Same_Aspect --
 538    -----------------
 539
 540    --  Table used for Same_Aspect, maps aspect to canonical aspect
 541
 542    type Aspect_To_Aspect_Mapping is array (Aspect_Id) of Aspect_Id;
 543
 544    function Init_Canonical_Aspect return Aspect_To_Aspect_Mapping;
 545    --  Initialize the Canonical_Aspect mapping below
 546
 547    function Init_Canonical_Aspect return Aspect_To_Aspect_Mapping is
 548       Result : Aspect_To_Aspect_Mapping;
 549    begin
 550       --  They all map to themselves...
 551
 552       for Aspect in Aspect_Id loop
 553          Result (Aspect) := Aspect;
 554       end loop;
 555
 556       --  ...except for these:
 557
 558       Result (Aspect_Dynamic_Predicate)  := Aspect_Predicate;
 559       Result (Aspect_Ghost_Predicate)    := Aspect_Predicate;
 560       Result (Aspect_Inline_Always)      := Aspect_Inline;
 561       Result (Aspect_Interrupt_Priority) := Aspect_Priority;
 562       Result (Aspect_Postcondition)      := Aspect_Post;
 563       Result (Aspect_Precondition)       := Aspect_Pre;
 564       Result (Aspect_Shared)             := Aspect_Atomic;
 565       Result (Aspect_Static_Predicate)   := Aspect_Predicate;
 566       Result (Aspect_Type_Invariant)     := Aspect_Invariant;
 567
 568       return Result;
 569    end Init_Canonical_Aspect;
 570
 571    Canonical_Aspect : constant Aspect_To_Aspect_Mapping :=
 572      Init_Canonical_Aspect;
 573
 574    function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is
 575    begin
 576       return Canonical_Aspect (A1) = Canonical_Aspect (A2);
 577    end Same_Aspect;
 578
 579    -------------------------------
 580    -- Set_Aspect_Specifications --
 581    -------------------------------
 582
 583    procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is
 584    begin
 585       pragma Assert (Permits_Aspect_Specifications (N));
 586       pragma Assert (not Has_Aspects (N));
 587       pragma Assert (L /= No_List);
 588
 589       Set_Has_Aspects (N);
 590       Set_Parent (L, N);
 591       Aspect_Specifications_Hash_Table.Set (N, L);
 592    end Set_Aspect_Specifications;
 593
 594 --  Package initialization sets up Aspect Id hash table
 595
 596 begin
 597    for J in Aspect_Id loop
 598       Aspect_Id_Hash_Table.Set (Aspect_Names (J), J);
 599    end loop;
 600 end Aspects;