Disable tests for strdup/strndup on __hpux__
[official-gcc.git] / gcc / ada / style.adb
blobe21730bb49d630945e89e93902a1b9657141b890
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S T Y L E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2023, 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 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Casing; use Casing;
28 with Csets; use Csets;
29 with Einfo; use Einfo;
30 with Einfo.Entities; use Einfo.Entities;
31 with Einfo.Utils; use Einfo.Utils;
32 with Errout; use Errout;
33 with Namet; use Namet;
34 with Nlists; use Nlists;
35 with Opt; use Opt;
36 with Sinfo; use Sinfo;
37 with Sinfo.Nodes; use Sinfo.Nodes;
38 with Sinput; use Sinput;
39 with Snames; use Snames;
40 with Stylesw; use Stylesw;
42 package body Style is
44 -----------------------
45 -- Body_With_No_Spec --
46 -----------------------
48 -- If the check specs mode (-gnatys) is set, then all subprograms must
49 -- have specs unless they are parameterless procedures at the library
50 -- level (i.e. they are possible main programs).
52 procedure Body_With_No_Spec (N : Node_Id) is
53 begin
54 if Style_Check_Specs then
55 if Nkind (Parent (N)) = N_Compilation_Unit then
56 declare
57 Spec : constant Node_Id := Specification (N);
58 Defnm : constant Node_Id := Defining_Unit_Name (Spec);
60 begin
61 if Nkind (Spec) = N_Procedure_Specification
62 and then Nkind (Defnm) = N_Defining_Identifier
63 and then No (First_Formal (Defnm))
64 then
65 return;
66 end if;
67 end;
68 end if;
70 Error_Msg_N ("(style) subprogram body has no previous spec?s?", N);
71 end if;
72 end Body_With_No_Spec;
74 ---------------------------------
75 -- Check_Array_Attribute_Index --
76 ---------------------------------
78 procedure Check_Array_Attribute_Index
79 (N : Node_Id;
80 E1 : Node_Id;
81 D : Int)
83 begin
84 if Style_Check_Array_Attribute_Index then
85 if D = 1 and then Present (E1) then
86 Error_Msg_N -- CODEFIX
87 ("(style) index number not allowed for one dimensional array?A?",
88 E1);
89 elsif D > 1 and then No (E1) then
90 Error_Msg_N -- CODEFIX
91 ("(style) index number required for multi-dimensional array?A?",
92 N);
93 end if;
94 end if;
95 end Check_Array_Attribute_Index;
97 ----------------------
98 -- Check_Identifier --
99 ----------------------
101 -- In check references mode (-gnatyr), identifier uses must be cased
102 -- the same way as the corresponding identifier declaration. If standard
103 -- references are checked (-gnatyn), then identifiers from Standard must
104 -- be cased as in the Reference Manual.
106 procedure Check_Identifier
107 (Ref : Node_Or_Entity_Id;
108 Def : Node_Or_Entity_Id)
110 Sref : Source_Ptr := Sloc (Ref);
111 Sdef : Source_Ptr := Sloc (Def);
112 Tref : Source_Buffer_Ptr;
113 Tdef : Source_Buffer_Ptr;
114 Nlen : Nat;
115 Cas : Casing_Type;
117 begin
118 -- If reference does not come from source, nothing to check
120 if not Comes_From_Source (Ref) then
121 return;
123 -- If previous error on either node/entity, ignore
125 elsif Error_Posted (Ref) or else Error_Posted (Def) then
126 return;
128 -- Case of definition comes from source, or a record component whose
129 -- Original_Record_Component comes from source.
131 elsif Comes_From_Source (Def) or else
132 (Ekind (Def) in Record_Field_Kind
133 and then Present (Original_Record_Component (Def))
134 and then Comes_From_Source (Original_Record_Component (Def)))
135 then
137 -- Check same casing if we are checking references
139 if Style_Check_References then
140 Tref := Source_Text (Get_Source_File_Index (Sref));
141 Tdef := Source_Text (Get_Source_File_Index (Sdef));
143 -- Ignore case of operator names. This also catches the case
144 -- where one is an operator and the other is not. This is a
145 -- phenomenon from rewriting of operators as functions, and is
146 -- to be ignored.
148 if Tref (Sref) = '"' or else Tdef (Sdef) = '"' then
149 return;
151 else
152 loop
153 -- If end of identifiers, all done. Note that they are the
154 -- same length.
156 pragma Assert
157 (Identifier_Char (Tref (Sref)) =
158 Identifier_Char (Tdef (Sdef)));
160 if not Identifier_Char (Tref (Sref)) then
161 return;
162 end if;
164 -- Case mismatch
166 if Tref (Sref) /= Tdef (Sdef) then
167 Error_Msg_Node_1 := Def;
168 Error_Msg_Sloc := Sloc (Def);
169 Error_Msg -- CODEFIX
170 ("(style) bad casing of & declared#?r?", Sref, Ref);
171 return;
172 end if;
174 Sref := Sref + 1;
175 Sdef := Sdef + 1;
176 end loop;
178 pragma Assert (False);
179 end if;
180 end if;
182 -- Case of definition in package Standard
184 elsif Sdef = Standard_Location
185 or else
186 Sdef = Standard_ASCII_Location
187 then
188 -- Check case of identifiers in Standard
190 if Style_Check_Standard then
191 Tref := Source_Text (Get_Source_File_Index (Sref));
193 -- Ignore operators
195 if Tref (Sref) = '"' then
196 null;
198 -- Otherwise determine required casing of Standard entity
200 else
201 -- ASCII is all upper case
203 if Chars (Ref) = Name_ASCII then
204 Cas := All_Upper_Case;
206 -- Special handling for names in package ASCII
208 elsif Sdef = Standard_ASCII_Location then
209 declare
210 Nam : constant String := Get_Name_String (Chars (Def));
212 begin
213 -- Bar is mixed case
215 if Nam = "bar" then
216 Cas := Mixed_Case;
218 -- All names longer than 4 characters are mixed case
220 elsif Nam'Length > 4 then
221 Cas := Mixed_Case;
223 -- All names shorter than 4 characters (other than Bar,
224 -- which we already tested for specially) are Upper case.
226 else
227 Cas := All_Upper_Case;
228 end if;
229 end;
231 -- All other entities are in mixed case
233 else
234 Cas := Mixed_Case;
235 end if;
237 Nlen := Length_Of_Name (Chars (Ref));
239 -- Now check if we have the right casing
241 if Determine_Casing
242 (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)) = Cas
243 then
244 null;
245 else
246 Name_Len := Integer (Nlen);
247 Name_Buffer (1 .. Name_Len) :=
248 String (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1));
249 Set_Casing (Cas);
250 Error_Msg_Name_1 := Name_Enter;
251 Error_Msg_N -- CODEFIX
252 ("(style) bad casing of %% declared in Standard?n?", Ref);
253 end if;
254 end if;
255 end if;
256 end if;
257 end Check_Identifier;
259 ------------------------
260 -- Missing_Overriding --
261 ------------------------
263 procedure Missing_Overriding (N : Node_Id; E : Entity_Id) is
264 Nod : Node_Id;
266 begin
267 -- Perform the check on source subprograms and on subprogram instances,
268 -- because these can be primitives of untagged types. Note that such
269 -- indicators were introduced in Ada 2005. We apply Comes_From_Source
270 -- to Original_Node to catch the case of a procedure body declared with
271 -- "is null" that has been rewritten as a normal empty body.
272 -- We do not emit a warning on an inherited operation that comes from
273 -- a type derivation.
275 if Style_Check_Missing_Overriding
276 and then (Comes_From_Source (Original_Node (N))
277 or else Is_Generic_Instance (E))
278 and then Ada_Version_Explicit >= Ada_2005
279 and then Present (Parent (E))
280 and then Nkind (Parent (E)) /= N_Full_Type_Declaration
281 then
282 -- If the subprogram is an instantiation, its declaration appears
283 -- within a wrapper package that precedes the instance node. Place
284 -- warning on the node to avoid references to the original generic.
286 if Nkind (N) = N_Subprogram_Declaration
287 and then Is_Generic_Instance (E)
288 then
289 Nod := Next (Parent (Parent (List_Containing (N))));
290 else
291 Nod := N;
292 end if;
294 if Nkind (N) = N_Subprogram_Body then
295 Error_Msg_NE -- CODEFIX
296 ("(style) missing OVERRIDING indicator in body of&?O?", N, E);
298 elsif Nkind (N) = N_Abstract_Subprogram_Declaration then
299 Error_Msg_NE -- CODEFIX
300 ("(style) missing OVERRIDING indicator in declaration of&?O?",
301 Specification (N), E);
303 else
304 Error_Msg_NE -- CODEFIX
305 ("(style) missing OVERRIDING indicator in declaration of&?O?",
306 Nod, E);
307 end if;
308 end if;
309 end Missing_Overriding;
311 -----------------------------------
312 -- Subprogram_Not_In_Alpha_Order --
313 -----------------------------------
315 procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is
316 begin
317 if Style_Check_Order_Subprograms then
318 Error_Msg_N -- CODEFIX
319 ("(style) subprogram body& not in alphabetical order?o?", Name);
320 end if;
321 end Subprogram_Not_In_Alpha_Order;
322 end Style;