1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ S C I L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2009-2012, 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. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Einfo; use Einfo; 27with Nlists; use Nlists; 28with Rtsfind; use Rtsfind; 29with Sem_Aux; use Sem_Aux; 30with Sinfo; use Sinfo; 31with Stand; use Stand; 32with SCIL_LL; use SCIL_LL; 33 34package body Sem_SCIL is 35 36 --------------------- 37 -- Check_SCIL_Node -- 38 --------------------- 39 40 function Check_SCIL_Node (N : Node_Id) return Traverse_Result is 41 SCIL_Node : constant Node_Id := Get_SCIL_Node (N); 42 Ctrl_Tag : Node_Id; 43 Ctrl_Typ : Entity_Id; 44 45 begin 46 -- For nodes that do not have SCIL node continue traversing the tree 47 48 if No (SCIL_Node) then 49 return OK; 50 end if; 51 52 case Nkind (SCIL_Node) is 53 when N_SCIL_Dispatch_Table_Tag_Init => 54 pragma Assert (Nkind (N) = N_Object_Declaration); 55 null; 56 57 when N_SCIL_Dispatching_Call => 58 Ctrl_Tag := SCIL_Controlling_Tag (SCIL_Node); 59 60 -- Parent of SCIL dispatching call nodes MUST be a subprogram call 61 62 if Nkind (N) not in N_Subprogram_Call then 63 raise Program_Error; 64 65 -- In simple cases the controlling tag is the tag of the 66 -- controlling argument (i.e. Obj.Tag). 67 68 elsif Nkind (Ctrl_Tag) = N_Selected_Component then 69 Ctrl_Typ := Etype (Ctrl_Tag); 70 71 -- Interface types are unsupported 72 73 if Is_Interface (Ctrl_Typ) 74 or else (RTE_Available (RE_Interface_Tag) 75 and then Ctrl_Typ = RTE (RE_Interface_Tag)) 76 then 77 null; 78 79 else 80 pragma Assert (Ctrl_Typ = RTE (RE_Tag)); 81 null; 82 end if; 83 84 -- When the controlling tag of a dispatching call is an identifier 85 -- the SCIL_Controlling_Tag attribute references the corresponding 86 -- object or parameter declaration. Interface types are still 87 -- unsupported. 88 89 elsif Nkind_In (Ctrl_Tag, N_Object_Declaration, 90 N_Parameter_Specification) 91 then 92 Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag)); 93 94 -- Interface types are unsupported. 95 96 if Is_Interface (Ctrl_Typ) 97 or else (RTE_Available (RE_Interface_Tag) 98 and then Ctrl_Typ = RTE (RE_Interface_Tag)) 99 or else (Is_Access_Type (Ctrl_Typ) 100 and then 101 Is_Interface 102 (Available_View 103 (Base_Type (Designated_Type (Ctrl_Typ))))) 104 then 105 null; 106 107 else 108 pragma Assert 109 (Ctrl_Typ = RTE (RE_Tag) 110 or else 111 (Is_Access_Type (Ctrl_Typ) 112 and then Available_View 113 (Base_Type (Designated_Type (Ctrl_Typ))) 114 = RTE (RE_Tag))); 115 null; 116 end if; 117 118 -- Interface types are unsupported 119 120 elsif Is_Interface (Etype (Ctrl_Tag)) then 121 null; 122 123 else 124 pragma Assert (False); 125 raise Program_Error; 126 end if; 127 128 return Skip; 129 130 when N_SCIL_Membership_Test => 131 132 -- Check contents of the boolean expression associated with the 133 -- membership test. 134 135 pragma Assert (Nkind_In (N, N_Identifier, 136 N_And_Then, 137 N_Or_Else, 138 N_Expression_With_Actions) 139 and then Etype (N) = Standard_Boolean); 140 141 -- Check the entity identifier of the associated tagged type (that 142 -- is, in testing for membership in T'Class, the entity id of the 143 -- specific type T). 144 145 -- Note: When the SCIL node is generated the private and full-view 146 -- of the tagged types may have been swapped and hence the node 147 -- referenced by attribute SCIL_Entity may be the private view. 148 -- Therefore, in order to uniformly locate the full-view we use 149 -- attribute Underlying_Type. 150 151 pragma Assert 152 (Is_Tagged_Type (Underlying_Type (SCIL_Entity (SCIL_Node)))); 153 154 -- Interface types are unsupported 155 156 pragma Assert 157 (not Is_Interface (Underlying_Type (SCIL_Entity (SCIL_Node)))); 158 159 -- Check the decoration of the expression that denotes the tag 160 -- value being tested 161 162 Ctrl_Tag := SCIL_Tag_Value (SCIL_Node); 163 164 case Nkind (Ctrl_Tag) is 165 166 -- For class-wide membership tests the SCIL tag value is the 167 -- tag of the tested object (i.e. Obj.Tag). 168 169 when N_Selected_Component => 170 pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag)); 171 null; 172 173 when others => 174 pragma Assert (False); 175 null; 176 end case; 177 178 return Skip; 179 180 when others => 181 pragma Assert (False); 182 raise Program_Error; 183 end case; 184 185 return Skip; 186 end Check_SCIL_Node; 187 188 ------------------------- 189 -- First_Non_SCIL_Node -- 190 ------------------------- 191 192 function First_Non_SCIL_Node (L : List_Id) return Node_Id is 193 N : Node_Id; 194 195 begin 196 N := First (L); 197 while Nkind (N) in N_SCIL_Node loop 198 Next (N); 199 end loop; 200 201 return N; 202 end First_Non_SCIL_Node; 203 204 ------------------------ 205 -- Next_Non_SCIL_Node -- 206 ------------------------ 207 208 function Next_Non_SCIL_Node (N : Node_Id) return Node_Id is 209 Aux_N : Node_Id; 210 211 begin 212 Aux_N := Next (N); 213 while Nkind (Aux_N) in N_SCIL_Node loop 214 Next (Aux_N); 215 end loop; 216 217 return Aux_N; 218 end Next_Non_SCIL_Node; 219 220end Sem_SCIL; 221