1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Casing; use Casing;
28 with Csets; use Csets;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Namet; use Namet;
32 with Sinfo; use Sinfo;
33 with Sinput; use Sinput;
34 with Stand; use Stand;
35 with Stylesw; use Stylesw;
39 -----------------------
40 -- Body_With_No_Spec --
41 -----------------------
43 -- If the check specs mode (-gnatys) is set, then all subprograms must
44 -- have specs unless they are parameterless procedures that are not child
45 -- units at the library level (i.e. they are possible main programs).
47 procedure Body_With_No_Spec (N : Node_Id) is
49 if Style_Check_Specs then
50 if Nkind (Parent (N)) = N_Compilation_Unit then
52 Spec : constant Node_Id := Specification (N);
53 Defnm : constant Node_Id := Defining_Unit_Name (Spec);
56 if Nkind (Spec) = N_Procedure_Specification
57 and then Nkind (Defnm) = N_Defining_Identifier
58 and then No (First_Formal (Defnm))
65 Error_Msg_N ("(style) subprogram body has no previous spec", N);
67 end Body_With_No_Spec;
69 ---------------------------------
70 -- Check_Array_Attribute_Index --
71 ---------------------------------
73 procedure Check_Array_Attribute_Index
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",
84 elsif D > 1 and then No (E1) then
85 Error_Msg_N -- CODEFIX
86 ("(style) index number required for multi-dimensional array",
90 end Check_Array_Attribute_Index;
92 ----------------------
93 -- Check_Identifier --
94 ----------------------
96 -- In check references mode (-gnatyr), identifier uses must be cased
97 -- the same way as the corresponding identifier declaration.
99 procedure Check_Identifier
100 (Ref : Node_Or_Entity_Id;
101 Def : Node_Or_Entity_Id)
103 Sref : Source_Ptr := Sloc (Ref);
104 Sdef : Source_Ptr := Sloc (Def);
105 Tref : Source_Buffer_Ptr;
106 Tdef : Source_Buffer_Ptr;
111 -- If reference does not come from source, nothing to check
113 if not Comes_From_Source (Ref) then
116 -- If previous error on either node/entity, ignore
118 elsif Error_Posted (Ref) or else Error_Posted (Def) then
121 -- Case of definition comes from source
123 elsif Comes_From_Source (Def) then
125 -- Check same casing if we are checking references
127 if Style_Check_References then
128 Tref := Source_Text (Get_Source_File_Index (Sref));
129 Tdef := Source_Text (Get_Source_File_Index (Sdef));
131 -- Ignore operator name case completely. This also catches the
132 -- case of where one is an operator and the other is not. This
133 -- is a phenomenon from rewriting of operators as functions,
134 -- and is to be ignored.
136 if Tref (Sref) = '"' or else Tdef (Sdef) = '"' then
140 while Tref (Sref) = Tdef (Sdef) loop
142 -- If end of identifier, all done
144 if not Identifier_Char (Tref (Sref)) then
147 -- Otherwise loop continues
155 -- Fall through loop when mismatch between identifiers
156 -- If either identifier is not terminated, error.
158 if Identifier_Char (Tref (Sref))
160 Identifier_Char (Tdef (Sdef))
162 Error_Msg_Node_1 := Def;
163 Error_Msg_Sloc := Sloc (Def);
165 ("(style) bad casing of & declared#", Sref);
168 -- Else end of identifiers, and they match
176 -- Case of definition in package Standard
178 elsif Sdef = Standard_Location
180 Sdef = Standard_ASCII_Location
182 -- Check case of identifiers in Standard
184 if Style_Check_Standard then
185 Tref := Source_Text (Get_Source_File_Index (Sref));
189 if Tref (Sref) = '"' then
192 -- Otherwise determine required casing of Standard entity
195 -- ASCII is all upper case
197 if Entity (Ref) = Standard_ASCII then
198 Cas := All_Upper_Case;
200 -- Special names in ASCII are also all upper case
202 elsif Sdef = Standard_ASCII_Location then
203 Cas := All_Upper_Case;
205 -- All other entities are in mixed case
211 Nlen := Length_Of_Name (Chars (Ref));
213 -- Now check if we have the right casing
216 (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)) = Cas
220 Name_Len := Integer (Nlen);
221 Name_Buffer (1 .. Name_Len) :=
222 String (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1));
224 Error_Msg_Name_1 := Name_Enter;
225 Error_Msg_N -- CODEFIX
226 ("(style) bad casing of %% declared in Standard", Ref);
231 end Check_Identifier;
233 ------------------------
234 -- Missing_Overriding --
235 ------------------------
237 procedure Missing_Overriding (N : Node_Id; E : Entity_Id) is
239 -- Note that Error_Msg_NE, which would be more natural to use here,
240 -- is not visible from this generic unit ???
242 Error_Msg_Name_1 := Chars (E);
244 if Style_Check_Missing_Overriding and then Comes_From_Source (N) then
245 if Nkind (N) = N_Subprogram_Body then
246 Error_Msg_N -- CODEFIX
247 ("(style) missing OVERRIDING indicator in body of%", N);
249 Error_Msg_N -- CODEFIX
250 ("(style) missing OVERRIDING indicator in declaration of%", N);
253 end Missing_Overriding;
255 -----------------------------------
256 -- Subprogram_Not_In_Alpha_Order --
257 -----------------------------------
259 procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is
261 if Style_Check_Order_Subprograms then
262 Error_Msg_N -- CODEFIX
263 ("(style) subprogram body& not in alphabetical order", Name);
265 end Subprogram_Not_In_Alpha_Order;