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 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    procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id);
  43    --  Same as Set_Aspect_Specifications, but does not contain the assertion
  44    --  that checks that N does not already have aspect specifications. This
  45    --  subprogram is supposed to be used as a part of Tree_Read. When reading
  46    --  tree, first read nodes with their basic properties (as Atree.Tree_Read),
  47    --  this includes reading the Has_Aspects flag for each node, then we reed
  48    --  all the list tables and only after that we call Tree_Read for Aspects.
  49    --  That is, when reading the tree, the list of aspects is attached to the
  50    --  node that already has Has_Aspects flag set ON.
  51
  52    ------------------------------------------
  53    -- Hash Table for Aspect Specifications --
  54    ------------------------------------------
  55
  56    type AS_Hash_Range is range 0 .. 510;
  57    --  Size of hash table headers
  58
  59    function AS_Hash (F : Node_Id) return AS_Hash_Range;
  60    --  Hash function for hash table
  61
  62    function AS_Hash (F : Node_Id) return AS_Hash_Range is
  63    begin
  64       return AS_Hash_Range (F mod 511);
  65    end AS_Hash;
  66
  67    package Aspect_Specifications_Hash_Table is new
  68      GNAT.HTable.Simple_HTable
  69        (Header_Num => AS_Hash_Range,
  70         Element    => List_Id,
  71         No_Element => No_List,
  72         Key        => Node_Id,
  73         Hash       => AS_Hash,
  74         Equal      => "=");
  75
  76    -------------------------------------
  77    -- Hash Table for Aspect Id Values --
  78    -------------------------------------
  79
  80    type AI_Hash_Range is range 0 .. 112;
  81    --  Size of hash table headers
  82
  83    function AI_Hash (F : Name_Id) return AI_Hash_Range;
  84    --  Hash function for hash table
  85
  86    function AI_Hash (F : Name_Id) return AI_Hash_Range is
  87    begin
  88       return AI_Hash_Range (F mod 113);
  89    end AI_Hash;
  90
  91    package Aspect_Id_Hash_Table is new
  92      GNAT.HTable.Simple_HTable
  93        (Header_Num => AI_Hash_Range,
  94         Element    => Aspect_Id,
  95         No_Element => No_Aspect,
  96         Key        => Name_Id,
  97         Hash       => AI_Hash,
  98         Equal      => "=");
  99
 100    ---------------------------
 101    -- Aspect_Specifications --
 102    ---------------------------
 103
 104    function Aspect_Specifications (N : Node_Id) return List_Id is
 105    begin
 106       if Has_Aspects (N) then
 107          return Aspect_Specifications_Hash_Table.Get (N);
 108       else
 109          return No_List;
 110       end if;
 111    end Aspect_Specifications;
 112
 113    -------------------
 114    -- Get_Aspect_Id --
 115    -------------------
 116
 117    function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is
 118    begin
 119       return Aspect_Id_Hash_Table.Get (Name);
 120    end Get_Aspect_Id;
 121
 122    -----------------
 123    -- Find_Aspect --
 124    -----------------
 125
 126    function Find_Aspect (Ent : Entity_Id; A : Aspect_Id) return Node_Id is
 127       Ritem : Node_Id;
 128
 129    begin
 130       Ritem := First_Rep_Item (Ent);
 131       while Present (Ritem) loop
 132          if Nkind (Ritem) = N_Aspect_Specification
 133            and then Get_Aspect_Id (Chars (Identifier (Ritem))) = A
 134          then
 135             if A = Aspect_Default_Iterator then
 136                return Expression (Aspect_Rep_Item (Ritem));
 137             else
 138                return Expression (Ritem);
 139             end if;
 140          end if;
 141
 142          Next_Rep_Item (Ritem);
 143       end loop;
 144
 145       return Empty;
 146    end Find_Aspect;
 147
 148    ------------------
 149    -- Move_Aspects --
 150    ------------------
 151
 152    procedure Move_Aspects (From : Node_Id; To : Node_Id) is
 153       pragma Assert (not Has_Aspects (To));
 154    begin
 155       if Has_Aspects (From) then
 156          Set_Aspect_Specifications (To, Aspect_Specifications (From));
 157          Aspect_Specifications_Hash_Table.Remove (From);
 158          Set_Has_Aspects (From, False);
 159       end if;
 160    end Move_Aspects;
 161
 162    -----------------------------------
 163    -- Permits_Aspect_Specifications --
 164    -----------------------------------
 165
 166    Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean :=
 167      (N_Abstract_Subprogram_Declaration        => True,
 168       N_Component_Declaration                  => True,
 169       N_Entry_Declaration                      => True,
 170       N_Exception_Declaration                  => True,
 171       N_Formal_Abstract_Subprogram_Declaration => True,
 172       N_Formal_Concrete_Subprogram_Declaration => True,
 173       N_Formal_Object_Declaration              => True,
 174       N_Formal_Package_Declaration             => True,
 175       N_Formal_Type_Declaration                => True,
 176       N_Full_Type_Declaration                  => True,
 177       N_Function_Instantiation                 => True,
 178       N_Generic_Package_Declaration            => True,
 179       N_Generic_Subprogram_Declaration         => True,
 180       N_Object_Declaration                     => True,
 181       N_Package_Declaration                    => True,
 182       N_Package_Instantiation                  => True,
 183       N_Package_Specification                  => True,
 184       N_Private_Extension_Declaration          => True,
 185       N_Private_Type_Declaration               => True,
 186       N_Procedure_Instantiation                => True,
 187       N_Protected_Body                         => True,
 188       N_Protected_Type_Declaration             => True,
 189       N_Single_Protected_Declaration           => True,
 190       N_Single_Task_Declaration                => True,
 191       N_Subprogram_Body                        => True,
 192       N_Subprogram_Declaration                 => True,
 193       N_Subtype_Declaration                    => True,
 194       N_Task_Body                              => True,
 195       N_Task_Type_Declaration                  => True,
 196       others                                   => False);
 197
 198    function Permits_Aspect_Specifications (N : Node_Id) return Boolean is
 199    begin
 200       return Has_Aspect_Specifications_Flag (Nkind (N));
 201    end Permits_Aspect_Specifications;
 202
 203    -----------------
 204    -- Same_Aspect --
 205    -----------------
 206
 207    --  Table used for Same_Aspect, maps aspect to canonical aspect
 208
 209    Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id :=
 210    (No_Aspect                           => No_Aspect,
 211     Aspect_Ada_2005                     => Aspect_Ada_2005,
 212     Aspect_Ada_2012                     => Aspect_Ada_2005,
 213     Aspect_Address                      => Aspect_Address,
 214     Aspect_Alignment                    => Aspect_Alignment,
 215     Aspect_Asynchronous                 => Aspect_Asynchronous,
 216     Aspect_Atomic                       => Aspect_Atomic,
 217     Aspect_Atomic_Components            => Aspect_Atomic_Components,
 218     Aspect_Attach_Handler               => Aspect_Attach_Handler,
 219     Aspect_Bit_Order                    => Aspect_Bit_Order,
 220     Aspect_Component_Size               => Aspect_Component_Size,
 221     Aspect_Constant_Indexing            => Aspect_Constant_Indexing,
 222     Aspect_CPU                          => Aspect_CPU,
 223     Aspect_Default_Component_Value      => Aspect_Default_Component_Value,
 224     Aspect_Default_Iterator             => Aspect_Default_Iterator,
 225     Aspect_Default_Value                => Aspect_Default_Value,
 226     Aspect_Discard_Names                => Aspect_Discard_Names,
 227     Aspect_Dispatching_Domain           => Aspect_Dispatching_Domain,
 228     Aspect_Dynamic_Predicate            => Aspect_Predicate,
 229     Aspect_External_Tag                 => Aspect_External_Tag,
 230     Aspect_Favor_Top_Level              => Aspect_Favor_Top_Level,
 231     Aspect_Implicit_Dereference         => Aspect_Implicit_Dereference,
 232     Aspect_Independent                  => Aspect_Independent,
 233     Aspect_Independent_Components       => Aspect_Independent_Components,
 234     Aspect_Inline                       => Aspect_Inline,
 235     Aspect_Inline_Always                => Aspect_Inline,
 236     Aspect_Interrupt_Handler            => Aspect_Interrupt_Handler,
 237     Aspect_Interrupt_Priority           => Aspect_Interrupt_Priority,
 238     Aspect_Iterator_Element             => Aspect_Iterator_Element,
 239     Aspect_All_Calls_Remote             => Aspect_All_Calls_Remote,
 240     Aspect_Compiler_Unit                => Aspect_Compiler_Unit,
 241     Aspect_Elaborate_Body               => Aspect_Elaborate_Body,
 242     Aspect_Preelaborate                 => Aspect_Preelaborate,
 243     Aspect_Preelaborate_05              => Aspect_Preelaborate_05,
 244     Aspect_Pure                         => Aspect_Pure,
 245     Aspect_Pure_05                      => Aspect_Pure_05,
 246     Aspect_Remote_Call_Interface        => Aspect_Remote_Call_Interface,
 247     Aspect_Remote_Types                 => Aspect_Remote_Types,
 248     Aspect_Shared_Passive               => Aspect_Shared_Passive,
 249     Aspect_Universal_Data               => Aspect_Universal_Data,
 250     Aspect_Input                        => Aspect_Input,
 251     Aspect_Invariant                    => Aspect_Invariant,
 252     Aspect_Machine_Radix                => Aspect_Machine_Radix,
 253     Aspect_No_Return                    => Aspect_No_Return,
 254     Aspect_Object_Size                  => Aspect_Object_Size,
 255     Aspect_Output                       => Aspect_Output,
 256     Aspect_Pack                         => Aspect_Pack,
 257     Aspect_Persistent_BSS               => Aspect_Persistent_BSS,
 258     Aspect_Post                         => Aspect_Post,
 259     Aspect_Postcondition                => Aspect_Post,
 260     Aspect_Pre                          => Aspect_Pre,
 261     Aspect_Precondition                 => Aspect_Pre,
 262     Aspect_Predicate                    => Aspect_Predicate,
 263     Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization,
 264     Aspect_Priority                     => Aspect_Priority,
 265     Aspect_Pure_Function                => Aspect_Pure_Function,
 266     Aspect_Read                         => Aspect_Read,
 267     Aspect_Shared                       => Aspect_Atomic,
 268     Aspect_Size                         => Aspect_Size,
 269     Aspect_Small                        => Aspect_Small,
 270     Aspect_Static_Predicate             => Aspect_Predicate,
 271     Aspect_Storage_Pool                 => Aspect_Storage_Pool,
 272     Aspect_Storage_Size                 => Aspect_Storage_Size,
 273     Aspect_Stream_Size                  => Aspect_Stream_Size,
 274     Aspect_Suppress                     => Aspect_Suppress,
 275     Aspect_Suppress_Debug_Info          => Aspect_Suppress_Debug_Info,
 276     Aspect_Test_Case                    => Aspect_Test_Case,
 277     Aspect_Type_Invariant               => Aspect_Invariant,
 278     Aspect_Unchecked_Union              => Aspect_Unchecked_Union,
 279     Aspect_Universal_Aliasing           => Aspect_Universal_Aliasing,
 280     Aspect_Unmodified                   => Aspect_Unmodified,
 281     Aspect_Unreferenced                 => Aspect_Unreferenced,
 282     Aspect_Unreferenced_Objects         => Aspect_Unreferenced_Objects,
 283     Aspect_Unsuppress                   => Aspect_Unsuppress,
 284     Aspect_Variable_Indexing            => Aspect_Variable_Indexing,
 285     Aspect_Value_Size                   => Aspect_Value_Size,
 286     Aspect_Volatile                     => Aspect_Volatile,
 287     Aspect_Volatile_Components          => Aspect_Volatile_Components,
 288     Aspect_Warnings                     => Aspect_Warnings,
 289     Aspect_Write                        => Aspect_Write);
 290
 291    function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is
 292    begin
 293       return Canonical_Aspect (A1) = Canonical_Aspect (A2);
 294    end Same_Aspect;
 295
 296    -------------------------------
 297    -- Set_Aspect_Specifications --
 298    -------------------------------
 299
 300    procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is
 301    begin
 302       pragma Assert (Permits_Aspect_Specifications (N));
 303       pragma Assert (not Has_Aspects (N));
 304       pragma Assert (L /= No_List);
 305
 306       Set_Has_Aspects (N);
 307       Set_Parent (L, N);
 308       Aspect_Specifications_Hash_Table.Set (N, L);
 309    end Set_Aspect_Specifications;
 310
 311    ----------------------------------------
 312    -- Set_Aspect_Specifications_No_Check --
 313    ----------------------------------------
 314
 315    procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id) is
 316    begin
 317       pragma Assert (Permits_Aspect_Specifications (N));
 318       pragma Assert (L /= No_List);
 319
 320       Set_Has_Aspects (N);
 321       Set_Parent (L, N);
 322       Aspect_Specifications_Hash_Table.Set (N, L);
 323    end Set_Aspect_Specifications_No_Check;
 324
 325    ---------------
 326    -- Tree_Read --
 327    ---------------
 328
 329    procedure Tree_Read is
 330       Node : Node_Id;
 331       List : List_Id;
 332    begin
 333       loop
 334          Tree_Read_Int (Int (Node));
 335          Tree_Read_Int (Int (List));
 336          exit when List = No_List;
 337          Set_Aspect_Specifications_No_Check (Node, List);
 338       end loop;
 339    end Tree_Read;
 340
 341    ----------------
 342    -- Tree_Write --
 343    ----------------
 344
 345    procedure Tree_Write is
 346       Node : Node_Id := Empty;
 347       List : List_Id;
 348    begin
 349       Aspect_Specifications_Hash_Table.Get_First (Node, List);
 350       loop
 351          Tree_Write_Int (Int (Node));
 352          Tree_Write_Int (Int (List));
 353          exit when List = No_List;
 354          Aspect_Specifications_Hash_Table.Get_Next (Node, List);
 355       end loop;
 356    end Tree_Write;
 357
 358 --  Package initialization sets up Aspect Id hash table
 359
 360 begin
 361    for J in Aspect_Id loop
 362       Aspect_Id_Hash_Table.Set (Aspect_Names (J), J);
 363    end loop;
 364 end Aspects;