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-2011, 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 Tree_IO;  use Tree_IO;
  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    -- Hash Table for Aspect Id Values --
  67    -------------------------------------
  68
  69    type AI_Hash_Range is range 0 .. 112;
  70    --  Size of hash table headers
  71
  72    function AI_Hash (F : Name_Id) return AI_Hash_Range;
  73    --  Hash function for hash table
  74
  75    function AI_Hash (F : Name_Id) return AI_Hash_Range is
  76    begin
  77       return AI_Hash_Range (F mod 113);
  78    end AI_Hash;
  79
  80    package Aspect_Id_Hash_Table is new
  81      GNAT.HTable.Simple_HTable
  82        (Header_Num => AI_Hash_Range,
  83         Element    => Aspect_Id,
  84         No_Element => No_Aspect,
  85         Key        => Name_Id,
  86         Hash       => AI_Hash,
  87         Equal      => "=");
  88
  89    ---------------------------
  90    -- Aspect_Specifications --
  91    ---------------------------
  92
  93    function Aspect_Specifications (N : Node_Id) return List_Id is
  94    begin
  95       if Has_Aspects (N) then
  96          return Aspect_Specifications_Hash_Table.Get (N);
  97       else
  98          return No_List;
  99       end if;
 100    end Aspect_Specifications;
 101
 102    -------------------
 103    -- Get_Aspect_Id --
 104    -------------------
 105
 106    function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is
 107    begin
 108       return Aspect_Id_Hash_Table.Get (Name);
 109    end Get_Aspect_Id;
 110
 111    ------------------
 112    -- Move_Aspects --
 113    ------------------
 114
 115    procedure Move_Aspects (From : Node_Id; To : Node_Id) is
 116       pragma Assert (not Has_Aspects (To));
 117    begin
 118       if Has_Aspects (From) then
 119          Set_Aspect_Specifications (To, Aspect_Specifications (From));
 120          Aspect_Specifications_Hash_Table.Remove (From);
 121          Set_Has_Aspects (From, False);
 122       end if;
 123    end Move_Aspects;
 124
 125    -----------------------------------
 126    -- Permits_Aspect_Specifications --
 127    -----------------------------------
 128
 129    Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean :=
 130      (N_Abstract_Subprogram_Declaration        => True,
 131       N_Component_Declaration                  => True,
 132       N_Entry_Declaration                      => True,
 133       N_Exception_Declaration                  => True,
 134       N_Formal_Abstract_Subprogram_Declaration => True,
 135       N_Formal_Concrete_Subprogram_Declaration => True,
 136       N_Formal_Object_Declaration              => True,
 137       N_Formal_Package_Declaration             => True,
 138       N_Formal_Type_Declaration                => True,
 139       N_Full_Type_Declaration                  => True,
 140       N_Function_Instantiation                 => True,
 141       N_Generic_Package_Declaration            => True,
 142       N_Generic_Subprogram_Declaration         => True,
 143       N_Object_Declaration                     => True,
 144       N_Package_Declaration                    => True,
 145       N_Package_Instantiation                  => True,
 146       N_Package_Specification                  => True,
 147       N_Private_Extension_Declaration          => True,
 148       N_Private_Type_Declaration               => True,
 149       N_Procedure_Instantiation                => True,
 150       N_Protected_Body                         => True,
 151       N_Protected_Type_Declaration             => True,
 152       N_Single_Protected_Declaration           => True,
 153       N_Single_Task_Declaration                => True,
 154       N_Subprogram_Body                        => True,
 155       N_Subprogram_Declaration                 => True,
 156       N_Subtype_Declaration                    => True,
 157       N_Task_Body                              => True,
 158       N_Task_Type_Declaration                  => True,
 159       others                                   => False);
 160
 161    function Permits_Aspect_Specifications (N : Node_Id) return Boolean is
 162    begin
 163       return Has_Aspect_Specifications_Flag (Nkind (N));
 164    end Permits_Aspect_Specifications;
 165
 166    -----------------
 167    -- Same_Aspect --
 168    -----------------
 169
 170    --  Table used for Same_Aspect, maps aspect to canonical aspect
 171
 172    Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id :=
 173    (No_Aspect                           => No_Aspect,
 174     Aspect_Ada_2005                     => Aspect_Ada_2005,
 175     Aspect_Ada_2012                     => Aspect_Ada_2005,
 176     Aspect_Address                      => Aspect_Address,
 177     Aspect_Alignment                    => Aspect_Alignment,
 178     Aspect_Atomic                       => Aspect_Atomic,
 179     Aspect_Atomic_Components            => Aspect_Atomic_Components,
 180     Aspect_Bit_Order                    => Aspect_Bit_Order,
 181     Aspect_Component_Size               => Aspect_Component_Size,
 182     Aspect_Default_Component_Value      => Aspect_Default_Component_Value,
 183     Aspect_Default_Value                => Aspect_Default_Value,
 184     Aspect_Discard_Names                => Aspect_Discard_Names,
 185     Aspect_Dynamic_Predicate            => Aspect_Predicate,
 186     Aspect_External_Tag                 => Aspect_External_Tag,
 187     Aspect_Favor_Top_Level              => Aspect_Favor_Top_Level,
 188     Aspect_Inline                       => Aspect_Inline,
 189     Aspect_Inline_Always                => Aspect_Inline,
 190     Aspect_All_Calls_Remote             => Aspect_All_Calls_Remote,
 191     Aspect_Compiler_Unit                => Aspect_Compiler_Unit,
 192     Aspect_Elaborate_Body               => Aspect_Elaborate_Body,
 193     Aspect_Preelaborate                 => Aspect_Preelaborate,
 194     Aspect_Preelaborate_05              => Aspect_Preelaborate_05,
 195     Aspect_Pure                         => Aspect_Pure,
 196     Aspect_Pure_05                      => Aspect_Pure_05,
 197     Aspect_Remote_Call_Interface        => Aspect_Remote_Call_Interface,
 198     Aspect_Remote_Types                 => Aspect_Remote_Types,
 199     Aspect_Shared_Passive               => Aspect_Shared_Passive,
 200     Aspect_Universal_Data               => Aspect_Universal_Data,
 201     Aspect_Input                        => Aspect_Input,
 202     Aspect_Invariant                    => Aspect_Invariant,
 203     Aspect_Machine_Radix                => Aspect_Machine_Radix,
 204     Aspect_No_Return                    => Aspect_No_Return,
 205     Aspect_Object_Size                  => Aspect_Object_Size,
 206     Aspect_Output                       => Aspect_Output,
 207     Aspect_Pack                         => Aspect_Pack,
 208     Aspect_Persistent_BSS               => Aspect_Persistent_BSS,
 209     Aspect_Post                         => Aspect_Post,
 210     Aspect_Postcondition                => Aspect_Post,
 211     Aspect_Pre                          => Aspect_Pre,
 212     Aspect_Precondition                 => Aspect_Pre,
 213     Aspect_Predicate                    => Aspect_Predicate,
 214     Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization,
 215     Aspect_Pure_Function                => Aspect_Pure_Function,
 216     Aspect_Read                         => Aspect_Read,
 217     Aspect_Shared                       => Aspect_Atomic,
 218     Aspect_Size                         => Aspect_Size,
 219     Aspect_Static_Predicate             => Aspect_Predicate,
 220     Aspect_Storage_Pool                 => Aspect_Storage_Pool,
 221     Aspect_Storage_Size                 => Aspect_Storage_Size,
 222     Aspect_Stream_Size                  => Aspect_Stream_Size,
 223     Aspect_Suppress                     => Aspect_Suppress,
 224     Aspect_Suppress_Debug_Info          => Aspect_Suppress_Debug_Info,
 225     Aspect_Test_Case                    => Aspect_Test_Case,
 226     Aspect_Type_Invariant               => Aspect_Invariant,
 227     Aspect_Unchecked_Union              => Aspect_Unchecked_Union,
 228     Aspect_Universal_Aliasing           => Aspect_Universal_Aliasing,
 229     Aspect_Unmodified                   => Aspect_Unmodified,
 230     Aspect_Unreferenced                 => Aspect_Unreferenced,
 231     Aspect_Unreferenced_Objects         => Aspect_Unreferenced_Objects,
 232     Aspect_Unsuppress                   => Aspect_Unsuppress,
 233     Aspect_Value_Size                   => Aspect_Value_Size,
 234     Aspect_Volatile                     => Aspect_Volatile,
 235     Aspect_Volatile_Components          => Aspect_Volatile_Components,
 236     Aspect_Warnings                     => Aspect_Warnings,
 237     Aspect_Write                        => Aspect_Write);
 238
 239    function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is
 240    begin
 241       return Canonical_Aspect (A1) = Canonical_Aspect (A2);
 242    end Same_Aspect;
 243
 244    -------------------------------
 245    -- Set_Aspect_Specifications --
 246    -------------------------------
 247
 248    procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is
 249    begin
 250       pragma Assert (Permits_Aspect_Specifications (N));
 251       pragma Assert (not Has_Aspects (N));
 252       pragma Assert (L /= No_List);
 253
 254       Set_Has_Aspects (N);
 255       Set_Parent (L, N);
 256       Aspect_Specifications_Hash_Table.Set (N, L);
 257    end Set_Aspect_Specifications;
 258
 259    ---------------
 260    -- Tree_Read --
 261    ---------------
 262
 263    procedure Tree_Read is
 264       Node : Node_Id;
 265       List : List_Id;
 266    begin
 267       loop
 268          Tree_Read_Int (Int (Node));
 269          Tree_Read_Int (Int (List));
 270          exit when List = No_List;
 271          Set_Aspect_Specifications (Node, List);
 272       end loop;
 273    end Tree_Read;
 274
 275    ----------------
 276    -- Tree_Write --
 277    ----------------
 278
 279    procedure Tree_Write is
 280       Node : Node_Id := Empty;
 281       List : List_Id;
 282    begin
 283       Aspect_Specifications_Hash_Table.Get_First (Node, List);
 284       loop
 285          Tree_Write_Int (Int (Node));
 286          Tree_Write_Int (Int (List));
 287          exit when List = No_List;
 288          Aspect_Specifications_Hash_Table.Get_Next (Node, List);
 289       end loop;
 290    end Tree_Write;
 291
 292 --  Package initialization sets up Aspect Id hash table
 293
 294 begin
 295    for J in Aspect_Id loop
 296       Aspect_Id_Hash_Table.Set (Aspect_Names (J), J);
 297    end loop;
 298 end Aspects;