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-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
  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 Sinfo.Utils;    use Sinfo.Utils;
  39 with Sinput;         use Sinput;
  40 with Stand;          use Stand;
  41 with Stylesw;        use Stylesw;
  42
  43 package 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 operator name case completely. This also catches the
 140             --  case of where one is an operator and the other is not. This
 141             --  is a phenomenon from rewriting of operators as functions,
 142             --  and is to be ignored.
 143
 144             if Tref (Sref) = '"' or else Tdef (Sdef) = '"' then
 145                return;
 146
 147             else
 148                while Tref (Sref) = Tdef (Sdef) loop
 149
 150                   --  If end of identifier, all done
 151
 152                   if not Identifier_Char (Tref (Sref)) then
 153                      return;
 154
 155                   --  Otherwise loop continues
 156
 157                   else
 158                      Sref := Sref + 1;
 159                      Sdef := Sdef + 1;
 160                   end if;
 161                end loop;
 162
 163                --  Fall through loop when mismatch between identifiers
 164                --  If either identifier is not terminated, error.
 165
 166                if Identifier_Char (Tref (Sref))
 167                     or else
 168                   Identifier_Char (Tdef (Sdef))
 169                then
 170                   Error_Msg_Node_1 := Def;
 171                   Error_Msg_Sloc := Sloc (Def);
 172                   Error_Msg -- CODEFIX
 173                     ("(style) bad casing of & declared#", Sref, Ref);
 174                   return;
 175
 176                --  Else end of identifiers, and they match
 177
 178                else
 179                   return;
 180                end if;
 181             end if;
 182          end if;
 183
 184       --  Case of definition in package Standard
 185
 186       elsif Sdef = Standard_Location
 187               or else
 188             Sdef = Standard_ASCII_Location
 189       then
 190          --  Check case of identifiers in Standard
 191
 192          if Style_Check_Standard then
 193             Tref := Source_Text (Get_Source_File_Index (Sref));
 194
 195             --  Ignore operators
 196
 197             if Tref (Sref) = '"' then
 198                null;
 199
 200             --  Otherwise determine required casing of Standard entity
 201
 202             else
 203                --  ASCII is all upper case
 204
 205                if Entity (Ref) = Standard_ASCII then
 206                   Cas := All_Upper_Case;
 207
 208                --  Special handling for names in package ASCII
 209
 210                elsif Sdef = Standard_ASCII_Location then
 211                   declare
 212                      Nam : constant String := Get_Name_String (Chars (Def));
 213
 214                   begin
 215                      --  Bar is mixed case
 216
 217                      if Nam = "bar" then
 218                         Cas := Mixed_Case;
 219
 220                      --  All names longer than 4 characters are mixed case
 221
 222                      elsif Nam'Length > 4 then
 223                         Cas := Mixed_Case;
 224
 225                      --  All names shorter than 4 characters (other than Bar,
 226                      --  which we already tested for specially) are Upper case.
 227
 228                      else
 229                         Cas := All_Upper_Case;
 230                      end if;
 231                   end;
 232
 233                --  All other entities are in mixed case
 234
 235                else
 236                   Cas := Mixed_Case;
 237                end if;
 238
 239                Nlen := Length_Of_Name (Chars (Ref));
 240
 241                --  Now check if we have the right casing
 242
 243                if Determine_Casing
 244                     (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)) = Cas
 245                then
 246                   null;
 247                else
 248                   Name_Len := Integer (Nlen);
 249                   Name_Buffer (1 .. Name_Len) :=
 250                     String (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1));
 251                   Set_Casing (Cas);
 252                   Error_Msg_Name_1 := Name_Enter;
 253                   Error_Msg_N -- CODEFIX
 254                     ("(style) bad casing of %% declared in Standard", Ref);
 255                end if;
 256             end if;
 257          end if;
 258       end if;
 259    end Check_Identifier;
 260
 261    ------------------------
 262    -- Missing_Overriding --
 263    ------------------------
 264
 265    procedure Missing_Overriding (N : Node_Id; E : Entity_Id) is
 266       Nod : Node_Id;
 267
 268    begin
 269       --  Perform the check on source subprograms and on subprogram instances,
 270       --  because these can be primitives of untagged types. Note that such
 271       --  indicators were introduced in Ada 2005. We apply Comes_From_Source
 272       --  to Original_Node to catch the case of a procedure body declared with
 273       --  "is null" that has been rewritten as a normal empty body.
 274
 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       then
 280          --  If the subprogram is an instantiation,  its declaration appears
 281          --  within a wrapper package that precedes the instance node. Place
 282          --  warning on the node to avoid references to the original generic.
 283
 284          if Nkind (N) = N_Subprogram_Declaration
 285            and then Is_Generic_Instance (E)
 286          then
 287             Nod := Next (Parent (Parent (List_Containing (N))));
 288          else
 289             Nod := N;
 290          end if;
 291
 292          if Nkind (N) = N_Subprogram_Body then
 293             Error_Msg_NE -- CODEFIX
 294               ("(style) missing OVERRIDING indicator in body of&", N, E);
 295
 296          elsif Nkind (N) = N_Abstract_Subprogram_Declaration then
 297             Error_Msg_NE -- CODEFIX
 298               ("(style) missing OVERRIDING indicator in declaration of&",
 299                 Specification (N), E);
 300
 301          else
 302             Error_Msg_NE -- CODEFIX
 303               ("(style) missing OVERRIDING indicator in declaration of&",
 304                Nod, E);
 305          end if;
 306       end if;
 307    end Missing_Overriding;
 308
 309    -----------------------------------
 310    -- Subprogram_Not_In_Alpha_Order --
 311    -----------------------------------
 312
 313    procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is
 314    begin
 315       if Style_Check_Order_Subprograms then
 316          Error_Msg_N -- CODEFIX
 317            ("(style) subprogram body& not in alphabetical order", Name);
 318       end if;
 319    end Subprogram_Not_In_Alpha_Order;
 320 end Style;