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