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-2008, 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 that are not child
  45    --  units at the library 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
  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
  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.
  98
  99    procedure Check_Identifier
 100      (Ref : Node_Or_Entity_Id;
 101       Def : Node_Or_Entity_Id)
 102    is
 103       Sref : Source_Ptr := Sloc (Ref);
 104       Sdef : Source_Ptr := Sloc (Def);
 105       Tref : Source_Buffer_Ptr;
 106       Tdef : Source_Buffer_Ptr;
 107       Nlen : Nat;
 108       Cas  : Casing_Type;
 109
 110    begin
 111       --  If reference does not come from source, nothing to check
 112
 113       if not Comes_From_Source (Ref) then
 114          return;
 115
 116       --  If previous error on either node/entity, ignore
 117
 118       elsif Error_Posted (Ref) or else Error_Posted (Def) then
 119          return;
 120
 121       --  Case of definition comes from source
 122
 123       elsif Comes_From_Source (Def) then
 124
 125          --  Check same casing if we are checking references
 126
 127          if Style_Check_References then
 128             Tref := Source_Text (Get_Source_File_Index (Sref));
 129             Tdef := Source_Text (Get_Source_File_Index (Sdef));
 130
 131             --  Ignore operator name case completely. This also catches the
 132             --  case of where one is an operator and the other is not. This
 133             --  is a phenomenon from rewriting of operators as functions,
 134             --  and is to be ignored.
 135
 136             if Tref (Sref) = '"' or else Tdef (Sdef) = '"' then
 137                return;
 138
 139             else
 140                while Tref (Sref) = Tdef (Sdef) loop
 141
 142                   --  If end of identifier, all done
 143
 144                   if not Identifier_Char (Tref (Sref)) then
 145                      return;
 146
 147                   --  Otherwise loop continues
 148
 149                   else
 150                      Sref := Sref + 1;
 151                      Sdef := Sdef + 1;
 152                   end if;
 153                end loop;
 154
 155                --  Fall through loop when mismatch between identifiers
 156                --  If either identifier is not terminated, error.
 157
 158                if Identifier_Char (Tref (Sref))
 159                     or else
 160                   Identifier_Char (Tdef (Sdef))
 161                then
 162                   Error_Msg_Node_1 := Def;
 163                   Error_Msg_Sloc := Sloc (Def);
 164                   Error_Msg
 165                     ("(style) bad casing of & declared#", Sref);
 166                   return;
 167
 168                --  Else end of identifiers, and they match
 169
 170                else
 171                   return;
 172                end if;
 173             end if;
 174          end if;
 175
 176       --  Case of definition in package Standard
 177
 178       elsif Sdef = Standard_Location
 179               or else
 180             Sdef = Standard_ASCII_Location
 181       then
 182          --  Check case of identifiers in Standard
 183
 184          if Style_Check_Standard then
 185             Tref := Source_Text (Get_Source_File_Index (Sref));
 186
 187             --  Ignore operators
 188
 189             if Tref (Sref) = '"' then
 190                null;
 191
 192             --  Otherwise determine required casing of Standard entity
 193
 194             else
 195                --  ASCII is all upper case
 196
 197                if Entity (Ref) = Standard_ASCII then
 198                   Cas := All_Upper_Case;
 199
 200                --  Special names in ASCII are also all upper case
 201
 202                elsif Sdef = Standard_ASCII_Location then
 203                   Cas := All_Upper_Case;
 204
 205                --  All other entities are in mixed case
 206
 207                else
 208                   Cas := Mixed_Case;
 209                end if;
 210
 211                Nlen := Length_Of_Name (Chars (Ref));
 212
 213                --  Now check if we have the right casing
 214
 215                if Determine_Casing
 216                     (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)) = Cas
 217                then
 218                   null;
 219                else
 220                   Name_Len := Integer (Nlen);
 221                   Name_Buffer (1 .. Name_Len) :=
 222                     String (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1));
 223                   Set_Casing (Cas);
 224                   Error_Msg_Name_1 := Name_Enter;
 225                   Error_Msg_N
 226                     ("(style) bad casing of %% declared in Standard", Ref);
 227                end if;
 228             end if;
 229          end if;
 230       end if;
 231    end Check_Identifier;
 232
 233    ------------------------
 234    -- Missing_Overriding --
 235    ------------------------
 236
 237    procedure Missing_Overriding (N : Node_Id; E : Entity_Id) is
 238    begin
 239       --  Note that Error_Msg_NE, which would be more natural to use here,
 240       --  is not visible from this generic unit ???
 241
 242       Error_Msg_Name_1 := Chars (E);
 243
 244       if Style_Check_Missing_Overriding and then Comes_From_Source (N) then
 245          if Nkind (N) = N_Subprogram_Body then
 246             Error_Msg_N
 247               ("(style) missing OVERRIDING indicator in body of%", N);
 248          else
 249             Error_Msg_N
 250               ("(style) missing OVERRIDING indicator in declaration of%", N);
 251          end if;
 252       end if;
 253    end Missing_Overriding;
 254
 255    -----------------------------------
 256    -- Subprogram_Not_In_Alpha_Order --
 257    -----------------------------------
 258
 259    procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is
 260    begin
 261       if Style_Check_Order_Subprograms then
 262          Error_Msg_N
 263            ("(style) subprogram body& not in alphabetical order", Name);
 264       end if;
 265    end Subprogram_Not_In_Alpha_Order;
 266 end Style;