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-2013, 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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Atree;    use Atree;
  33 with Einfo;    use Einfo;
  34 with Nlists;   use Nlists;
  35 with Sinfo;    use Sinfo;
  36 with Tree_IO;  use Tree_IO;
  37
  38 with GNAT.HTable;           use GNAT.HTable;
  39
  40 package body Aspects is
  41
  42    --  The following array indicates aspects that a subtype inherits from its
  43    --  base type. True means that the subtype inherits the aspect from its base
  44    --  type. False means it is not inherited.
  45
  46    Base_Aspect : constant array (Aspect_Id) of Boolean :=
  47      (Aspect_Atomic                  => True,
  48       Aspect_Atomic_Components       => True,
  49       Aspect_Constant_Indexing       => True,
  50       Aspect_Default_Iterator        => True,
  51       Aspect_Discard_Names           => True,
  52       Aspect_Independent_Components  => True,
  53       Aspect_Iterator_Element        => True,
  54       Aspect_Type_Invariant          => True,
  55       Aspect_Unchecked_Union         => True,
  56       Aspect_Variable_Indexing       => True,
  57       Aspect_Volatile                => True,
  58       others                         => False);
  59
  60    --  The following array indicates type aspects that are inherited and apply
  61    --  to the class-wide type as well.
  62
  63    Inherited_Aspect : constant array (Aspect_Id) of Boolean :=
  64      (Aspect_Constant_Indexing    => True,
  65       Aspect_Default_Iterator     => True,
  66       Aspect_Implicit_Dereference => True,
  67       Aspect_Iterator_Element     => True,
  68       Aspect_Remote_Types         => True,
  69       Aspect_Variable_Indexing    => True,
  70       others                      => False);
  71
  72    procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id);
  73    --  Same as Set_Aspect_Specifications, but does not contain the assertion
  74    --  that checks that N does not already have aspect specifications. This
  75    --  subprogram is supposed to be used as a part of Tree_Read. When reading
  76    --  tree, first read nodes with their basic properties (as Atree.Tree_Read),
  77    --  this includes reading the Has_Aspects flag for each node, then we reed
  78    --  all the list tables and only after that we call Tree_Read for Aspects.
  79    --  That is, when reading the tree, the list of aspects is attached to the
  80    --  node that already has Has_Aspects flag set ON.
  81
  82    ------------------------------------------
  83    -- Hash Table for Aspect Specifications --
  84    ------------------------------------------
  85
  86    type AS_Hash_Range is range 0 .. 510;
  87    --  Size of hash table headers
  88
  89    function AS_Hash (F : Node_Id) return AS_Hash_Range;
  90    --  Hash function for hash table
  91
  92    function AS_Hash (F : Node_Id) return AS_Hash_Range is
  93    begin
  94       return AS_Hash_Range (F mod 511);
  95    end AS_Hash;
  96
  97    package Aspect_Specifications_Hash_Table is new
  98      GNAT.HTable.Simple_HTable
  99        (Header_Num => AS_Hash_Range,
 100         Element    => List_Id,
 101         No_Element => No_List,
 102         Key        => Node_Id,
 103         Hash       => AS_Hash,
 104         Equal      => "=");
 105
 106    -------------------------------------
 107    -- Hash Table for Aspect Id Values --
 108    -------------------------------------
 109
 110    type AI_Hash_Range is range 0 .. 112;
 111    --  Size of hash table headers
 112
 113    function AI_Hash (F : Name_Id) return AI_Hash_Range;
 114    --  Hash function for hash table
 115
 116    function AI_Hash (F : Name_Id) return AI_Hash_Range is
 117    begin
 118       return AI_Hash_Range (F mod 113);
 119    end AI_Hash;
 120
 121    package Aspect_Id_Hash_Table is new
 122      GNAT.HTable.Simple_HTable
 123        (Header_Num => AI_Hash_Range,
 124         Element    => Aspect_Id,
 125         No_Element => No_Aspect,
 126         Key        => Name_Id,
 127         Hash       => AI_Hash,
 128         Equal      => "=");
 129
 130    ---------------------------
 131    -- Aspect_Specifications --
 132    ---------------------------
 133
 134    function Aspect_Specifications (N : Node_Id) return List_Id is
 135    begin
 136       if Has_Aspects (N) then
 137          return Aspect_Specifications_Hash_Table.Get (N);
 138       else
 139          return No_List;
 140       end if;
 141    end Aspect_Specifications;
 142
 143    -----------------
 144    -- Find_Aspect --
 145    -----------------
 146
 147    function Find_Aspect (Id : Entity_Id; A : Aspect_Id) return Node_Id is
 148       Decl  : Node_Id;
 149       Item  : Node_Id;
 150       Owner : Entity_Id;
 151       Spec  : Node_Id;
 152
 153    begin
 154       Owner := Id;
 155
 156       --  Handle various cases of base or inherited aspects for types
 157
 158       if Is_Type (Id) then
 159          if Base_Aspect (A) then
 160             Owner := Base_Type (Owner);
 161          end if;
 162
 163          if Is_Class_Wide_Type (Owner) and then Inherited_Aspect (A) then
 164             Owner := Root_Type (Owner);
 165          end if;
 166
 167          if Is_Private_Type (Owner)
 168            and then Present (Full_View (Owner))
 169          then
 170             Owner := Full_View (Owner);
 171          end if;
 172       end if;
 173
 174       --  Search the representation items for the desired aspect
 175
 176       Item := First_Rep_Item (Owner);
 177       while Present (Item) loop
 178          if Nkind (Item) = N_Aspect_Specification
 179            and then Get_Aspect_Id (Item) = A
 180          then
 181             return Item;
 182          end if;
 183
 184          Next_Rep_Item (Item);
 185       end loop;
 186
 187       --  Note that not all aspects are added to the chain of representation
 188       --  items. In such cases, search the list of aspect specifications. First
 189       --  find the declaration node where the aspects reside. This is usually
 190       --  the parent or the parent of the parent.
 191
 192       Decl := Parent (Owner);
 193       if not Permits_Aspect_Specifications (Decl) then
 194          Decl := Parent (Decl);
 195       end if;
 196
 197       --  Search the list of aspect specifications for the desired aspect
 198
 199       if Permits_Aspect_Specifications (Decl) then
 200          Spec := First (Aspect_Specifications (Decl));
 201          while Present (Spec) loop
 202             if Get_Aspect_Id (Spec) = A then
 203                return Spec;
 204             end if;
 205
 206             Next (Spec);
 207          end loop;
 208       end if;
 209
 210       --  The entity does not carry any aspects or the desired aspect was not
 211       --  found.
 212
 213       return Empty;
 214    end Find_Aspect;
 215
 216    --------------------------
 217    -- Find_Value_Of_Aspect --
 218    --------------------------
 219
 220    function Find_Value_Of_Aspect
 221      (Id : Entity_Id;
 222       A  : Aspect_Id) return Node_Id
 223    is
 224       Spec : constant Node_Id := Find_Aspect (Id, A);
 225
 226    begin
 227       if Present (Spec) then
 228          if A = Aspect_Default_Iterator then
 229             return Expression (Aspect_Rep_Item (Spec));
 230          else
 231             return Expression (Spec);
 232          end if;
 233       end if;
 234
 235       return Empty;
 236    end Find_Value_Of_Aspect;
 237
 238    -------------------
 239    -- Get_Aspect_Id --
 240    -------------------
 241
 242    function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is
 243    begin
 244       return Aspect_Id_Hash_Table.Get (Name);
 245    end Get_Aspect_Id;
 246
 247    function Get_Aspect_Id (Aspect : Node_Id) return Aspect_Id is
 248    begin
 249       pragma Assert (Nkind (Aspect) = N_Aspect_Specification);
 250       return Aspect_Id_Hash_Table.Get (Chars (Identifier (Aspect)));
 251    end Get_Aspect_Id;
 252
 253    ----------------
 254    -- Has_Aspect --
 255    ----------------
 256
 257    function Has_Aspect (Id : Entity_Id; A : Aspect_Id) return Boolean is
 258    begin
 259       return Present (Find_Aspect (Id, A));
 260    end Has_Aspect;
 261
 262    ------------------
 263    -- Move_Aspects --
 264    ------------------
 265
 266    procedure Move_Aspects (From : Node_Id; To : Node_Id) is
 267       pragma Assert (not Has_Aspects (To));
 268    begin
 269       if Has_Aspects (From) then
 270          Set_Aspect_Specifications (To, Aspect_Specifications (From));
 271          Aspect_Specifications_Hash_Table.Remove (From);
 272          Set_Has_Aspects (From, False);
 273       end if;
 274    end Move_Aspects;
 275
 276    -----------------------------------
 277    -- Permits_Aspect_Specifications --
 278    -----------------------------------
 279
 280    Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean :=
 281      (N_Abstract_Subprogram_Declaration        => True,
 282       N_Component_Declaration                  => True,
 283       N_Entry_Declaration                      => True,
 284       N_Exception_Declaration                  => True,
 285       N_Exception_Renaming_Declaration         => True,
 286       N_Expression_Function                    => True,
 287       N_Formal_Abstract_Subprogram_Declaration => True,
 288       N_Formal_Concrete_Subprogram_Declaration => True,
 289       N_Formal_Object_Declaration              => True,
 290       N_Formal_Package_Declaration             => True,
 291       N_Formal_Type_Declaration                => True,
 292       N_Full_Type_Declaration                  => True,
 293       N_Function_Instantiation                 => True,
 294       N_Generic_Package_Declaration            => True,
 295       N_Generic_Renaming_Declaration           => True,
 296       N_Generic_Subprogram_Declaration         => True,
 297       N_Object_Declaration                     => True,
 298       N_Object_Renaming_Declaration            => True,
 299       N_Package_Declaration                    => True,
 300       N_Package_Instantiation                  => True,
 301       N_Package_Specification                  => True,
 302       N_Package_Renaming_Declaration           => True,
 303       N_Private_Extension_Declaration          => True,
 304       N_Private_Type_Declaration               => True,
 305       N_Procedure_Instantiation                => True,
 306       N_Protected_Body                         => True,
 307       N_Protected_Type_Declaration             => True,
 308       N_Single_Protected_Declaration           => True,
 309       N_Single_Task_Declaration                => True,
 310       N_Subprogram_Body                        => True,
 311       N_Subprogram_Declaration                 => True,
 312       N_Subprogram_Renaming_Declaration        => True,
 313       N_Subprogram_Body_Stub                   => True,
 314       N_Subtype_Declaration                    => True,
 315       N_Task_Body                              => True,
 316       N_Task_Type_Declaration                  => True,
 317       others                                   => False);
 318
 319    function Permits_Aspect_Specifications (N : Node_Id) return Boolean is
 320    begin
 321       return Has_Aspect_Specifications_Flag (Nkind (N));
 322    end Permits_Aspect_Specifications;
 323
 324    -----------------
 325    -- Same_Aspect --
 326    -----------------
 327
 328    --  Table used for Same_Aspect, maps aspect to canonical aspect
 329
 330    Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id :=
 331    (No_Aspect                           => No_Aspect,
 332     Aspect_Abstract_State               => Aspect_Abstract_State,
 333     Aspect_Ada_2005                     => Aspect_Ada_2005,
 334     Aspect_Ada_2012                     => Aspect_Ada_2005,
 335     Aspect_Address                      => Aspect_Address,
 336     Aspect_Alignment                    => Aspect_Alignment,
 337     Aspect_All_Calls_Remote             => Aspect_All_Calls_Remote,
 338     Aspect_Asynchronous                 => Aspect_Asynchronous,
 339     Aspect_Atomic                       => Aspect_Atomic,
 340     Aspect_Atomic_Components            => Aspect_Atomic_Components,
 341     Aspect_Attach_Handler               => Aspect_Attach_Handler,
 342     Aspect_Bit_Order                    => Aspect_Bit_Order,
 343     Aspect_Compiler_Unit                => Aspect_Compiler_Unit,
 344     Aspect_Component_Size               => Aspect_Component_Size,
 345     Aspect_Constant_Indexing            => Aspect_Constant_Indexing,
 346     Aspect_Contract_Cases               => Aspect_Contract_Cases,
 347     Aspect_Convention                   => Aspect_Convention,
 348     Aspect_CPU                          => Aspect_CPU,
 349     Aspect_Default_Component_Value      => Aspect_Default_Component_Value,
 350     Aspect_Default_Iterator             => Aspect_Default_Iterator,
 351     Aspect_Default_Value                => Aspect_Default_Value,
 352     Aspect_Depends                      => Aspect_Depends,
 353     Aspect_Dimension                    => Aspect_Dimension,
 354     Aspect_Dimension_System             => Aspect_Dimension_System,
 355     Aspect_Discard_Names                => Aspect_Discard_Names,
 356     Aspect_Dispatching_Domain           => Aspect_Dispatching_Domain,
 357     Aspect_Dynamic_Predicate            => Aspect_Predicate,
 358     Aspect_Elaborate_Body               => Aspect_Elaborate_Body,
 359     Aspect_Export                       => Aspect_Export,
 360     Aspect_External_Name                => Aspect_External_Name,
 361     Aspect_External_Tag                 => Aspect_External_Tag,
 362     Aspect_Favor_Top_Level              => Aspect_Favor_Top_Level,
 363     Aspect_Ghost                        => Aspect_Ghost,
 364     Aspect_Global                       => Aspect_Global,
 365     Aspect_Implicit_Dereference         => Aspect_Implicit_Dereference,
 366     Aspect_Import                       => Aspect_Import,
 367     Aspect_Independent                  => Aspect_Independent,
 368     Aspect_Independent_Components       => Aspect_Independent_Components,
 369     Aspect_Inline                       => Aspect_Inline,
 370     Aspect_Inline_Always                => Aspect_Inline,
 371     Aspect_Input                        => Aspect_Input,
 372     Aspect_Interrupt_Handler            => Aspect_Interrupt_Handler,
 373     Aspect_Interrupt_Priority           => Aspect_Priority,
 374     Aspect_Invariant                    => Aspect_Invariant,
 375     Aspect_Iterator_Element             => Aspect_Iterator_Element,
 376     Aspect_Link_Name                    => Aspect_Link_Name,
 377     Aspect_Lock_Free                    => Aspect_Lock_Free,
 378     Aspect_Machine_Radix                => Aspect_Machine_Radix,
 379     Aspect_No_Return                    => Aspect_No_Return,
 380     Aspect_Object_Size                  => Aspect_Object_Size,
 381     Aspect_Output                       => Aspect_Output,
 382     Aspect_Pack                         => Aspect_Pack,
 383     Aspect_Persistent_BSS               => Aspect_Persistent_BSS,
 384     Aspect_Post                         => Aspect_Post,
 385     Aspect_Postcondition                => Aspect_Post,
 386     Aspect_Pre                          => Aspect_Pre,
 387     Aspect_Precondition                 => Aspect_Pre,
 388     Aspect_Predicate                    => Aspect_Predicate,
 389     Aspect_Preelaborate                 => Aspect_Preelaborate,
 390     Aspect_Preelaborate_05              => Aspect_Preelaborate_05,
 391     Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization,
 392     Aspect_Priority                     => Aspect_Priority,
 393     Aspect_Pure                         => Aspect_Pure,
 394     Aspect_Pure_05                      => Aspect_Pure_05,
 395     Aspect_Pure_12                      => Aspect_Pure_12,
 396     Aspect_Pure_Function                => Aspect_Pure_Function,
 397     Aspect_Remote_Access_Type           => Aspect_Remote_Access_Type,
 398     Aspect_Remote_Call_Interface        => Aspect_Remote_Call_Interface,
 399     Aspect_Remote_Types                 => Aspect_Remote_Types,
 400     Aspect_Read                         => Aspect_Read,
 401     Aspect_Relative_Deadline            => Aspect_Relative_Deadline,
 402     Aspect_Scalar_Storage_Order         => Aspect_Scalar_Storage_Order,
 403     Aspect_Shared                       => Aspect_Atomic,
 404     Aspect_Shared_Passive               => Aspect_Shared_Passive,
 405     Aspect_Simple_Storage_Pool          => Aspect_Simple_Storage_Pool,
 406     Aspect_Simple_Storage_Pool_Type     => Aspect_Simple_Storage_Pool_Type,
 407     Aspect_Size                         => Aspect_Size,
 408     Aspect_Small                        => Aspect_Small,
 409     Aspect_Static_Predicate             => Aspect_Predicate,
 410     Aspect_Storage_Pool                 => Aspect_Storage_Pool,
 411     Aspect_Storage_Size                 => Aspect_Storage_Size,
 412     Aspect_Stream_Size                  => Aspect_Stream_Size,
 413     Aspect_Suppress                     => Aspect_Suppress,
 414     Aspect_Suppress_Debug_Info          => Aspect_Suppress_Debug_Info,
 415     Aspect_Synchronization              => Aspect_Synchronization,
 416     Aspect_Test_Case                    => Aspect_Test_Case,
 417     Aspect_Type_Invariant               => Aspect_Invariant,
 418     Aspect_Unchecked_Union              => Aspect_Unchecked_Union,
 419     Aspect_Universal_Aliasing           => Aspect_Universal_Aliasing,
 420     Aspect_Universal_Data               => Aspect_Universal_Data,
 421     Aspect_Unmodified                   => Aspect_Unmodified,
 422     Aspect_Unreferenced                 => Aspect_Unreferenced,
 423     Aspect_Unreferenced_Objects         => Aspect_Unreferenced_Objects,
 424     Aspect_Unsuppress                   => Aspect_Unsuppress,
 425     Aspect_Variable_Indexing            => Aspect_Variable_Indexing,
 426     Aspect_Value_Size                   => Aspect_Value_Size,
 427     Aspect_Volatile                     => Aspect_Volatile,
 428     Aspect_Volatile_Components          => Aspect_Volatile_Components,
 429     Aspect_Warnings                     => Aspect_Warnings,
 430     Aspect_Write                        => Aspect_Write);
 431
 432    function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is
 433    begin
 434       return Canonical_Aspect (A1) = Canonical_Aspect (A2);
 435    end Same_Aspect;
 436
 437    -------------------------------
 438    -- Set_Aspect_Specifications --
 439    -------------------------------
 440
 441    procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is
 442    begin
 443       pragma Assert (Permits_Aspect_Specifications (N));
 444       pragma Assert (not Has_Aspects (N));
 445       pragma Assert (L /= No_List);
 446
 447       Set_Has_Aspects (N);
 448       Set_Parent (L, N);
 449       Aspect_Specifications_Hash_Table.Set (N, L);
 450    end Set_Aspect_Specifications;
 451
 452    ----------------------------------------
 453    -- Set_Aspect_Specifications_No_Check --
 454    ----------------------------------------
 455
 456    procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id) is
 457    begin
 458       pragma Assert (Permits_Aspect_Specifications (N));
 459       pragma Assert (L /= No_List);
 460
 461       Set_Has_Aspects (N);
 462       Set_Parent (L, N);
 463       Aspect_Specifications_Hash_Table.Set (N, L);
 464    end Set_Aspect_Specifications_No_Check;
 465
 466    ---------------
 467    -- Tree_Read --
 468    ---------------
 469
 470    procedure Tree_Read is
 471       Node : Node_Id;
 472       List : List_Id;
 473    begin
 474       loop
 475          Tree_Read_Int (Int (Node));
 476          Tree_Read_Int (Int (List));
 477          exit when List = No_List;
 478          Set_Aspect_Specifications_No_Check (Node, List);
 479       end loop;
 480    end Tree_Read;
 481
 482    ----------------
 483    -- Tree_Write --
 484    ----------------
 485
 486    procedure Tree_Write is
 487       Node : Node_Id := Empty;
 488       List : List_Id;
 489    begin
 490       Aspect_Specifications_Hash_Table.Get_First (Node, List);
 491       loop
 492          Tree_Write_Int (Int (Node));
 493          Tree_Write_Int (Int (List));
 494          exit when List = No_List;
 495          Aspect_Specifications_Hash_Table.Get_Next (Node, List);
 496       end loop;
 497    end Tree_Write;
 498
 499 --  Package initialization sets up Aspect Id hash table
 500
 501 begin
 502    for J in Aspect_Id loop
 503       Aspect_Id_Hash_Table.Set (Aspect_Names (J), J);
 504    end loop;
 505 end Aspects;