diff options
author | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
---|---|---|
committer | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
commit | 554fd8c5195424bdbcabf5de30fdc183aba391bd (patch) | |
tree | 976dc5ab7fddf506dadce60ae936f43f58787092 /gcc/ada/aspects.adb | |
download | cbb-gcc-4.6.4-15d2061ac0796199866debe9ac87130894b0cdd3.tar.bz2 cbb-gcc-4.6.4-15d2061ac0796199866debe9ac87130894b0cdd3.tar.xz |
obtained gcc-4.6.4.tar.bz2 from upstream website;upstream
verified gcc-4.6.4.tar.bz2.sig;
imported gcc-4.6.4 source tree from verified upstream tarball.
downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.
if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
Diffstat (limited to 'gcc/ada/aspects.adb')
-rwxr-xr-x | gcc/ada/aspects.adb | 272 |
1 files changed, 272 insertions, 0 deletions
diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb new file mode 100755 index 000000000..faf50cd86 --- /dev/null +++ b/gcc/ada/aspects.adb @@ -0,0 +1,272 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A S P E C T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Nlists; use Nlists; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Tree_IO; use Tree_IO; + +with GNAT.HTable; use GNAT.HTable; + +package body Aspects is + + ------------------------------------------ + -- Hash Table for Aspect Specifications -- + ------------------------------------------ + + type AS_Hash_Range is range 0 .. 510; + -- Size of hash table headers + + function AS_Hash (F : Node_Id) return AS_Hash_Range; + -- Hash function for hash table + + function AS_Hash (F : Node_Id) return AS_Hash_Range is + begin + return AS_Hash_Range (F mod 511); + end AS_Hash; + + package Aspect_Specifications_Hash_Table is new + GNAT.HTable.Simple_HTable + (Header_Num => AS_Hash_Range, + Element => List_Id, + No_Element => No_List, + Key => Node_Id, + Hash => AS_Hash, + Equal => "="); + + ----------------------------------------- + -- Table Linking Names and Aspect_Id's -- + ----------------------------------------- + + type Aspect_Entry is record + Nam : Name_Id; + Asp : Aspect_Id; + end record; + + Aspect_Names : constant array (Integer range <>) of Aspect_Entry := ( + (Name_Ada_2005, Aspect_Ada_2005), + (Name_Ada_2012, Aspect_Ada_2012), + (Name_Address, Aspect_Address), + (Name_Alignment, Aspect_Alignment), + (Name_Atomic, Aspect_Atomic), + (Name_Atomic_Components, Aspect_Atomic_Components), + (Name_Bit_Order, Aspect_Bit_Order), + (Name_Component_Size, Aspect_Component_Size), + (Name_Discard_Names, Aspect_Discard_Names), + (Name_External_Tag, Aspect_External_Tag), + (Name_Favor_Top_Level, Aspect_Favor_Top_Level), + (Name_Inline, Aspect_Inline), + (Name_Inline_Always, Aspect_Inline_Always), + (Name_Input, Aspect_Input), + (Name_Invariant, Aspect_Invariant), + (Name_Machine_Radix, Aspect_Machine_Radix), + (Name_Object_Size, Aspect_Object_Size), + (Name_Output, Aspect_Output), + (Name_Pack, Aspect_Pack), + (Name_Persistent_BSS, Aspect_Persistent_BSS), + (Name_Post, Aspect_Post), + (Name_Pre, Aspect_Pre), + (Name_Predicate, Aspect_Predicate), + (Name_Preelaborable_Initialization, Aspect_Preelaborable_Initialization), + (Name_Pure_Function, Aspect_Pure_Function), + (Name_Read, Aspect_Read), + (Name_Shared, Aspect_Shared), + (Name_Size, Aspect_Size), + (Name_Storage_Pool, Aspect_Storage_Pool), + (Name_Storage_Size, Aspect_Storage_Size), + (Name_Stream_Size, Aspect_Stream_Size), + (Name_Suppress, Aspect_Suppress), + (Name_Suppress_Debug_Info, Aspect_Suppress_Debug_Info), + (Name_Unchecked_Union, Aspect_Unchecked_Union), + (Name_Universal_Aliasing, Aspect_Universal_Aliasing), + (Name_Unmodified, Aspect_Unmodified), + (Name_Unreferenced, Aspect_Unreferenced), + (Name_Unreferenced_Objects, Aspect_Unreferenced_Objects), + (Name_Unsuppress, Aspect_Unsuppress), + (Name_Value_Size, Aspect_Value_Size), + (Name_Volatile, Aspect_Volatile), + (Name_Volatile_Components, Aspect_Volatile_Components), + (Name_Warnings, Aspect_Warnings), + (Name_Write, Aspect_Write)); + + ------------------------------------- + -- Hash Table for Aspect Id Values -- + ------------------------------------- + + type AI_Hash_Range is range 0 .. 112; + -- Size of hash table headers + + function AI_Hash (F : Name_Id) return AI_Hash_Range; + -- Hash function for hash table + + function AI_Hash (F : Name_Id) return AI_Hash_Range is + begin + return AI_Hash_Range (F mod 113); + end AI_Hash; + + package Aspect_Id_Hash_Table is new + GNAT.HTable.Simple_HTable + (Header_Num => AI_Hash_Range, + Element => Aspect_Id, + No_Element => No_Aspect, + Key => Name_Id, + Hash => AI_Hash, + Equal => "="); + + ------------------- + -- Get_Aspect_Id -- + ------------------- + + function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is + begin + return Aspect_Id_Hash_Table.Get (Name); + end Get_Aspect_Id; + + --------------------------- + -- Aspect_Specifications -- + --------------------------- + + function Aspect_Specifications (N : Node_Id) return List_Id is + begin + if Has_Aspects (N) then + return Aspect_Specifications_Hash_Table.Get (N); + else + return No_List; + end if; + end Aspect_Specifications; + + ------------------ + -- Move_Aspects -- + ------------------ + + procedure Move_Aspects (From : Node_Id; To : Node_Id) is + pragma Assert (not Has_Aspects (To)); + begin + if Has_Aspects (From) then + Set_Aspect_Specifications (To, Aspect_Specifications (From)); + Aspect_Specifications_Hash_Table.Remove (From); + Set_Has_Aspects (From, False); + end if; + end Move_Aspects; + + ----------------------------------- + -- Permits_Aspect_Specifications -- + ----------------------------------- + + Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean := + (N_Abstract_Subprogram_Declaration => True, + N_Component_Declaration => True, + N_Entry_Declaration => True, + N_Exception_Declaration => True, + N_Formal_Abstract_Subprogram_Declaration => True, + N_Formal_Concrete_Subprogram_Declaration => True, + N_Formal_Object_Declaration => True, + N_Formal_Package_Declaration => True, + N_Formal_Type_Declaration => True, + N_Full_Type_Declaration => True, + N_Function_Instantiation => True, + N_Generic_Package_Declaration => True, + N_Generic_Subprogram_Declaration => True, + N_Object_Declaration => True, + N_Package_Declaration => True, + N_Package_Instantiation => True, + N_Private_Extension_Declaration => True, + N_Private_Type_Declaration => True, + N_Procedure_Instantiation => True, + N_Protected_Type_Declaration => True, + N_Single_Protected_Declaration => True, + N_Single_Task_Declaration => True, + N_Subprogram_Declaration => True, + N_Subtype_Declaration => True, + N_Task_Type_Declaration => True, + others => False); + + function Permits_Aspect_Specifications (N : Node_Id) return Boolean is + begin + return Has_Aspect_Specifications_Flag (Nkind (N)); + end Permits_Aspect_Specifications; + + ------------------------------- + -- Set_Aspect_Specifications -- + ------------------------------- + + procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is + begin + pragma Assert (Permits_Aspect_Specifications (N)); + pragma Assert (not Has_Aspects (N)); + pragma Assert (L /= No_List); + + Set_Has_Aspects (N); + Set_Parent (L, N); + Aspect_Specifications_Hash_Table.Set (N, L); + end Set_Aspect_Specifications; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + Node : Node_Id; + List : List_Id; + begin + loop + Tree_Read_Int (Int (Node)); + Tree_Read_Int (Int (List)); + exit when List = No_List; + Set_Aspect_Specifications (Node, List); + end loop; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + Node : Node_Id := Empty; + List : List_Id; + begin + Aspect_Specifications_Hash_Table.Get_First (Node, List); + loop + Tree_Write_Int (Int (Node)); + Tree_Write_Int (Int (List)); + exit when List = No_List; + Aspect_Specifications_Hash_Table.Get_Next (Node, List); + end loop; + end Tree_Write; + +-- Package initialization sets up Aspect Id hash table + +begin + for J in Aspect_Names'Range loop + Aspect_Id_Hash_Table.Set (Aspect_Names (J).Nam, Aspect_Names (J).Asp); + end loop; +end Aspects; |