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