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, 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 Nlists; use Nlists;
  34 with Sinfo;  use Sinfo;
  35 with Snames; use Snames;
  36
  37 with GNAT.HTable; use GNAT.HTable;
  38
  39 package body Aspects is
  40
  41    ------------------------------------------
  42    -- Hash Table for Aspect Specifications --
  43    ------------------------------------------
  44
  45    type AS_Hash_Range is range 0 .. 510;
  46    --  Size of hash table headers
  47
  48    function AS_Hash (F : Node_Id) return AS_Hash_Range;
  49    --  Hash function for hash table
  50
  51    function AS_Hash (F : Node_Id) return AS_Hash_Range is
  52    begin
  53       return AS_Hash_Range (F mod 511);
  54    end AS_Hash;
  55
  56    package Aspect_Specifications_Hash_Table is new
  57      GNAT.HTable.Simple_HTable
  58        (Header_Num => AS_Hash_Range,
  59         Element    => List_Id,
  60         No_Element => No_List,
  61         Key        => Node_Id,
  62         Hash       => AS_Hash,
  63         Equal      => "=");
  64
  65    -----------------------------------------
  66    -- Table Linking Names and Aspect_Id's --
  67    -----------------------------------------
  68
  69    type Aspect_Entry is record
  70       Nam : Name_Id;
  71       Asp : Aspect_Id;
  72    end record;
  73
  74    Aspect_Names : constant array (Integer range <>) of Aspect_Entry := (
  75      (Name_Ada_2005,                     Aspect_Ada_2005),
  76      (Name_Ada_2012,                     Aspect_Ada_2012),
  77      (Name_Address,                      Aspect_Address),
  78      (Name_Alignment,                    Aspect_Alignment),
  79      (Name_Atomic,                       Aspect_Atomic),
  80      (Name_Atomic_Components,            Aspect_Atomic_Components),
  81      (Name_Bit_Order,                    Aspect_Bit_Order),
  82      (Name_Component_Size,               Aspect_Component_Size),
  83      (Name_Discard_Names,                Aspect_Discard_Names),
  84      (Name_External_Tag,                 Aspect_External_Tag),
  85      (Name_Favor_Top_Level,              Aspect_Favor_Top_Level),
  86      (Name_Inline,                       Aspect_Inline),
  87      (Name_Inline_Always,                Aspect_Inline_Always),
  88      (Name_Invariant,                    Aspect_Invariant),
  89      (Name_Machine_Radix,                Aspect_Machine_Radix),
  90      (Name_Object_Size,                  Aspect_Object_Size),
  91      (Name_Pack,                         Aspect_Pack),
  92      (Name_Persistent_BSS,               Aspect_Persistent_BSS),
  93      (Name_Post,                         Aspect_Post),
  94      (Name_Pre,                          Aspect_Pre),
  95      (Name_Predicate,                    Aspect_Predicate),
  96      (Name_Preelaborable_Initialization, Aspect_Preelaborable_Initialization),
  97      (Name_Pure_Function,                Aspect_Pure_Function),
  98      (Name_Shared,                       Aspect_Shared),
  99      (Name_Size,                         Aspect_Size),
 100      (Name_Storage_Pool,                 Aspect_Storage_Pool),
 101      (Name_Storage_Size,                 Aspect_Storage_Size),
 102      (Name_Stream_Size,                  Aspect_Stream_Size),
 103      (Name_Suppress,                     Aspect_Suppress),
 104      (Name_Suppress_Debug_Info,          Aspect_Suppress_Debug_Info),
 105      (Name_Unchecked_Union,              Aspect_Unchecked_Union),
 106      (Name_Universal_Aliasing,           Aspect_Universal_Aliasing),
 107      (Name_Unmodified,                   Aspect_Unmodified),
 108      (Name_Unreferenced,                 Aspect_Unreferenced),
 109      (Name_Unreferenced_Objects,         Aspect_Unreferenced_Objects),
 110      (Name_Unsuppress,                   Aspect_Unsuppress),
 111      (Name_Value_Size,                   Aspect_Value_Size),
 112      (Name_Volatile,                     Aspect_Volatile),
 113      (Name_Volatile_Components,          Aspect_Volatile_Components),
 114      (Name_Warnings,                     Aspect_Warnings));
 115
 116    -------------------------------------
 117    -- Hash Table for Aspect Id Values --
 118    -------------------------------------
 119
 120    type AI_Hash_Range is range 0 .. 112;
 121    --  Size of hash table headers
 122
 123    function AI_Hash (F : Name_Id) return AI_Hash_Range;
 124    --  Hash function for hash table
 125
 126    function AI_Hash (F : Name_Id) return AI_Hash_Range is
 127    begin
 128       return AI_Hash_Range (F mod 113);
 129    end AI_Hash;
 130
 131    package Aspect_Id_Hash_Table is new
 132      GNAT.HTable.Simple_HTable
 133        (Header_Num => AI_Hash_Range,
 134         Element    => Aspect_Id,
 135         No_Element => No_Aspect,
 136         Key        => Name_Id,
 137         Hash       => AI_Hash,
 138         Equal      => "=");
 139
 140    -------------------
 141    -- Get_Aspect_Id --
 142    -------------------
 143
 144    function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is
 145    begin
 146       return Aspect_Id_Hash_Table.Get (Name);
 147    end Get_Aspect_Id;
 148
 149    ---------------------------
 150    -- Aspect_Specifications --
 151    ---------------------------
 152
 153    function Aspect_Specifications (N : Node_Id) return List_Id is
 154    begin
 155       return Aspect_Specifications_Hash_Table.Get (N);
 156    end Aspect_Specifications;
 157
 158    -----------------------------------
 159    -- Permits_Aspect_Specifications --
 160    -----------------------------------
 161
 162    Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean :=
 163      (N_Abstract_Subprogram_Declaration        => True,
 164       N_Component_Declaration                  => True,
 165       N_Entry_Declaration                      => True,
 166       N_Exception_Declaration                  => True,
 167       N_Formal_Abstract_Subprogram_Declaration => True,
 168       N_Formal_Concrete_Subprogram_Declaration => True,
 169       N_Formal_Object_Declaration              => True,
 170       N_Formal_Package_Declaration             => True,
 171       N_Formal_Type_Declaration                => True,
 172       N_Full_Type_Declaration                  => True,
 173       N_Function_Instantiation                 => True,
 174       N_Generic_Package_Declaration            => True,
 175       N_Generic_Subprogram_Declaration         => True,
 176       N_Object_Declaration                     => True,
 177       N_Package_Declaration                    => True,
 178       N_Package_Instantiation                  => True,
 179       N_Private_Extension_Declaration          => True,
 180       N_Private_Type_Declaration               => True,
 181       N_Procedure_Instantiation                => True,
 182       N_Protected_Type_Declaration             => True,
 183       N_Single_Protected_Declaration           => True,
 184       N_Single_Task_Declaration                => True,
 185       N_Subprogram_Declaration                 => True,
 186       N_Subtype_Declaration                    => True,
 187       N_Task_Type_Declaration                  => True,
 188       others                                   => False);
 189
 190    function Permits_Aspect_Specifications (N : Node_Id) return Boolean is
 191    begin
 192       return Has_Aspect_Specifications_Flag (Nkind (N));
 193    end Permits_Aspect_Specifications;
 194
 195    -------------------------------
 196    -- Set_Aspect_Specifications --
 197    -------------------------------
 198
 199    procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is
 200    begin
 201       pragma Assert (Permits_Aspect_Specifications (N));
 202       pragma Assert (not Has_Aspect_Specifications (N));
 203       pragma Assert (L /= No_List);
 204
 205       Set_Has_Aspect_Specifications (N);
 206       Set_Parent (L, N);
 207       Aspect_Specifications_Hash_Table.Set (N, L);
 208    end Set_Aspect_Specifications;
 209
 210 --  Package initialization sets up Aspect Id hash table
 211
 212 begin
 213    for J in Aspect_Names'Range loop
 214       Aspect_Id_Hash_Table.Set (Aspect_Names (J).Nam, Aspect_Names (J).Asp);
 215    end loop;
 216 end Aspects;