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-2003 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Casing;   use Casing;
  29 with Csets;    use Csets;
  30 with Einfo;    use Einfo;
  31 with Err_Vars; use Err_Vars;
  32 with Namet;    use Namet;
  33 with Sinfo;    use Sinfo;
  34 with Sinput;   use Sinput;
  35 with Stand;    use Stand;
  36 with Stylesw;  use Stylesw;
  37
  38 package body Styleg.C is
  39
  40    -----------------------
  41    -- Body_With_No_Spec --
  42    -----------------------
  43
  44    --  If the check specs mode (-gnatys) is set, then all subprograms must
  45    --  have specs unless they are parameterless procedures that are not child
  46    --  units at the library level (i.e. they are possible main programs).
  47
  48    procedure Body_With_No_Spec (N : Node_Id) is
  49    begin
  50       if Style_Check_Specs then
  51          if Nkind (Parent (N)) = N_Compilation_Unit then
  52             declare
  53                Spec  : constant Node_Id := Specification (N);
  54                Defnm : constant Node_Id := Defining_Unit_Name (Spec);
  55
  56             begin
  57                if Nkind (Spec) = N_Procedure_Specification
  58                  and then Nkind (Defnm) = N_Defining_Identifier
  59                  and then No (First_Formal (Defnm))
  60                then
  61                   return;
  62                end if;
  63             end;
  64          end if;
  65
  66          Error_Msg_N ("(style): subprogram body has no previous spec", N);
  67       end if;
  68    end Body_With_No_Spec;
  69
  70    ----------------------
  71    -- Check_Identifier --
  72    ----------------------
  73
  74    --  In check references mode (-gnatyr), identifier uses must be cased
  75    --  the same way as the corresponding identifier declaration.
  76
  77    procedure Check_Identifier
  78      (Ref : Node_Or_Entity_Id;
  79       Def : Node_Or_Entity_Id)
  80    is
  81       Sref : Source_Ptr := Sloc (Ref);
  82       Sdef : Source_Ptr := Sloc (Def);
  83       Tref : Source_Buffer_Ptr;
  84       Tdef : Source_Buffer_Ptr;
  85       Nlen : Nat;
  86       Cas  : Casing_Type;
  87
  88    begin
  89       --  If reference does not come from source, nothing to check
  90
  91       if not Comes_From_Source (Ref) then
  92          return;
  93
  94       --  If previous error on either node/entity, ignore
  95
  96       elsif Error_Posted (Ref) or else Error_Posted (Def) then
  97          return;
  98
  99       --  Case of definition comes from source
 100
 101       elsif Comes_From_Source (Def) then
 102
 103          --  Check same casing if we are checking references
 104
 105          if Style_Check_References then
 106             Tref := Source_Text (Get_Source_File_Index (Sref));
 107             Tdef := Source_Text (Get_Source_File_Index (Sdef));
 108
 109             --  Ignore operator name case completely. This also catches the
 110             --  case of where one is an operator and the other is not. This
 111             --  is a phenomenon from rewriting of operators as functions,
 112             --  and is to be ignored.
 113
 114             if Tref (Sref) = '"' or else Tdef (Sdef) = '"' then
 115                return;
 116
 117             else
 118                while Tref (Sref) = Tdef (Sdef) loop
 119
 120                   --  If end of identifier, all done
 121
 122                   if not Identifier_Char (Tref (Sref)) then
 123                      return;
 124
 125                   --  Otherwise loop continues
 126
 127                   else
 128                      Sref := Sref + 1;
 129                      Sdef := Sdef + 1;
 130                   end if;
 131                end loop;
 132
 133                --  Fall through loop when mismatch between identifiers
 134                --  If either identifier is not terminated, error.
 135
 136                if Identifier_Char (Tref (Sref))
 137                     or else
 138                   Identifier_Char (Tdef (Sdef))
 139                then
 140                   Error_Msg_Node_1 := Def;
 141                   Error_Msg_Sloc := Sloc (Def);
 142                   Error_Msg
 143                     ("(style) bad casing of & declared#", Sref);
 144                   return;
 145
 146                --  Else end of identifiers, and they match
 147
 148                else
 149                   return;
 150                end if;
 151             end if;
 152          end if;
 153
 154       --  Case of definition in package Standard
 155
 156       elsif Sdef = Standard_Location then
 157
 158          --  Check case of identifiers in Standard
 159
 160          if Style_Check_Standard then
 161             Tref := Source_Text (Get_Source_File_Index (Sref));
 162
 163             --  Ignore operators
 164
 165             if Tref (Sref) = '"' then
 166                null;
 167
 168             --  Otherwise determine required casing of Standard entity
 169
 170             else
 171                --  ASCII entities are in all upper case
 172
 173                if Entity (Ref) = Standard_ASCII then
 174                   Cas := All_Upper_Case;
 175
 176                --  Special names in ASCII are also all upper case
 177
 178                elsif Entity (Ref) in SE (S_LC_A) .. SE (S_LC_Z)
 179                        or else
 180                      Entity (Ref) in SE (S_NUL) .. SE (S_US)
 181                        or else
 182                      Entity (Ref) = SE (S_DEL)
 183                then
 184                   Cas := All_Upper_Case;
 185
 186                --  All other entities are in mixed case
 187
 188                else
 189                   Cas := Mixed_Case;
 190                end if;
 191
 192                Nlen  := Length_Of_Name (Chars (Ref));
 193
 194                --  Now check if we have the right casing
 195
 196                if Determine_Casing
 197                     (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)) = Cas
 198                then
 199                   null;
 200                else
 201                   Name_Len := Integer (Nlen);
 202                   Name_Buffer (1 .. Name_Len) :=
 203                     String (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1));
 204                   Set_Casing (Cas);
 205                   Error_Msg_Name_1 := Name_Enter;
 206                   Error_Msg_N
 207                     ("(style) bad casing of { declared in Standard", Ref);
 208                end if;
 209             end if;
 210          end if;
 211       end if;
 212    end Check_Identifier;
 213
 214    -----------------------------------
 215    -- Subprogram_Not_In_Alpha_Order --
 216    -----------------------------------
 217
 218    procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is
 219    begin
 220       if Style_Check_Subprogram_Order then
 221          Error_Msg_N
 222            ("(style) subprogram body& not in alphabetical order", Name);
 223       end if;
 224    end Subprogram_Not_In_Alpha_Order;
 225 end Styleg.C;