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