diff options
Diffstat (limited to 'gcc-4.9/gcc/ada/aspects.adb')
-rw-r--r-- | gcc-4.9/gcc/ada/aspects.adb | 674 |
1 files changed, 674 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/aspects.adb b/gcc-4.9/gcc/ada/aspects.adb new file mode 100644 index 000000000..cc8d2f93d --- /dev/null +++ b/gcc-4.9/gcc/ada/aspects.adb @@ -0,0 +1,674 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A S P E C T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2013, 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 Einfo; use Einfo; +with Nlists; use Nlists; +with Sinfo; use Sinfo; +with Tree_IO; use Tree_IO; + +with GNAT.HTable; use GNAT.HTable; + +package body Aspects is + + -- The following array indicates aspects that a subtype inherits from its + -- base type. True means that the subtype inherits the aspect from its base + -- type. False means it is not inherited. + + Base_Aspect : constant array (Aspect_Id) of Boolean := + (Aspect_Atomic => True, + Aspect_Atomic_Components => True, + Aspect_Constant_Indexing => True, + Aspect_Default_Iterator => True, + Aspect_Discard_Names => True, + Aspect_Independent_Components => True, + Aspect_Iterator_Element => True, + Aspect_Type_Invariant => True, + Aspect_Unchecked_Union => True, + Aspect_Variable_Indexing => True, + Aspect_Volatile => True, + others => False); + + -- The following array indicates type aspects that are inherited and apply + -- to the class-wide type as well. + + Inherited_Aspect : constant array (Aspect_Id) of Boolean := + (Aspect_Constant_Indexing => True, + Aspect_Default_Iterator => True, + Aspect_Implicit_Dereference => True, + Aspect_Iterator_Element => True, + Aspect_Remote_Types => True, + Aspect_Variable_Indexing => True, + others => False); + + procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id); + -- Same as Set_Aspect_Specifications, but does not contain the assertion + -- that checks that N does not already have aspect specifications. This + -- subprogram is supposed to be used as a part of Tree_Read. When reading + -- tree, first read nodes with their basic properties (as Atree.Tree_Read), + -- this includes reading the Has_Aspects flag for each node, then we reed + -- all the list tables and only after that we call Tree_Read for Aspects. + -- That is, when reading the tree, the list of aspects is attached to the + -- node that already has Has_Aspects flag set ON. + + ------------------------------------------ + -- 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 => "="); + + ------------------------------------- + -- 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 => "="); + + --------------------------- + -- 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; + + -------------------------------- + -- Aspects_On_Body_Or_Stub_OK -- + -------------------------------- + + function Aspects_On_Body_Or_Stub_OK (N : Node_Id) return Boolean is + Aspect : Node_Id; + Aspects : List_Id; + + begin + -- The routine should be invoked on a body [stub] with aspects + + pragma Assert (Has_Aspects (N)); + pragma Assert (Nkind (N) in N_Body_Stub + or else Nkind_In (N, N_Package_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body)); + + -- Look through all aspects and see whether they can be applied to a + -- body [stub]. + + Aspects := Aspect_Specifications (N); + Aspect := First (Aspects); + while Present (Aspect) loop + if not Aspect_On_Body_Or_Stub_OK (Get_Aspect_Id (Aspect)) then + return False; + end if; + + Next (Aspect); + end loop; + + return True; + end Aspects_On_Body_Or_Stub_OK; + + ---------------------- + -- Exchange_Aspects -- + ---------------------- + + procedure Exchange_Aspects (N1 : Node_Id; N2 : Node_Id) is + begin + pragma Assert + (Permits_Aspect_Specifications (N1) + and then Permits_Aspect_Specifications (N2)); + + -- Perform the exchange only when both nodes have lists to be swapped + + if Has_Aspects (N1) and then Has_Aspects (N2) then + declare + L1 : constant List_Id := Aspect_Specifications (N1); + L2 : constant List_Id := Aspect_Specifications (N2); + begin + Set_Parent (L1, N2); + Set_Parent (L2, N1); + Aspect_Specifications_Hash_Table.Set (N1, L2); + Aspect_Specifications_Hash_Table.Set (N2, L1); + end; + end if; + end Exchange_Aspects; + + ----------------- + -- Find_Aspect -- + ----------------- + + function Find_Aspect (Id : Entity_Id; A : Aspect_Id) return Node_Id is + Decl : Node_Id; + Item : Node_Id; + Owner : Entity_Id; + Spec : Node_Id; + + begin + Owner := Id; + + -- Handle various cases of base or inherited aspects for types + + if Is_Type (Id) then + if Base_Aspect (A) then + Owner := Base_Type (Owner); + end if; + + if Is_Class_Wide_Type (Owner) and then Inherited_Aspect (A) then + Owner := Root_Type (Owner); + end if; + + if Is_Private_Type (Owner) and then Present (Full_View (Owner)) then + Owner := Full_View (Owner); + end if; + end if; + + -- Search the representation items for the desired aspect + + Item := First_Rep_Item (Owner); + while Present (Item) loop + if Nkind (Item) = N_Aspect_Specification + and then Get_Aspect_Id (Item) = A + then + return Item; + end if; + + Next_Rep_Item (Item); + end loop; + + -- Note that not all aspects are added to the chain of representation + -- items. In such cases, search the list of aspect specifications. First + -- find the declaration node where the aspects reside. This is usually + -- the parent or the parent of the parent. + + Decl := Parent (Owner); + if not Permits_Aspect_Specifications (Decl) then + Decl := Parent (Decl); + end if; + + -- Search the list of aspect specifications for the desired aspect + + if Permits_Aspect_Specifications (Decl) then + Spec := First (Aspect_Specifications (Decl)); + while Present (Spec) loop + if Get_Aspect_Id (Spec) = A then + return Spec; + end if; + + Next (Spec); + end loop; + end if; + + -- The entity does not carry any aspects or the desired aspect was not + -- found. + + return Empty; + end Find_Aspect; + + -------------------------- + -- Find_Value_Of_Aspect -- + -------------------------- + + function Find_Value_Of_Aspect + (Id : Entity_Id; + A : Aspect_Id) return Node_Id + is + Spec : constant Node_Id := Find_Aspect (Id, A); + + begin + if Present (Spec) then + if A = Aspect_Default_Iterator then + return Expression (Aspect_Rep_Item (Spec)); + else + return Expression (Spec); + end if; + end if; + + return Empty; + end Find_Value_Of_Aspect; + + ------------------- + -- 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; + + function Get_Aspect_Id (Aspect : Node_Id) return Aspect_Id is + begin + pragma Assert (Nkind (Aspect) = N_Aspect_Specification); + return Aspect_Id_Hash_Table.Get (Chars (Identifier (Aspect))); + end Get_Aspect_Id; + + ---------------- + -- Has_Aspect -- + ---------------- + + function Has_Aspect (Id : Entity_Id; A : Aspect_Id) return Boolean is + begin + return Present (Find_Aspect (Id, A)); + end Has_Aspect; + + ------------------ + -- 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; + + --------------------------- + -- Move_Or_Merge_Aspects -- + --------------------------- + + procedure Move_Or_Merge_Aspects (From : Node_Id; To : Node_Id) is + procedure Relocate_Aspect (Asp : Node_Id); + -- Asp denotes an aspect specification of node From. Relocate the Asp to + -- the aspect specifications of node To (if any). + + --------------------- + -- Relocate_Aspect -- + --------------------- + + procedure Relocate_Aspect (Asp : Node_Id) is + Asps : List_Id; + + begin + if Has_Aspects (To) then + Asps := Aspect_Specifications (To); + + -- Create a new aspect specification list for node To + + else + Asps := New_List; + Set_Aspect_Specifications (To, Asps); + Set_Has_Aspects (To); + end if; + + -- Remove the aspect from node From's aspect specifications and + -- append it to node To. + + Remove (Asp); + Append (Asp, Asps); + end Relocate_Aspect; + + -- Local variables + + Asp : Node_Id; + Asp_Id : Aspect_Id; + Next_Asp : Node_Id; + + -- Start of processing for Move_Or_Merge_Aspects + + begin + if Has_Aspects (From) then + Asp := First (Aspect_Specifications (From)); + while Present (Asp) loop + + -- Store the next aspect now as a potential relocation will alter + -- the contents of the list. + + Next_Asp := Next (Asp); + + -- When moving or merging aspects from a subprogram body stub that + -- also acts as a spec, relocate only those aspects that may apply + -- to a body [stub]. Note that a precondition must also be moved + -- to the proper body as the pre/post machinery expects it to be + -- there. + + if Nkind (From) = N_Subprogram_Body_Stub + and then No (Corresponding_Spec_Of_Stub (From)) + then + Asp_Id := Get_Aspect_Id (Asp); + + if Aspect_On_Body_Or_Stub_OK (Asp_Id) + or else Asp_Id = Aspect_Pre + or else Asp_Id = Aspect_Precondition + then + Relocate_Aspect (Asp); + end if; + + -- Default case - relocate the aspect to its new owner + + else + Relocate_Aspect (Asp); + end if; + + Asp := Next_Asp; + end loop; + + -- The relocations may have left node From's aspect specifications + -- list empty. If this is the case, simply remove the aspects. + + if Is_Empty_List (Aspect_Specifications (From)) then + Remove_Aspects (From); + end if; + end if; + end Move_Or_Merge_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_Exception_Renaming_Declaration => True, + N_Expression_Function => 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_Renaming_Declaration => True, + N_Generic_Subprogram_Declaration => True, + N_Object_Declaration => True, + N_Object_Renaming_Declaration => True, + N_Package_Body => True, + N_Package_Body_Stub => True, + N_Package_Declaration => True, + N_Package_Instantiation => True, + N_Package_Specification => True, + N_Package_Renaming_Declaration => True, + N_Private_Extension_Declaration => True, + N_Private_Type_Declaration => True, + N_Procedure_Instantiation => True, + N_Protected_Body => True, + N_Protected_Body_Stub => True, + N_Protected_Type_Declaration => True, + N_Single_Protected_Declaration => True, + N_Single_Task_Declaration => True, + N_Subprogram_Body => True, + N_Subprogram_Body_Stub => True, + N_Subprogram_Declaration => True, + N_Subprogram_Renaming_Declaration => True, + N_Subtype_Declaration => True, + N_Task_Body => True, + N_Task_Body_Stub => 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; + + -------------------- + -- Remove_Aspects -- + -------------------- + + procedure Remove_Aspects (N : Node_Id) is + begin + if Has_Aspects (N) then + Aspect_Specifications_Hash_Table.Remove (N); + Set_Has_Aspects (N, False); + end if; + end Remove_Aspects; + + ----------------- + -- Same_Aspect -- + ----------------- + + -- Table used for Same_Aspect, maps aspect to canonical aspect + + Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id := + (No_Aspect => No_Aspect, + Aspect_Abstract_State => Aspect_Abstract_State, + Aspect_Address => Aspect_Address, + Aspect_Alignment => Aspect_Alignment, + Aspect_All_Calls_Remote => Aspect_All_Calls_Remote, + Aspect_Async_Readers => Aspect_Async_Readers, + Aspect_Async_Writers => Aspect_Async_Writers, + Aspect_Asynchronous => Aspect_Asynchronous, + Aspect_Atomic => Aspect_Atomic, + Aspect_Atomic_Components => Aspect_Atomic_Components, + Aspect_Attach_Handler => Aspect_Attach_Handler, + Aspect_Bit_Order => Aspect_Bit_Order, + Aspect_Component_Size => Aspect_Component_Size, + Aspect_Constant_Indexing => Aspect_Constant_Indexing, + Aspect_Contract_Cases => Aspect_Contract_Cases, + Aspect_Convention => Aspect_Convention, + Aspect_CPU => Aspect_CPU, + Aspect_Default_Component_Value => Aspect_Default_Component_Value, + Aspect_Default_Iterator => Aspect_Default_Iterator, + Aspect_Default_Value => Aspect_Default_Value, + Aspect_Depends => Aspect_Depends, + Aspect_Dimension => Aspect_Dimension, + Aspect_Dimension_System => Aspect_Dimension_System, + Aspect_Discard_Names => Aspect_Discard_Names, + Aspect_Dispatching_Domain => Aspect_Dispatching_Domain, + Aspect_Dynamic_Predicate => Aspect_Predicate, + Aspect_Effective_Reads => Aspect_Effective_Reads, + Aspect_Effective_Writes => Aspect_Effective_Writes, + Aspect_Elaborate_Body => Aspect_Elaborate_Body, + Aspect_Export => Aspect_Export, + Aspect_External_Name => Aspect_External_Name, + Aspect_External_Tag => Aspect_External_Tag, + Aspect_Favor_Top_Level => Aspect_Favor_Top_Level, + Aspect_Global => Aspect_Global, + Aspect_Implicit_Dereference => Aspect_Implicit_Dereference, + Aspect_Import => Aspect_Import, + Aspect_Independent => Aspect_Independent, + Aspect_Independent_Components => Aspect_Independent_Components, + Aspect_Inline => Aspect_Inline, + Aspect_Inline_Always => Aspect_Inline, + Aspect_Initial_Condition => Aspect_Initial_Condition, + Aspect_Initializes => Aspect_Initializes, + Aspect_Input => Aspect_Input, + Aspect_Interrupt_Handler => Aspect_Interrupt_Handler, + Aspect_Interrupt_Priority => Aspect_Priority, + Aspect_Invariant => Aspect_Invariant, + Aspect_Iterable => Aspect_Iterable, + Aspect_Iterator_Element => Aspect_Iterator_Element, + Aspect_Link_Name => Aspect_Link_Name, + Aspect_Linker_Section => Aspect_Linker_Section, + Aspect_Lock_Free => Aspect_Lock_Free, + Aspect_Machine_Radix => Aspect_Machine_Radix, + Aspect_No_Return => Aspect_No_Return, + Aspect_Object_Size => Aspect_Object_Size, + Aspect_Output => Aspect_Output, + Aspect_Pack => Aspect_Pack, + Aspect_Part_Of => Aspect_Part_Of, + Aspect_Persistent_BSS => Aspect_Persistent_BSS, + Aspect_Post => Aspect_Post, + Aspect_Postcondition => Aspect_Post, + Aspect_Pre => Aspect_Pre, + Aspect_Precondition => Aspect_Pre, + Aspect_Predicate => Aspect_Predicate, + Aspect_Preelaborate => Aspect_Preelaborate, + Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization, + Aspect_Priority => Aspect_Priority, + Aspect_Pure => Aspect_Pure, + Aspect_Pure_Function => Aspect_Pure_Function, + Aspect_Refined_Depends => Aspect_Refined_Depends, + Aspect_Refined_Global => Aspect_Refined_Global, + Aspect_Refined_Post => Aspect_Refined_Post, + Aspect_Refined_State => Aspect_Refined_State, + Aspect_Remote_Access_Type => Aspect_Remote_Access_Type, + Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface, + Aspect_Remote_Types => Aspect_Remote_Types, + Aspect_Read => Aspect_Read, + Aspect_Relative_Deadline => Aspect_Relative_Deadline, + Aspect_Scalar_Storage_Order => Aspect_Scalar_Storage_Order, + Aspect_Shared => Aspect_Atomic, + Aspect_Shared_Passive => Aspect_Shared_Passive, + Aspect_Simple_Storage_Pool => Aspect_Simple_Storage_Pool, + Aspect_Simple_Storage_Pool_Type => Aspect_Simple_Storage_Pool_Type, + Aspect_Size => Aspect_Size, + Aspect_Small => Aspect_Small, + Aspect_SPARK_Mode => Aspect_SPARK_Mode, + Aspect_Static_Predicate => Aspect_Predicate, + Aspect_Storage_Pool => Aspect_Storage_Pool, + Aspect_Storage_Size => Aspect_Storage_Size, + Aspect_Stream_Size => Aspect_Stream_Size, + Aspect_Suppress => Aspect_Suppress, + Aspect_Suppress_Debug_Info => Aspect_Suppress_Debug_Info, + Aspect_Synchronization => Aspect_Synchronization, + Aspect_Test_Case => Aspect_Test_Case, + Aspect_Type_Invariant => Aspect_Invariant, + Aspect_Unchecked_Union => Aspect_Unchecked_Union, + Aspect_Universal_Aliasing => Aspect_Universal_Aliasing, + Aspect_Universal_Data => Aspect_Universal_Data, + Aspect_Unmodified => Aspect_Unmodified, + Aspect_Unreferenced => Aspect_Unreferenced, + Aspect_Unreferenced_Objects => Aspect_Unreferenced_Objects, + Aspect_Unsuppress => Aspect_Unsuppress, + Aspect_Variable_Indexing => Aspect_Variable_Indexing, + Aspect_Value_Size => Aspect_Value_Size, + Aspect_Volatile => Aspect_Volatile, + Aspect_Volatile_Components => Aspect_Volatile_Components, + Aspect_Warnings => Aspect_Warnings, + Aspect_Write => Aspect_Write); + + function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is + begin + return Canonical_Aspect (A1) = Canonical_Aspect (A2); + end Same_Aspect; + + ------------------------------- + -- 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; + + ---------------------------------------- + -- Set_Aspect_Specifications_No_Check -- + ---------------------------------------- + + procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id) is + begin + pragma Assert (Permits_Aspect_Specifications (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_No_Check; + + --------------- + -- 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_No_Check (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_Id loop + Aspect_Id_Hash_Table.Set (Aspect_Names (J), J); + end loop; +end Aspects; |