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 Nlists;   use Nlists;
33with Opt;      use Opt;
34with Sinfo;    use Sinfo;
35with Sinput;   use Sinput;
36with Stand;    use Stand;
37with Stylesw;  use Stylesw;
38
39package 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
169                    ("(style) bad casing of & declared#", Sref);
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.
268
269      if Style_Check_Missing_Overriding
270        and then (Comes_From_Source (N) or else Is_Generic_Instance (E))
271        and then Ada_Version_Explicit >= Ada_2005
272      then
273         --  If the subprogram is an instantiation,  its declaration appears
274         --  within a wrapper package that precedes the instance node. Place
275         --  warning on the node to avoid references to the original generic.
276
277         if Nkind (N) = N_Subprogram_Declaration
278           and then Is_Generic_Instance (E)
279         then
280            Nod := Next (Parent (Parent (List_Containing (N))));
281         else
282            Nod := N;
283         end if;
284
285         if Nkind (N) = N_Subprogram_Body then
286            Error_Msg_NE -- CODEFIX
287              ("(style) missing OVERRIDING indicator in body of&", N, E);
288         else
289            Error_Msg_NE -- CODEFIX
290              ("(style) missing OVERRIDING indicator in declaration of&",
291               Nod, E);
292         end if;
293      end if;
294   end Missing_Overriding;
295
296   -----------------------------------
297   -- Subprogram_Not_In_Alpha_Order --
298   -----------------------------------
299
300   procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is
301   begin
302      if Style_Check_Order_Subprograms then
303         Error_Msg_N -- CODEFIX
304           ("(style) subprogram body& not in alphabetical order", Name);
305      end if;
306   end Subprogram_Not_In_Alpha_Order;
307end Style;
308