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-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 ------------------------------------------------------------------------------
  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 Sinput;         use Sinput;
  39 with Snames;         use Snames;
  40 with Stylesw;        use Stylesw;
  41
  42 package body Style is
  43
  44    -----------------------
  45    -- Body_With_No_Spec --
  46    -----------------------
  47
  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).
  51
  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);
  59
  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;
  69
  70          Error_Msg_N ("(style) subprogram body has no previous spec?s?", N);
  71       end if;
  72    end Body_With_No_Spec;
  73
  74    ---------------------------------
  75    -- Check_Array_Attribute_Index --
  76    ---------------------------------
  77
  78    procedure Check_Array_Attribute_Index
  79      (N  : Node_Id;
  80       E1 : Node_Id;
  81       D  : Int)
  82    is
  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;
  96
  97    ----------------------
  98    -- Check_Identifier --
  99    ----------------------
 100
 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.
 105
 106    procedure Check_Identifier
 107      (Ref : Node_Or_Entity_Id;
 108       Def : Node_Or_Entity_Id)
 109    is
 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;
 116
 117    begin
 118       --  If reference does not come from source, nothing to check
 119
 120       if not Comes_From_Source (Ref) then
 121          return;
 122
 123       --  If previous error on either node/entity, ignore
 124
 125       elsif Error_Posted (Ref) or else Error_Posted (Def) then
 126          return;
 127
 128       --  Case of definition comes from source, or a record component whose
 129       --  Original_Record_Component comes from source.
 130
 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
 136
 137          --  Check same casing if we are checking references
 138
 139          if Style_Check_References then
 140             Tref := Source_Text (Get_Source_File_Index (Sref));
 141             Tdef := Source_Text (Get_Source_File_Index (Sdef));
 142
 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.
 147
 148             if Tref (Sref) = '"' or else Tdef (Sdef) = '"' then
 149                return;
 150
 151             else
 152                loop
 153                   --  If end of identifiers, all done. Note that they are the
 154                   --  same length.
 155
 156                   pragma Assert
 157                     (Identifier_Char (Tref (Sref)) =
 158                      Identifier_Char (Tdef (Sdef)));
 159
 160                   if not Identifier_Char (Tref (Sref)) then
 161                      return;
 162                   end if;
 163
 164                   --  Case mismatch
 165
 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;
 173
 174                   Sref := Sref + 1;
 175                   Sdef := Sdef + 1;
 176                end loop;
 177
 178                pragma Assert (False);
 179             end if;
 180          end if;
 181
 182       --  Case of definition in package Standard
 183
 184       elsif Sdef = Standard_Location
 185               or else
 186             Sdef = Standard_ASCII_Location
 187       then
 188          --  Check case of identifiers in Standard
 189
 190          if Style_Check_Standard then
 191             Tref := Source_Text (Get_Source_File_Index (Sref));
 192
 193             --  Ignore operators
 194
 195             if Tref (Sref) = '"' then
 196                null;
 197
 198             --  Otherwise determine required casing of Standard entity
 199
 200             else
 201                --  ASCII is all upper case
 202
 203                if Chars (Ref) = Name_ASCII then
 204                   Cas := All_Upper_Case;
 205
 206                --  Special handling for names in package ASCII
 207
 208                elsif Sdef = Standard_ASCII_Location then
 209                   declare
 210                      Nam : constant String := Get_Name_String (Chars (Def));
 211
 212                   begin
 213                      --  Bar is mixed case
 214
 215                      if Nam = "bar" then
 216                         Cas := Mixed_Case;
 217
 218                      --  All names longer than 4 characters are mixed case
 219
 220                      elsif Nam'Length > 4 then
 221                         Cas := Mixed_Case;
 222
 223                      --  All names shorter than 4 characters (other than Bar,
 224                      --  which we already tested for specially) are Upper case.
 225
 226                      else
 227                         Cas := All_Upper_Case;
 228                      end if;
 229                   end;
 230
 231                --  All other entities are in mixed case
 232
 233                else
 234                   Cas := Mixed_Case;
 235                end if;
 236
 237                Nlen := Length_Of_Name (Chars (Ref));
 238
 239                --  Now check if we have the right casing
 240
 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;
 258
 259    ------------------------
 260    -- Missing_Overriding --
 261    ------------------------
 262
 263    procedure Missing_Overriding (N : Node_Id; E : Entity_Id) is
 264       Nod : Node_Id;
 265
 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.
 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         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.
 285
 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;
 293
 294          if Nkind (N) = N_Subprogram_Body then
 295             Error_Msg_NE -- CODEFIX
 296               ("(style) missing OVERRIDING indicator in body of&?O?", N, E);
 297
 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);
 302
 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;
 310
 311    -----------------------------------
 312    -- Subprogram_Not_In_Alpha_Order --
 313    -----------------------------------
 314
 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;