diff options
Diffstat (limited to 'gcc-4.9/gcc/ada/sem_scil.adb')
| -rw-r--r-- | gcc-4.9/gcc/ada/sem_scil.adb | 220 |
1 files changed, 220 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/sem_scil.adb b/gcc-4.9/gcc/ada/sem_scil.adb new file mode 100644 index 000000000..b94411a49 --- /dev/null +++ b/gcc-4.9/gcc/ada/sem_scil.adb @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ S C I L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2012, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Einfo; use Einfo; +with Nlists; use Nlists; +with Rtsfind; use Rtsfind; +with Sem_Aux; use Sem_Aux; +with Sinfo; use Sinfo; +with Stand; use Stand; +with SCIL_LL; use SCIL_LL; + +package body Sem_SCIL is + + --------------------- + -- Check_SCIL_Node -- + --------------------- + + function Check_SCIL_Node (N : Node_Id) return Traverse_Result is + SCIL_Node : constant Node_Id := Get_SCIL_Node (N); + Ctrl_Tag : Node_Id; + Ctrl_Typ : Entity_Id; + + begin + -- For nodes that do not have SCIL node continue traversing the tree + + if No (SCIL_Node) then + return OK; + end if; + + case Nkind (SCIL_Node) is + when N_SCIL_Dispatch_Table_Tag_Init => + pragma Assert (Nkind (N) = N_Object_Declaration); + null; + + when N_SCIL_Dispatching_Call => + Ctrl_Tag := SCIL_Controlling_Tag (SCIL_Node); + + -- Parent of SCIL dispatching call nodes MUST be a subprogram call + + if Nkind (N) not in N_Subprogram_Call then + raise Program_Error; + + -- In simple cases the controlling tag is the tag of the + -- controlling argument (i.e. Obj.Tag). + + elsif Nkind (Ctrl_Tag) = N_Selected_Component then + Ctrl_Typ := Etype (Ctrl_Tag); + + -- Interface types are unsupported + + if Is_Interface (Ctrl_Typ) + or else (RTE_Available (RE_Interface_Tag) + and then Ctrl_Typ = RTE (RE_Interface_Tag)) + then + null; + + else + pragma Assert (Ctrl_Typ = RTE (RE_Tag)); + null; + end if; + + -- When the controlling tag of a dispatching call is an identifier + -- the SCIL_Controlling_Tag attribute references the corresponding + -- object or parameter declaration. Interface types are still + -- unsupported. + + elsif Nkind_In (Ctrl_Tag, N_Object_Declaration, + N_Parameter_Specification) + then + Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag)); + + -- Interface types are unsupported. + + if Is_Interface (Ctrl_Typ) + or else (RTE_Available (RE_Interface_Tag) + and then Ctrl_Typ = RTE (RE_Interface_Tag)) + or else (Is_Access_Type (Ctrl_Typ) + and then + Is_Interface + (Available_View + (Base_Type (Designated_Type (Ctrl_Typ))))) + then + null; + + else + pragma Assert + (Ctrl_Typ = RTE (RE_Tag) + or else + (Is_Access_Type (Ctrl_Typ) + and then Available_View + (Base_Type (Designated_Type (Ctrl_Typ))) + = RTE (RE_Tag))); + null; + end if; + + -- Interface types are unsupported + + elsif Is_Interface (Etype (Ctrl_Tag)) then + null; + + else + pragma Assert (False); + raise Program_Error; + end if; + + return Skip; + + when N_SCIL_Membership_Test => + + -- Check contents of the boolean expression associated with the + -- membership test. + + pragma Assert (Nkind_In (N, N_Identifier, + N_And_Then, + N_Or_Else, + N_Expression_With_Actions) + and then Etype (N) = Standard_Boolean); + + -- Check the entity identifier of the associated tagged type (that + -- is, in testing for membership in T'Class, the entity id of the + -- specific type T). + + -- Note: When the SCIL node is generated the private and full-view + -- of the tagged types may have been swapped and hence the node + -- referenced by attribute SCIL_Entity may be the private view. + -- Therefore, in order to uniformly locate the full-view we use + -- attribute Underlying_Type. + + pragma Assert + (Is_Tagged_Type (Underlying_Type (SCIL_Entity (SCIL_Node)))); + + -- Interface types are unsupported + + pragma Assert + (not Is_Interface (Underlying_Type (SCIL_Entity (SCIL_Node)))); + + -- Check the decoration of the expression that denotes the tag + -- value being tested + + Ctrl_Tag := SCIL_Tag_Value (SCIL_Node); + + case Nkind (Ctrl_Tag) is + + -- For class-wide membership tests the SCIL tag value is the + -- tag of the tested object (i.e. Obj.Tag). + + when N_Selected_Component => + pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag)); + null; + + when others => + pragma Assert (False); + null; + end case; + + return Skip; + + when others => + pragma Assert (False); + raise Program_Error; + end case; + + return Skip; + end Check_SCIL_Node; + + ------------------------- + -- First_Non_SCIL_Node -- + ------------------------- + + function First_Non_SCIL_Node (L : List_Id) return Node_Id is + N : Node_Id; + + begin + N := First (L); + while Nkind (N) in N_SCIL_Node loop + Next (N); + end loop; + + return N; + end First_Non_SCIL_Node; + + ------------------------ + -- Next_Non_SCIL_Node -- + ------------------------ + + function Next_Non_SCIL_Node (N : Node_Id) return Node_Id is + Aux_N : Node_Id; + + begin + Aux_N := Next (N); + while Nkind (Aux_N) in N_SCIL_Node loop + Next (Aux_N); + end loop; + + return Aux_N; + end Next_Non_SCIL_Node; + +end Sem_SCIL; |