gcc/ada/styleg-c.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                            S T Y L E G . C                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2007, 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 Err_Vars; use Err_Vars;
  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 Styleg.C 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 then
 179
 180          --  Check case of identifiers in Standard
 181
 182          if Style_Check_Standard then
 183             Tref := Source_Text (Get_Source_File_Index (Sref));
 184
 185             --  Ignore operators
 186
 187             if Tref (Sref) = '"' then
 188                null;
 189
 190             --  Otherwise determine required casing of Standard entity
 191
 192             else
 193                --  ASCII entities are in all upper case
 194
 195                if Entity (Ref) = Standard_ASCII then
 196                   Cas := All_Upper_Case;
 197
 198                --  Special names in ASCII are also all upper case
 199
 200                elsif Entity (Ref) in SE (S_LC_A) .. SE (S_LC_Z)
 201                        or else
 202                      Entity (Ref) in SE (S_NUL) .. SE (S_US)
 203                        or else
 204                      Entity (Ref) = SE (S_DEL)
 205                then
 206                   Cas := All_Upper_Case;
 207
 208                --  All other entities are in mixed case
 209
 210                else
 211                   Cas := Mixed_Case;
 212                end if;
 213
 214                Nlen := Length_Of_Name (Chars (Ref));
 215
 216                --  Now check if we have the right casing
 217
 218                if Determine_Casing
 219                     (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)) = Cas
 220                then
 221                   null;
 222                else
 223                   Name_Len := Integer (Nlen);
 224                   Name_Buffer (1 .. Name_Len) :=
 225                     String (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1));
 226                   Set_Casing (Cas);
 227                   Error_Msg_Name_1 := Name_Enter;
 228                   Error_Msg_N
 229                     ("(style) bad casing of %% declared in Standard", Ref);
 230                end if;
 231             end if;
 232          end if;
 233       end if;
 234    end Check_Identifier;
 235
 236    -----------------------------------
 237    -- Subprogram_Not_In_Alpha_Order --
 238    -----------------------------------
 239
 240    procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is
 241    begin
 242       if Style_Check_Order_Subprograms then
 243          Error_Msg_N
 244            ("(style) subprogram body& not in alphabetical order", Name);
 245       end if;
 246    end Subprogram_Not_In_Alpha_Order;
 247 end Styleg.C;