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-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
  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 Sinfo;    use Sinfo;
  33 with Sinput;   use Sinput;
  34 with Stand;    use Stand;
  35 with Stylesw;  use Stylesw;
  36
  37 package body Style is
  38
  39    -----------------------
  40    -- Body_With_No_Spec --
  41    -----------------------
  42
  43    --  If the check specs mode (-gnatys) is set, then all subprograms must
  44    --  have specs unless they are parameterless procedures at the library
  45    --  level (i.e. they are possible main programs).
  46
  47    procedure Body_With_No_Spec (N : Node_Id) is
  48    begin
  49       if Style_Check_Specs then
  50          if Nkind (Parent (N)) = N_Compilation_Unit then
  51             declare
  52                Spec  : constant Node_Id := Specification (N);
  53                Defnm : constant Node_Id := Defining_Unit_Name (Spec);
  54
  55             begin
  56                if Nkind (Spec) = N_Procedure_Specification
  57                  and then Nkind (Defnm) = N_Defining_Identifier
  58                  and then No (First_Formal (Defnm))
  59                then
  60                   return;
  61                end if;
  62             end;
  63          end if;
  64
  65          Error_Msg_N ("(style) subprogram body has no previous spec", N);
  66       end if;
  67    end Body_With_No_Spec;
  68
  69    ---------------------------------
  70    -- Check_Array_Attribute_Index --
  71    ---------------------------------
  72
  73    procedure Check_Array_Attribute_Index
  74      (N  : Node_Id;
  75       E1 : Node_Id;
  76       D  : Int)
  77    is
  78    begin
  79       if Style_Check_Array_Attribute_Index then
  80          if D = 1 and then Present (E1) then
  81             Error_Msg_N -- CODEFIX
  82               ("(style) index number not allowed for one dimensional array",
  83                E1);
  84          elsif D > 1 and then No (E1) then
  85             Error_Msg_N -- CODEFIX
  86               ("(style) index number required for multi-dimensional array",
  87                N);
  88          end if;
  89       end if;
  90    end Check_Array_Attribute_Index;
  91
  92    ----------------------
  93    -- Check_Identifier --
  94    ----------------------
  95
  96    --  In check references mode (-gnatyr), identifier uses must be cased
  97    --  the same way as the corresponding identifier declaration. If standard
  98    --  references are checked (-gnatyn), then identifiers from Standard must
  99    --  be cased as in the Reference Manual.
 100
 101    procedure Check_Identifier
 102      (Ref : Node_Or_Entity_Id;
 103       Def : Node_Or_Entity_Id)
 104    is
 105       Sref : Source_Ptr := Sloc (Ref);
 106       Sdef : Source_Ptr := Sloc (Def);
 107       Tref : Source_Buffer_Ptr;
 108       Tdef : Source_Buffer_Ptr;
 109       Nlen : Nat;
 110       Cas  : Casing_Type;
 111
 112    begin
 113       --  If reference does not come from source, nothing to check
 114
 115       if not Comes_From_Source (Ref) then
 116          return;
 117
 118       --  If previous error on either node/entity, ignore
 119
 120       elsif Error_Posted (Ref) or else Error_Posted (Def) then
 121          return;
 122
 123       --  Case of definition comes from source
 124
 125       elsif Comes_From_Source (Def) then
 126
 127          --  Check same casing if we are checking references
 128
 129          if Style_Check_References then
 130             Tref := Source_Text (Get_Source_File_Index (Sref));
 131             Tdef := Source_Text (Get_Source_File_Index (Sdef));
 132
 133             --  Ignore operator name case completely. This also catches the
 134             --  case of where one is an operator and the other is not. This
 135             --  is a phenomenon from rewriting of operators as functions,
 136             --  and is to be ignored.
 137
 138             if Tref (Sref) = '"' or else Tdef (Sdef) = '"' then
 139                return;
 140
 141             else
 142                while Tref (Sref) = Tdef (Sdef) loop
 143
 144                   --  If end of identifier, all done
 145
 146                   if not Identifier_Char (Tref (Sref)) then
 147                      return;
 148
 149                   --  Otherwise loop continues
 150
 151                   else
 152                      Sref := Sref + 1;
 153                      Sdef := Sdef + 1;
 154                   end if;
 155                end loop;
 156
 157                --  Fall through loop when mismatch between identifiers
 158                --  If either identifier is not terminated, error.
 159
 160                if Identifier_Char (Tref (Sref))
 161                     or else
 162                   Identifier_Char (Tdef (Sdef))
 163                then
 164                   Error_Msg_Node_1 := Def;
 165                   Error_Msg_Sloc := Sloc (Def);
 166                   Error_Msg -- CODEFIX
 167                     ("(style) bad casing of & declared#", Sref);
 168                   return;
 169
 170                --  Else end of identifiers, and they match
 171
 172                else
 173                   return;
 174                end if;
 175             end if;
 176          end if;
 177
 178       --  Case of definition in package Standard
 179
 180       elsif Sdef = Standard_Location
 181               or else
 182             Sdef = Standard_ASCII_Location
 183       then
 184          --  Check case of identifiers in Standard
 185
 186          if Style_Check_Standard then
 187             Tref := Source_Text (Get_Source_File_Index (Sref));
 188
 189             --  Ignore operators
 190
 191             if Tref (Sref) = '"' then
 192                null;
 193
 194             --  Otherwise determine required casing of Standard entity
 195
 196             else
 197                --  ASCII is all upper case
 198
 199                if Entity (Ref) = Standard_ASCII then
 200                   Cas := All_Upper_Case;
 201
 202                --  Special handling for names in package ASCII
 203
 204                elsif Sdef = Standard_ASCII_Location then
 205                   declare
 206                      Nam : constant String := Get_Name_String (Chars (Def));
 207
 208                   begin
 209                      --  Bar is mixed case
 210
 211                      if Nam = "bar" then
 212                         Cas := Mixed_Case;
 213
 214                      --  All names longer than 4 characters are mixed case
 215
 216                      elsif Nam'Length > 4 then
 217                         Cas := Mixed_Case;
 218
 219                      --  All names shorter than 4 characters (other than Bar,
 220                      --  which we already tested for specially) are Upper case.
 221
 222                      else
 223                         Cas := All_Upper_Case;
 224                      end if;
 225                   end;
 226
 227                --  All other entities are in mixed case
 228
 229                else
 230                   Cas := Mixed_Case;
 231                end if;
 232
 233                Nlen := Length_Of_Name (Chars (Ref));
 234
 235                --  Now check if we have the right casing
 236
 237                if Determine_Casing
 238                     (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)) = Cas
 239                then
 240                   null;
 241                else
 242                   Name_Len := Integer (Nlen);
 243                   Name_Buffer (1 .. Name_Len) :=
 244                     String (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1));
 245                   Set_Casing (Cas);
 246                   Error_Msg_Name_1 := Name_Enter;
 247                   Error_Msg_N -- CODEFIX
 248                     ("(style) bad casing of %% declared in Standard", Ref);
 249                end if;
 250             end if;
 251          end if;
 252       end if;
 253    end Check_Identifier;
 254
 255    ------------------------
 256    -- Missing_Overriding --
 257    ------------------------
 258
 259    procedure Missing_Overriding (N : Node_Id; E : Entity_Id) is
 260    begin
 261
 262       --  Perform the check on source subprograms and on subprogram instances,
 263       --  because these can be primitives of untagged types.
 264
 265       if Style_Check_Missing_Overriding
 266         and then (Comes_From_Source (N) or else Is_Generic_Instance (E))
 267       then
 268          if Nkind (N) = N_Subprogram_Body then
 269             Error_Msg_NE -- CODEFIX
 270               ("(style) missing OVERRIDING indicator in body of&", N, E);
 271          else
 272             Error_Msg_NE -- CODEFIX
 273               ("(style) missing OVERRIDING indicator in declaration of&",
 274                N, E);
 275          end if;
 276       end if;
 277    end Missing_Overriding;
 278
 279    -----------------------------------
 280    -- Subprogram_Not_In_Alpha_Order --
 281    -----------------------------------
 282
 283    procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is
 284    begin
 285       if Style_Check_Order_Subprograms then
 286          Error_Msg_N -- CODEFIX
 287            ("(style) subprogram body& not in alphabetical order", Name);
 288       end if;
 289    end Subprogram_Not_In_Alpha_Order;
 290 end Style;