1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                                S T Y L E                                 --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2021, 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 Einfo.Entities; use Einfo.Entities;
31with Einfo.Utils;    use Einfo.Utils;
32with Errout;         use Errout;
33with Namet;          use Namet;
34with Nlists;         use Nlists;
35with Opt;            use Opt;
36with Sinfo;          use Sinfo;
37with Sinfo.Nodes;    use Sinfo.Nodes;
38with Sinfo.Utils;    use Sinfo.Utils;
39with Sinput;         use Sinput;
40with Stand;          use Stand;
41with Stylesw;        use Stylesw;
42
43package body Style is
44
45   -----------------------
46   -- Body_With_No_Spec --
47   -----------------------
48
49   --  If the check specs mode (-gnatys) is set, then all subprograms must
50   --  have specs unless they are parameterless procedures at the library
51   --  level (i.e. they are possible main programs).
52
53   procedure Body_With_No_Spec (N : Node_Id) is
54   begin
55      if Style_Check_Specs then
56         if Nkind (Parent (N)) = N_Compilation_Unit then
57            declare
58               Spec  : constant Node_Id := Specification (N);
59               Defnm : constant Node_Id := Defining_Unit_Name (Spec);
60
61            begin
62               if Nkind (Spec) = N_Procedure_Specification
63                 and then Nkind (Defnm) = N_Defining_Identifier
64                 and then No (First_Formal (Defnm))
65               then
66                  return;
67               end if;
68            end;
69         end if;
70
71         Error_Msg_N ("(style) subprogram body has no previous spec", N);
72      end if;
73   end Body_With_No_Spec;
74
75   ---------------------------------
76   -- Check_Array_Attribute_Index --
77   ---------------------------------
78
79   procedure Check_Array_Attribute_Index
80     (N  : Node_Id;
81      E1 : Node_Id;
82      D  : Int)
83   is
84   begin
85      if Style_Check_Array_Attribute_Index then
86         if D = 1 and then Present (E1) then
87            Error_Msg_N -- CODEFIX
88              ("(style) index number not allowed for one dimensional array",
89               E1);
90         elsif D > 1 and then No (E1) then
91            Error_Msg_N -- CODEFIX
92              ("(style) index number required for multi-dimensional array",
93               N);
94         end if;
95      end if;
96   end Check_Array_Attribute_Index;
97
98   ----------------------
99   -- Check_Identifier --
100   ----------------------
101
102   --  In check references mode (-gnatyr), identifier uses must be cased
103   --  the same way as the corresponding identifier declaration. If standard
104   --  references are checked (-gnatyn), then identifiers from Standard must
105   --  be cased as in the Reference Manual.
106
107   procedure Check_Identifier
108     (Ref : Node_Or_Entity_Id;
109      Def : Node_Or_Entity_Id)
110   is
111      Sref : Source_Ptr := Sloc (Ref);
112      Sdef : Source_Ptr := Sloc (Def);
113      Tref : Source_Buffer_Ptr;
114      Tdef : Source_Buffer_Ptr;
115      Nlen : Nat;
116      Cas  : Casing_Type;
117
118   begin
119      --  If reference does not come from source, nothing to check
120
121      if not Comes_From_Source (Ref) then
122         return;
123
124      --  If previous error on either node/entity, ignore
125
126      elsif Error_Posted (Ref) or else Error_Posted (Def) then
127         return;
128
129      --  Case of definition comes from source
130
131      elsif Comes_From_Source (Def) then
132
133         --  Check same casing if we are checking references
134
135         if Style_Check_References then
136            Tref := Source_Text (Get_Source_File_Index (Sref));
137            Tdef := Source_Text (Get_Source_File_Index (Sdef));
138
139            --  Ignore case of operator names. This also catches the case
140            --  where one is an operator and the other is not. This is a
141            --  phenomenon from rewriting of operators as functions, and is
142            --  to be ignored.
143
144            if Tref (Sref) = '"' or else Tdef (Sdef) = '"' then
145               return;
146
147            else
148               loop
149                  --  If end of identifiers, all done. Note that they are the
150                  --  same length.
151
152                  pragma Assert
153                    (Identifier_Char (Tref (Sref)) =
154                     Identifier_Char (Tdef (Sdef)));
155
156                  if not Identifier_Char (Tref (Sref)) then
157                     return;
158                  end if;
159
160                  --  Case mismatch
161
162                  if Tref (Sref) /= Tdef (Sdef) then
163                     Error_Msg_Node_1 := Def;
164                     Error_Msg_Sloc := Sloc (Def);
165                     Error_Msg -- CODEFIX
166                       ("(style) bad casing of & declared#", Sref, Ref);
167                     return;
168                  end if;
169
170                  Sref := Sref + 1;
171                  Sdef := Sdef + 1;
172               end loop;
173
174               pragma Assert (False);
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      Nod : Node_Id;
261
262   begin
263      --  Perform the check on source subprograms and on subprogram instances,
264      --  because these can be primitives of untagged types. Note that such
265      --  indicators were introduced in Ada 2005. We apply Comes_From_Source
266      --  to Original_Node to catch the case of a procedure body declared with
267      --  "is null" that has been rewritten as a normal empty body.
268      --  We do not emit a warning on an inherited operation that comes from
269      --  a type derivation.
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        and then Present (Parent (E))
276        and then Nkind (Parent (E)) /= N_Full_Type_Declaration
277      then
278         --  If the subprogram is an instantiation,  its declaration appears
279         --  within a wrapper package that precedes the instance node. Place
280         --  warning on the node to avoid references to the original generic.
281
282         if Nkind (N) = N_Subprogram_Declaration
283           and then Is_Generic_Instance (E)
284         then
285            Nod := Next (Parent (Parent (List_Containing (N))));
286         else
287            Nod := N;
288         end if;
289
290         if Nkind (N) = N_Subprogram_Body then
291            Error_Msg_NE -- CODEFIX
292              ("(style) missing OVERRIDING indicator in body of&", N, E);
293
294         elsif Nkind (N) = N_Abstract_Subprogram_Declaration then
295            Error_Msg_NE -- CODEFIX
296              ("(style) missing OVERRIDING indicator in declaration of&",
297                Specification (N), E);
298
299         else
300            Error_Msg_NE -- CODEFIX
301              ("(style) missing OVERRIDING indicator in declaration of&",
302               Nod, E);
303         end if;
304      end if;
305   end Missing_Overriding;
306
307   -----------------------------------
308   -- Subprogram_Not_In_Alpha_Order --
309   -----------------------------------
310
311   procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is
312   begin
313      if Style_Check_Order_Subprograms then
314         Error_Msg_N -- CODEFIX
315           ("(style) subprogram body& not in alphabetical order", Name);
316      end if;
317   end Subprogram_Not_In_Alpha_Order;
318end Style;
319