gcc/ada/style.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                S T Y L E                                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2017, 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
  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
 169                     ("(style) bad casing of & declared#", Sref, Ref);
 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;