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-2024, 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_Boolean_Operator --
  99    ----------------------------
 100
 101    procedure Check_Boolean_Operator (Node : Node_Id) is
 102
 103       function OK_Boolean_Operand (N : Node_Id) return Boolean;
 104       --  Returns True for simple variable, or "not X1" or "X1 and X2" or
 105       --  "X1 or X2" where X1, X2 are recursively OK_Boolean_Operand's.
 106
 107       ------------------------
 108       -- OK_Boolean_Operand --
 109       ------------------------
 110
 111       function OK_Boolean_Operand (N : Node_Id) return Boolean is
 112       begin
 113          if Nkind (N) in N_Identifier | N_Expanded_Name then
 114             return True;
 115
 116          elsif Nkind (N) = N_Op_Not then
 117             return OK_Boolean_Operand (Original_Node (Right_Opnd (N)));
 118
 119          elsif Nkind (N) in N_Op_And | N_Op_Or then
 120             return OK_Boolean_Operand (Original_Node (Left_Opnd (N)))
 121                      and then
 122                    OK_Boolean_Operand (Original_Node (Right_Opnd (N)));
 123
 124          else
 125             return False;
 126          end if;
 127       end OK_Boolean_Operand;
 128
 129    --  Start of processing for Check_Boolean_Operator
 130
 131    begin
 132       if Style_Check_Boolean_And_Or
 133         and then Comes_From_Source (Node)
 134       then
 135          declare
 136             Orig : constant Node_Id := Original_Node (Node);
 137
 138          begin
 139             if Nkind (Orig) in N_Op_And | N_Op_Or then
 140                declare
 141                   L : constant Node_Id := Original_Node (Left_Opnd  (Orig));
 142                   R : constant Node_Id := Original_Node (Right_Opnd (Orig));
 143
 144                begin
 145                   --  First OK case, simple boolean constants/identifiers
 146
 147                   if OK_Boolean_Operand (L)
 148                        and then
 149                      OK_Boolean_Operand (R)
 150                   then
 151                      return;
 152
 153                   --  Second OK case, modular types
 154
 155                   elsif Is_Modular_Integer_Type (Etype (Node)) then
 156                      return;
 157
 158                   --  Third OK case, array types
 159
 160                   elsif Is_Array_Type (Etype (Node)) then
 161                      return;
 162
 163                   --  Otherwise we have an error
 164
 165                   elsif Nkind (Orig) = N_Op_And then
 166                      Error_Msg -- CODEFIX
 167                        ("(style) `AND THEN` required?B?", Sloc (Orig), Orig);
 168                   else
 169                      Error_Msg -- CODEFIX
 170                        ("(style) `OR ELSE` required?B?", Sloc (Orig), Orig);
 171                   end if;
 172                end;
 173             end if;
 174          end;
 175       end if;
 176    end Check_Boolean_Operator;
 177
 178    ----------------------
 179    -- Check_Identifier --
 180    ----------------------
 181
 182    --  In check references mode (-gnatyr), identifier uses must be cased
 183    --  the same way as the corresponding identifier declaration. If standard
 184    --  references are checked (-gnatyn), then identifiers from Standard must
 185    --  be cased as in the Reference Manual.
 186
 187    procedure Check_Identifier
 188      (Ref : Node_Or_Entity_Id;
 189       Def : Node_Or_Entity_Id)
 190    is
 191       Sref : Source_Ptr := Sloc (Ref);
 192       Sdef : Source_Ptr := Sloc (Def);
 193       Tref : Source_Buffer_Ptr;
 194       Tdef : Source_Buffer_Ptr;
 195       Nlen : Nat;
 196       Cas  : Casing_Type;
 197
 198    begin
 199       --  If reference does not come from source, nothing to check
 200
 201       if not Comes_From_Source (Ref) then
 202          return;
 203
 204       --  If previous error on either node/entity, ignore
 205
 206       elsif Error_Posted (Ref) or else Error_Posted (Def) then
 207          return;
 208
 209       --  Case of definition comes from source, or a record component whose
 210       --  Original_Record_Component comes from source.
 211
 212       elsif Comes_From_Source (Def) or else
 213         (Ekind (Def) in Record_Field_Kind
 214            and then Present (Original_Record_Component (Def))
 215            and then Comes_From_Source (Original_Record_Component (Def)))
 216       then
 217
 218          --  Check same casing if we are checking references
 219
 220          if Style_Check_References then
 221             Tref := Source_Text (Get_Source_File_Index (Sref));
 222             Tdef := Source_Text (Get_Source_File_Index (Sdef));
 223
 224             --  Ignore case of operator names. This also catches the case
 225             --  where one is an operator and the other is not. This is a
 226             --  phenomenon from rewriting of operators as functions, and is
 227             --  to be ignored.
 228
 229             if Tref (Sref) = '"' or else Tdef (Sdef) = '"' then
 230                return;
 231
 232             else
 233                loop
 234                   --  If end of identifiers, all done. Note that they are the
 235                   --  same length.
 236
 237                   pragma Assert
 238                     (Identifier_Char (Tref (Sref)) =
 239                      Identifier_Char (Tdef (Sdef)));
 240
 241                   if not Identifier_Char (Tref (Sref)) then
 242                      return;
 243                   end if;
 244
 245                   --  Case mismatch
 246
 247                   if Tref (Sref) /= Tdef (Sdef) then
 248                      Error_Msg_Node_1 := Def;
 249                      Error_Msg_Sloc := Sloc (Def);
 250                      Error_Msg -- CODEFIX
 251                        ("(style) bad casing of & declared#?r?", Sref, Ref);
 252                      return;
 253                   end if;
 254
 255                   Sref := Sref + 1;
 256                   Sdef := Sdef + 1;
 257                end loop;
 258
 259                pragma Assert (False);
 260             end if;
 261          end if;
 262
 263       --  Case of definition in package Standard
 264
 265       elsif Sdef = Standard_Location
 266               or else
 267             Sdef = Standard_ASCII_Location
 268       then
 269          --  Check case of identifiers in Standard
 270
 271          if Style_Check_Standard then
 272             Tref := Source_Text (Get_Source_File_Index (Sref));
 273
 274             --  Ignore operators
 275
 276             if Tref (Sref) = '"' then
 277                null;
 278
 279             --  Otherwise determine required casing of Standard entity
 280
 281             else
 282                --  ASCII is all upper case
 283
 284                if Chars (Ref) = Name_ASCII then
 285                   Cas := All_Upper_Case;
 286
 287                --  Special handling for names in package ASCII
 288
 289                elsif Sdef = Standard_ASCII_Location then
 290                   declare
 291                      Nam : constant String := Get_Name_String (Chars (Def));
 292
 293                   begin
 294                      --  Bar is mixed case
 295
 296                      if Nam = "bar" then
 297                         Cas := Mixed_Case;
 298
 299                      --  All names longer than 4 characters are mixed case
 300
 301                      elsif Nam'Length > 4 then
 302                         Cas := Mixed_Case;
 303
 304                      --  All names shorter than 4 characters (other than Bar,
 305                      --  which we already tested for specially) are Upper case.
 306
 307                      else
 308                         Cas := All_Upper_Case;
 309                      end if;
 310                   end;
 311
 312                --  All other entities are in mixed case
 313
 314                else
 315                   Cas := Mixed_Case;
 316                end if;
 317
 318                Nlen := Length_Of_Name (Chars (Ref));
 319
 320                --  Now check if we have the right casing
 321
 322                if Determine_Casing
 323                     (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)) = Cas
 324                then
 325                   null;
 326                else
 327                   Name_Len := Integer (Nlen);
 328                   Name_Buffer (1 .. Name_Len) :=
 329                     String (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1));
 330                   Set_Casing (Cas);
 331                   Error_Msg_Name_1 := Name_Enter;
 332                   Error_Msg_N -- CODEFIX
 333                     ("(style) bad casing of %% declared in Standard?n?", Ref);
 334                end if;
 335             end if;
 336          end if;
 337       end if;
 338    end Check_Identifier;
 339
 340    ----------------------------------
 341    -- Check_Xtra_Parens_Precedence --
 342    ----------------------------------
 343
 344    procedure Check_Xtra_Parens_Precedence (N : Node_Id) is
 345    begin
 346       if Style_Check_Xtra_Parens_Precedence
 347         and then
 348           Paren_Count (N) >
 349             (if Nkind (N) in N_Case_Expression
 350                            | N_Expression_With_Actions
 351                            | N_If_Expression
 352                            | N_Quantified_Expression
 353                            | N_Raise_Expression
 354              then 1
 355              else 0)
 356       then
 357          Error_Msg -- CODEFIX
 358            ("(style) redundant parentheses?z?", First_Sloc (N), N);
 359       end if;
 360    end Check_Xtra_Parens_Precedence;
 361
 362    ------------------------
 363    -- Missing_Overriding --
 364    ------------------------
 365
 366    procedure Missing_Overriding (N : Node_Id; E : Entity_Id) is
 367       Nod : Node_Id;
 368
 369    begin
 370       --  Perform the check on source subprograms and on subprogram instances,
 371       --  because these can be primitives of untagged types. Note that such
 372       --  indicators were introduced in Ada 2005. We apply Comes_From_Source
 373       --  to Original_Node to catch the case of a procedure body declared with
 374       --  "is null" that has been rewritten as a normal empty body.
 375       --  We do not emit a warning on an inherited operation that comes from
 376       --  a type derivation.
 377
 378       if Style_Check_Missing_Overriding
 379         and then (Comes_From_Source (Original_Node (N))
 380                    or else Is_Generic_Instance (E))
 381         and then Ada_Version_Explicit >= Ada_2005
 382         and then Present (Parent (E))
 383         and then Nkind (Parent (E)) /= N_Full_Type_Declaration
 384       then
 385          --  If the subprogram is an instantiation,  its declaration appears
 386          --  within a wrapper package that precedes the instance node. Place
 387          --  warning on the node to avoid references to the original generic.
 388
 389          if Nkind (N) = N_Subprogram_Declaration
 390            and then Is_Generic_Instance (E)
 391          then
 392             Nod := Next (Parent (Parent (List_Containing (N))));
 393          else
 394             Nod := N;
 395          end if;
 396
 397          if Nkind (N) = N_Subprogram_Body then
 398             Error_Msg_NE -- CODEFIX
 399               ("(style) missing OVERRIDING indicator in body of&?O?", N, E);
 400
 401          elsif Nkind (N) = N_Abstract_Subprogram_Declaration then
 402             Error_Msg_NE -- CODEFIX
 403               ("(style) missing OVERRIDING indicator in declaration of&?O?",
 404                 Specification (N), E);
 405
 406          else
 407             Error_Msg_NE -- CODEFIX
 408               ("(style) missing OVERRIDING indicator in declaration of&?O?",
 409                Nod, E);
 410          end if;
 411       end if;
 412    end Missing_Overriding;
 413
 414    -----------------------------------
 415    -- Subprogram_Not_In_Alpha_Order --
 416    -----------------------------------
 417
 418    procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is
 419    begin
 420       if Style_Check_Order_Subprograms then
 421          Error_Msg_N -- CODEFIX
 422            ("(style) subprogram body& not in alphabetical order?o?", Name);
 423       end if;
 424    end Subprogram_Not_In_Alpha_Order;
 425 end Style;