1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S T Y L E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-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. 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 Atree; use Atree; 27with Casing; use Casing; 28with Csets; use Csets; 29with Einfo; use Einfo; 30with Errout; use Errout; 31with Namet; use Namet; 32with Nlists; use Nlists; 33with Opt; use Opt; 34with Sinfo; use Sinfo; 35with Sinput; use Sinput; 36with Stand; use Stand; 37with Stylesw; use Stylesw; 38 39package body Style is 40 41 ----------------------- 42 -- Body_With_No_Spec -- 43 ----------------------- 44 45 -- If the check specs mode (-gnatys) is set, then all subprograms must 46 -- have specs unless they are parameterless procedures at the library 47 -- level (i.e. they are possible main programs). 48 49 procedure Body_With_No_Spec (N : Node_Id) is 50 begin 51 if Style_Check_Specs then 52 if Nkind (Parent (N)) = N_Compilation_Unit then 53 declare 54 Spec : constant Node_Id := Specification (N); 55 Defnm : constant Node_Id := Defining_Unit_Name (Spec); 56 57 begin 58 if Nkind (Spec) = N_Procedure_Specification 59 and then Nkind (Defnm) = N_Defining_Identifier 60 and then No (First_Formal (Defnm)) 61 then 62 return; 63 end if; 64 end; 65 end if; 66 67 Error_Msg_N ("(style) subprogram body has no previous spec", N); 68 end if; 69 end Body_With_No_Spec; 70 71 --------------------------------- 72 -- Check_Array_Attribute_Index -- 73 --------------------------------- 74 75 procedure Check_Array_Attribute_Index 76 (N : Node_Id; 77 E1 : Node_Id; 78 D : Int) 79 is 80 begin 81 if Style_Check_Array_Attribute_Index then 82 if D = 1 and then Present (E1) then 83 Error_Msg_N -- CODEFIX 84 ("(style) index number not allowed for one dimensional array", 85 E1); 86 elsif D > 1 and then No (E1) then 87 Error_Msg_N -- CODEFIX 88 ("(style) index number required for multi-dimensional array", 89 N); 90 end if; 91 end if; 92 end Check_Array_Attribute_Index; 93 94 ---------------------- 95 -- Check_Identifier -- 96 ---------------------- 97 98 -- In check references mode (-gnatyr), identifier uses must be cased 99 -- the same way as the corresponding identifier declaration. If standard 100 -- references are checked (-gnatyn), then identifiers from Standard must 101 -- be cased as in the Reference Manual. 102 103 procedure Check_Identifier 104 (Ref : Node_Or_Entity_Id; 105 Def : Node_Or_Entity_Id) 106 is 107 Sref : Source_Ptr := Sloc (Ref); 108 Sdef : Source_Ptr := Sloc (Def); 109 Tref : Source_Buffer_Ptr; 110 Tdef : Source_Buffer_Ptr; 111 Nlen : Nat; 112 Cas : Casing_Type; 113 114 begin 115 -- If reference does not come from source, nothing to check 116 117 if not Comes_From_Source (Ref) then 118 return; 119 120 -- If previous error on either node/entity, ignore 121 122 elsif Error_Posted (Ref) or else Error_Posted (Def) then 123 return; 124 125 -- Case of definition comes from source 126 127 elsif Comes_From_Source (Def) then 128 129 -- Check same casing if we are checking references 130 131 if Style_Check_References then 132 Tref := Source_Text (Get_Source_File_Index (Sref)); 133 Tdef := Source_Text (Get_Source_File_Index (Sdef)); 134 135 -- Ignore operator name case completely. This also catches the 136 -- case of where one is an operator and the other is not. This 137 -- is a phenomenon from rewriting of operators as functions, 138 -- and is to be ignored. 139 140 if Tref (Sref) = '"' or else Tdef (Sdef) = '"' then 141 return; 142 143 else 144 while Tref (Sref) = Tdef (Sdef) loop 145 146 -- If end of identifier, all done 147 148 if not Identifier_Char (Tref (Sref)) then 149 return; 150 151 -- Otherwise loop continues 152 153 else 154 Sref := Sref + 1; 155 Sdef := Sdef + 1; 156 end if; 157 end loop; 158 159 -- Fall through loop when mismatch between identifiers 160 -- If either identifier is not terminated, error. 161 162 if Identifier_Char (Tref (Sref)) 163 or else 164 Identifier_Char (Tdef (Sdef)) 165 then 166 Error_Msg_Node_1 := Def; 167 Error_Msg_Sloc := Sloc (Def); 168 Error_Msg -- CODEFIX 169 ("(style) bad casing of & declared#", Sref); 170 return; 171 172 -- Else end of identifiers, and they match 173 174 else 175 return; 176 end if; 177 end if; 178 end if; 179 180 -- Case of definition in package Standard 181 182 elsif Sdef = Standard_Location 183 or else 184 Sdef = Standard_ASCII_Location 185 then 186 -- Check case of identifiers in Standard 187 188 if Style_Check_Standard then 189 Tref := Source_Text (Get_Source_File_Index (Sref)); 190 191 -- Ignore operators 192 193 if Tref (Sref) = '"' then 194 null; 195 196 -- Otherwise determine required casing of Standard entity 197 198 else 199 -- ASCII is all upper case 200 201 if Entity (Ref) = Standard_ASCII then 202 Cas := All_Upper_Case; 203 204 -- Special handling for names in package ASCII 205 206 elsif Sdef = Standard_ASCII_Location then 207 declare 208 Nam : constant String := Get_Name_String (Chars (Def)); 209 210 begin 211 -- Bar is mixed case 212 213 if Nam = "bar" then 214 Cas := Mixed_Case; 215 216 -- All names longer than 4 characters are mixed case 217 218 elsif Nam'Length > 4 then 219 Cas := Mixed_Case; 220 221 -- All names shorter than 4 characters (other than Bar, 222 -- which we already tested for specially) are Upper case. 223 224 else 225 Cas := All_Upper_Case; 226 end if; 227 end; 228 229 -- All other entities are in mixed case 230 231 else 232 Cas := Mixed_Case; 233 end if; 234 235 Nlen := Length_Of_Name (Chars (Ref)); 236 237 -- Now check if we have the right casing 238 239 if Determine_Casing 240 (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)) = Cas 241 then 242 null; 243 else 244 Name_Len := Integer (Nlen); 245 Name_Buffer (1 .. Name_Len) := 246 String (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)); 247 Set_Casing (Cas); 248 Error_Msg_Name_1 := Name_Enter; 249 Error_Msg_N -- CODEFIX 250 ("(style) bad casing of %% declared in Standard", Ref); 251 end if; 252 end if; 253 end if; 254 end if; 255 end Check_Identifier; 256 257 ------------------------ 258 -- Missing_Overriding -- 259 ------------------------ 260 261 procedure Missing_Overriding (N : Node_Id; E : Entity_Id) is 262 Nod : Node_Id; 263 264 begin 265 -- Perform the check on source subprograms and on subprogram instances, 266 -- because these can be primitives of untagged types. Note that such 267 -- indicators were introduced in Ada 2005. 268 269 if Style_Check_Missing_Overriding 270 and then (Comes_From_Source (N) or else Is_Generic_Instance (E)) 271 and then Ada_Version_Explicit >= Ada_2005 272 then 273 -- If the subprogram is an instantiation, its declaration appears 274 -- within a wrapper package that precedes the instance node. Place 275 -- warning on the node to avoid references to the original generic. 276 277 if Nkind (N) = N_Subprogram_Declaration 278 and then Is_Generic_Instance (E) 279 then 280 Nod := Next (Parent (Parent (List_Containing (N)))); 281 else 282 Nod := N; 283 end if; 284 285 if Nkind (N) = N_Subprogram_Body then 286 Error_Msg_NE -- CODEFIX 287 ("(style) missing OVERRIDING indicator in body of&", N, E); 288 else 289 Error_Msg_NE -- CODEFIX 290 ("(style) missing OVERRIDING indicator in declaration of&", 291 Nod, E); 292 end if; 293 end if; 294 end Missing_Overriding; 295 296 ----------------------------------- 297 -- Subprogram_Not_In_Alpha_Order -- 298 ----------------------------------- 299 300 procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is 301 begin 302 if Style_Check_Order_Subprograms then 303 Error_Msg_N -- CODEFIX 304 ("(style) subprogram body& not in alphabetical order", Name); 305 end if; 306 end Subprogram_Not_In_Alpha_Order; 307end Style; 308