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-2013, 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       Typ   : Entity_Id;
 129
 130    begin
 131
 132       --  If the aspect is an inherited one and the entity is a class-wide
 133       --  type, use the aspect of the specific type. If the type is a base
 134       --  aspect, examine the rep. items of the base type.
 135
 136       if Is_Type (Ent) then
 137          if Base_Aspect (A) then
 138             Typ := Base_Type (Ent);
 139          else
 140             Typ := Ent;
 141          end if;
 142
 143          if Is_Class_Wide_Type (Typ)
 144            and then Inherited_Aspect (A)
 145          then
 146             Ritem := First_Rep_Item (Etype (Typ));
 147          else
 148             Ritem := First_Rep_Item (Typ);
 149          end if;
 150
 151       else
 152          Ritem := First_Rep_Item (Ent);
 153       end if;
 154
 155       while Present (Ritem) loop
 156          if Nkind (Ritem) = N_Aspect_Specification
 157            and then Get_Aspect_Id (Chars (Identifier (Ritem))) = A
 158          then
 159             if A = Aspect_Default_Iterator then
 160                return Expression (Aspect_Rep_Item (Ritem));
 161             else
 162                return Expression (Ritem);
 163             end if;
 164          end if;
 165
 166          Next_Rep_Item (Ritem);
 167       end loop;
 168
 169       return Empty;
 170    end Find_Aspect;
 171
 172    ------------------
 173    -- Move_Aspects --
 174    ------------------
 175
 176    procedure Move_Aspects (From : Node_Id; To : Node_Id) is
 177       pragma Assert (not Has_Aspects (To));
 178    begin
 179       if Has_Aspects (From) then
 180          Set_Aspect_Specifications (To, Aspect_Specifications (From));
 181          Aspect_Specifications_Hash_Table.Remove (From);
 182          Set_Has_Aspects (From, False);
 183       end if;
 184    end Move_Aspects;
 185
 186    -----------------------------------
 187    -- Permits_Aspect_Specifications --
 188    -----------------------------------
 189
 190    Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean :=
 191      (N_Abstract_Subprogram_Declaration        => True,
 192       N_Component_Declaration                  => True,
 193       N_Entry_Declaration                      => True,
 194       N_Exception_Declaration                  => True,
 195       N_Exception_Renaming_Declaration         => True,
 196       N_Expression_Function                    => True,
 197       N_Formal_Abstract_Subprogram_Declaration => True,
 198       N_Formal_Concrete_Subprogram_Declaration => True,
 199       N_Formal_Object_Declaration              => True,
 200       N_Formal_Package_Declaration             => True,
 201       N_Formal_Type_Declaration                => True,
 202       N_Full_Type_Declaration                  => True,
 203       N_Function_Instantiation                 => True,
 204       N_Generic_Package_Declaration            => True,
 205       N_Generic_Renaming_Declaration           => True,
 206       N_Generic_Subprogram_Declaration         => True,
 207       N_Object_Declaration                     => True,
 208       N_Object_Renaming_Declaration            => True,
 209       N_Package_Declaration                    => True,
 210       N_Package_Instantiation                  => True,
 211       N_Package_Specification                  => True,
 212       N_Package_Renaming_Declaration           => True,
 213       N_Private_Extension_Declaration          => True,
 214       N_Private_Type_Declaration               => True,
 215       N_Procedure_Instantiation                => True,
 216       N_Protected_Body                         => True,
 217       N_Protected_Type_Declaration             => True,
 218       N_Single_Protected_Declaration           => True,
 219       N_Single_Task_Declaration                => True,
 220       N_Subprogram_Body                        => True,
 221       N_Subprogram_Declaration                 => True,
 222       N_Subprogram_Renaming_Declaration        => True,
 223       N_Subtype_Declaration                    => True,
 224       N_Task_Body                              => True,
 225       N_Task_Type_Declaration                  => True,
 226       others                                   => False);
 227
 228    function Permits_Aspect_Specifications (N : Node_Id) return Boolean is
 229    begin
 230       return Has_Aspect_Specifications_Flag (Nkind (N));
 231    end Permits_Aspect_Specifications;
 232
 233    -----------------
 234    -- Same_Aspect --
 235    -----------------
 236
 237    --  Table used for Same_Aspect, maps aspect to canonical aspect
 238
 239    Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id :=
 240    (No_Aspect                           => No_Aspect,
 241     Aspect_Abstract_State               => Aspect_Abstract_State,
 242     Aspect_Ada_2005                     => Aspect_Ada_2005,
 243     Aspect_Ada_2012                     => Aspect_Ada_2005,
 244     Aspect_Address                      => Aspect_Address,
 245     Aspect_Alignment                    => Aspect_Alignment,
 246     Aspect_All_Calls_Remote             => Aspect_All_Calls_Remote,
 247     Aspect_Asynchronous                 => Aspect_Asynchronous,
 248     Aspect_Atomic                       => Aspect_Atomic,
 249     Aspect_Atomic_Components            => Aspect_Atomic_Components,
 250     Aspect_Attach_Handler               => Aspect_Attach_Handler,
 251     Aspect_Bit_Order                    => Aspect_Bit_Order,
 252     Aspect_Compiler_Unit                => Aspect_Compiler_Unit,
 253     Aspect_Component_Size               => Aspect_Component_Size,
 254     Aspect_Constant_Indexing            => Aspect_Constant_Indexing,
 255     Aspect_Contract_Case                => Aspect_Contract_Case,
 256     Aspect_Contract_Cases               => Aspect_Contract_Cases,
 257     Aspect_Convention                   => Aspect_Convention,
 258     Aspect_CPU                          => Aspect_CPU,
 259     Aspect_Default_Component_Value      => Aspect_Default_Component_Value,
 260     Aspect_Default_Iterator             => Aspect_Default_Iterator,
 261     Aspect_Default_Value                => Aspect_Default_Value,
 262     Aspect_Depends                      => Aspect_Depends,
 263     Aspect_Dimension                    => Aspect_Dimension,
 264     Aspect_Dimension_System             => Aspect_Dimension_System,
 265     Aspect_Discard_Names                => Aspect_Discard_Names,
 266     Aspect_Dispatching_Domain           => Aspect_Dispatching_Domain,
 267     Aspect_Dynamic_Predicate            => Aspect_Predicate,
 268     Aspect_Elaborate_Body               => Aspect_Elaborate_Body,
 269     Aspect_Export                       => Aspect_Export,
 270     Aspect_External_Name                => Aspect_External_Name,
 271     Aspect_External_Tag                 => Aspect_External_Tag,
 272     Aspect_Favor_Top_Level              => Aspect_Favor_Top_Level,
 273     Aspect_Global                       => Aspect_Global,
 274     Aspect_Implicit_Dereference         => Aspect_Implicit_Dereference,
 275     Aspect_Import                       => Aspect_Import,
 276     Aspect_Independent                  => Aspect_Independent,
 277     Aspect_Independent_Components       => Aspect_Independent_Components,
 278     Aspect_Inline                       => Aspect_Inline,
 279     Aspect_Inline_Always                => Aspect_Inline,
 280     Aspect_Input                        => Aspect_Input,
 281     Aspect_Interrupt_Handler            => Aspect_Interrupt_Handler,
 282     Aspect_Interrupt_Priority           => Aspect_Priority,
 283     Aspect_Invariant                    => Aspect_Invariant,
 284     Aspect_Iterator_Element             => Aspect_Iterator_Element,
 285     Aspect_Link_Name                    => Aspect_Link_Name,
 286     Aspect_Lock_Free                    => Aspect_Lock_Free,
 287     Aspect_Machine_Radix                => Aspect_Machine_Radix,
 288     Aspect_No_Return                    => Aspect_No_Return,
 289     Aspect_Object_Size                  => Aspect_Object_Size,
 290     Aspect_Output                       => Aspect_Output,
 291     Aspect_Pack                         => Aspect_Pack,
 292     Aspect_Persistent_BSS               => Aspect_Persistent_BSS,
 293     Aspect_Post                         => Aspect_Post,
 294     Aspect_Postcondition                => Aspect_Post,
 295     Aspect_Pre                          => Aspect_Pre,
 296     Aspect_Precondition                 => Aspect_Pre,
 297     Aspect_Predicate                    => Aspect_Predicate,
 298     Aspect_Preelaborate                 => Aspect_Preelaborate,
 299     Aspect_Preelaborate_05              => Aspect_Preelaborate_05,
 300     Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization,
 301     Aspect_Priority                     => Aspect_Priority,
 302     Aspect_Pure                         => Aspect_Pure,
 303     Aspect_Pure_05                      => Aspect_Pure_05,
 304     Aspect_Pure_12                      => Aspect_Pure_12,
 305     Aspect_Pure_Function                => Aspect_Pure_Function,
 306     Aspect_Remote_Access_Type           => Aspect_Remote_Access_Type,
 307     Aspect_Remote_Call_Interface        => Aspect_Remote_Call_Interface,
 308     Aspect_Remote_Types                 => Aspect_Remote_Types,
 309     Aspect_Read                         => Aspect_Read,
 310     Aspect_Relative_Deadline            => Aspect_Relative_Deadline,
 311     Aspect_Scalar_Storage_Order         => Aspect_Scalar_Storage_Order,
 312     Aspect_Shared                       => Aspect_Atomic,
 313     Aspect_Shared_Passive               => Aspect_Shared_Passive,
 314     Aspect_Simple_Storage_Pool          => Aspect_Simple_Storage_Pool,
 315     Aspect_Simple_Storage_Pool_Type     => Aspect_Simple_Storage_Pool_Type,
 316     Aspect_Size                         => Aspect_Size,
 317     Aspect_Small                        => Aspect_Small,
 318     Aspect_Static_Predicate             => Aspect_Predicate,
 319     Aspect_Storage_Pool                 => Aspect_Storage_Pool,
 320     Aspect_Storage_Size                 => Aspect_Storage_Size,
 321     Aspect_Stream_Size                  => Aspect_Stream_Size,
 322     Aspect_Suppress                     => Aspect_Suppress,
 323     Aspect_Suppress_Debug_Info          => Aspect_Suppress_Debug_Info,
 324     Aspect_Synchronization              => Aspect_Synchronization,
 325     Aspect_Test_Case                    => Aspect_Test_Case,
 326     Aspect_Type_Invariant               => Aspect_Invariant,
 327     Aspect_Unchecked_Union              => Aspect_Unchecked_Union,
 328     Aspect_Universal_Aliasing           => Aspect_Universal_Aliasing,
 329     Aspect_Universal_Data               => Aspect_Universal_Data,
 330     Aspect_Unmodified                   => Aspect_Unmodified,
 331     Aspect_Unreferenced                 => Aspect_Unreferenced,
 332     Aspect_Unreferenced_Objects         => Aspect_Unreferenced_Objects,
 333     Aspect_Unsuppress                   => Aspect_Unsuppress,
 334     Aspect_Variable_Indexing            => Aspect_Variable_Indexing,
 335     Aspect_Value_Size                   => Aspect_Value_Size,
 336     Aspect_Volatile                     => Aspect_Volatile,
 337     Aspect_Volatile_Components          => Aspect_Volatile_Components,
 338     Aspect_Warnings                     => Aspect_Warnings,
 339     Aspect_Write                        => Aspect_Write);
 340
 341    function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is
 342    begin
 343       return Canonical_Aspect (A1) = Canonical_Aspect (A2);
 344    end Same_Aspect;
 345
 346    -------------------------------
 347    -- Set_Aspect_Specifications --
 348    -------------------------------
 349
 350    procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is
 351    begin
 352       pragma Assert (Permits_Aspect_Specifications (N));
 353       pragma Assert (not Has_Aspects (N));
 354       pragma Assert (L /= No_List);
 355
 356       Set_Has_Aspects (N);
 357       Set_Parent (L, N);
 358       Aspect_Specifications_Hash_Table.Set (N, L);
 359    end Set_Aspect_Specifications;
 360
 361    ----------------------------------------
 362    -- Set_Aspect_Specifications_No_Check --
 363    ----------------------------------------
 364
 365    procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id) is
 366    begin
 367       pragma Assert (Permits_Aspect_Specifications (N));
 368       pragma Assert (L /= No_List);
 369
 370       Set_Has_Aspects (N);
 371       Set_Parent (L, N);
 372       Aspect_Specifications_Hash_Table.Set (N, L);
 373    end Set_Aspect_Specifications_No_Check;
 374
 375    ---------------
 376    -- Tree_Read --
 377    ---------------
 378
 379    procedure Tree_Read is
 380       Node : Node_Id;
 381       List : List_Id;
 382    begin
 383       loop
 384          Tree_Read_Int (Int (Node));
 385          Tree_Read_Int (Int (List));
 386          exit when List = No_List;
 387          Set_Aspect_Specifications_No_Check (Node, List);
 388       end loop;
 389    end Tree_Read;
 390
 391    ----------------
 392    -- Tree_Write --
 393    ----------------
 394
 395    procedure Tree_Write is
 396       Node : Node_Id := Empty;
 397       List : List_Id;
 398    begin
 399       Aspect_Specifications_Hash_Table.Get_First (Node, List);
 400       loop
 401          Tree_Write_Int (Int (Node));
 402          Tree_Write_Int (Int (List));
 403          exit when List = No_List;
 404          Aspect_Specifications_Hash_Table.Get_Next (Node, List);
 405       end loop;
 406    end Tree_Write;
 407
 408 --  Package initialization sets up Aspect Id hash table
 409
 410 begin
 411    for J in Aspect_Id loop
 412       Aspect_Id_Hash_Table.Set (Aspect_Names (J), J);
 413    end loop;
 414 end Aspects;