|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S T Y L E --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
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
|
|
|
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 Nlists; use Nlists;
|
|
|
33 with Opt; use Opt;
|
|
|
34 with Sinfo; use Sinfo;
|
|
|
35 with Sinput; use Sinput;
|
|
|
36 with Stand; use Stand;
|
|
|
37 with Stylesw; use Stylesw;
|
|
|
38
|
|
|
39 package 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
|
|
131
|
169 ("(style) bad casing of & declared#", Sref, Ref);
|
|
111
|
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. We apply Comes_From_Source
|
|
|
268 -- to Original_Node to catch the case of a procedure body declared with
|
|
|
269 -- "is null" that has been rewritten as a normal empty body.
|
|
|
270
|
|
|
271 if Style_Check_Missing_Overriding
|
|
|
272 and then (Comes_From_Source (Original_Node (N))
|
|
|
273 or else Is_Generic_Instance (E))
|
|
|
274 and then Ada_Version_Explicit >= Ada_2005
|
|
|
275 then
|
|
|
276 -- If the subprogram is an instantiation, its declaration appears
|
|
|
277 -- within a wrapper package that precedes the instance node. Place
|
|
|
278 -- warning on the node to avoid references to the original generic.
|
|
|
279
|
|
|
280 if Nkind (N) = N_Subprogram_Declaration
|
|
|
281 and then Is_Generic_Instance (E)
|
|
|
282 then
|
|
|
283 Nod := Next (Parent (Parent (List_Containing (N))));
|
|
|
284 else
|
|
|
285 Nod := N;
|
|
|
286 end if;
|
|
|
287
|
|
|
288 if Nkind (N) = N_Subprogram_Body then
|
|
|
289 Error_Msg_NE -- CODEFIX
|
|
|
290 ("(style) missing OVERRIDING indicator in body of&", N, E);
|
|
|
291
|
|
|
292 elsif Nkind (N) = N_Abstract_Subprogram_Declaration then
|
|
|
293 Error_Msg_NE -- CODEFIX
|
|
|
294 ("(style) missing OVERRIDING indicator in declaration of&",
|
|
|
295 Specification (N), E);
|
|
|
296
|
|
|
297 else
|
|
|
298 Error_Msg_NE -- CODEFIX
|
|
|
299 ("(style) missing OVERRIDING indicator in declaration of&",
|
|
|
300 Nod, E);
|
|
|
301 end if;
|
|
|
302 end if;
|
|
|
303 end Missing_Overriding;
|
|
|
304
|
|
|
305 -----------------------------------
|
|
|
306 -- Subprogram_Not_In_Alpha_Order --
|
|
|
307 -----------------------------------
|
|
|
308
|
|
|
309 procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is
|
|
|
310 begin
|
|
|
311 if Style_Check_Order_Subprograms then
|
|
|
312 Error_Msg_N -- CODEFIX
|
|
|
313 ("(style) subprogram body& not in alphabetical order", Name);
|
|
|
314 end if;
|
|
|
315 end Subprogram_Not_In_Alpha_Order;
|
|
|
316 end Style;
|
