------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                                S T Y L E                                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Atree;    use Atree;
with Casing;   use Casing;
with Csets;    use Csets;
with Einfo;    use Einfo;
with Errout;   use Errout;
with Namet;    use Namet;
with Sinfo;    use Sinfo;
with Sinput;   use Sinput;
with Stand;    use Stand;
with Stylesw;  use Stylesw;

package body Style is

   -----------------------
   -- Body_With_No_Spec --
   -----------------------

   --  If the check specs mode (-gnatys) is set, then all subprograms must
   --  have specs unless they are parameterless procedures that are not child
   --  units at the library level (i.e. they are possible main programs).

   procedure Body_With_No_Spec (N : Node_Id) is
   begin
      if Style_Check_Specs then
         if Nkind (Parent (N)) = N_Compilation_Unit then
            declare
               Spec  : constant Node_Id := Specification (N);
               Defnm : constant Node_Id := Defining_Unit_Name (Spec);

            begin
               if Nkind (Spec) = N_Procedure_Specification
                 and then Nkind (Defnm) = N_Defining_Identifier
                 and then No (First_Formal (Defnm))
               then
                  return;
               end if;
            end;
         end if;

         Error_Msg_N ("(style) subprogram body has no previous spec", N);
      end if;
   end Body_With_No_Spec;

   ---------------------------------
   -- Check_Array_Attribute_Index --
   ---------------------------------

   procedure Check_Array_Attribute_Index
     (N  : Node_Id;
      E1 : Node_Id;
      D  : Int)
   is
   begin
      if Style_Check_Array_Attribute_Index then
         if D = 1 and then Present (E1) then
            Error_Msg_N -- CODEFIX
              ("(style) index number not allowed for one dimensional array",
               E1);
         elsif D > 1 and then No (E1) then
            Error_Msg_N -- CODEFIX
              ("(style) index number required for multi-dimensional array",
               N);
         end if;
      end if;
   end Check_Array_Attribute_Index;

   ----------------------
   -- Check_Identifier --
   ----------------------

   --  In check references mode (-gnatyr), identifier uses must be cased
   --  the same way as the corresponding identifier declaration.

   procedure Check_Identifier
     (Ref : Node_Or_Entity_Id;
      Def : Node_Or_Entity_Id)
   is
      Sref : Source_Ptr := Sloc (Ref);
      Sdef : Source_Ptr := Sloc (Def);
      Tref : Source_Buffer_Ptr;
      Tdef : Source_Buffer_Ptr;
      Nlen : Nat;
      Cas  : Casing_Type;

   begin
      --  If reference does not come from source, nothing to check

      if not Comes_From_Source (Ref) then
         return;

      --  If previous error on either node/entity, ignore

      elsif Error_Posted (Ref) or else Error_Posted (Def) then
         return;

      --  Case of definition comes from source

      elsif Comes_From_Source (Def) then

         --  Check same casing if we are checking references

         if Style_Check_References then
            Tref := Source_Text (Get_Source_File_Index (Sref));
            Tdef := Source_Text (Get_Source_File_Index (Sdef));

            --  Ignore operator name case completely. This also catches the
            --  case of where one is an operator and the other is not. This
            --  is a phenomenon from rewriting of operators as functions,
            --  and is to be ignored.

            if Tref (Sref) = '"' or else Tdef (Sdef) = '"' then
               return;

            else
               while Tref (Sref) = Tdef (Sdef) loop

                  --  If end of identifier, all done

                  if not Identifier_Char (Tref (Sref)) then
                     return;

                  --  Otherwise loop continues

                  else
                     Sref := Sref + 1;
                     Sdef := Sdef + 1;
                  end if;
               end loop;

               --  Fall through loop when mismatch between identifiers
               --  If either identifier is not terminated, error.

               if Identifier_Char (Tref (Sref))
                    or else
                  Identifier_Char (Tdef (Sdef))
               then
                  Error_Msg_Node_1 := Def;
                  Error_Msg_Sloc := Sloc (Def);
                  Error_Msg -- CODEFIX
                    ("(style) bad casing of & declared#", Sref);
                  return;

               --  Else end of identifiers, and they match

               else
                  return;
               end if;
            end if;
         end if;

      --  Case of definition in package Standard

      elsif Sdef = Standard_Location
              or else
            Sdef = Standard_ASCII_Location
      then
         --  Check case of identifiers in Standard

         if Style_Check_Standard then
            Tref := Source_Text (Get_Source_File_Index (Sref));

            --  Ignore operators

            if Tref (Sref) = '"' then
               null;

            --  Otherwise determine required casing of Standard entity

            else
               --  ASCII is all upper case

               if Entity (Ref) = Standard_ASCII then
                  Cas := All_Upper_Case;

               --  Special names in ASCII are also all upper case

               elsif Sdef = Standard_ASCII_Location then
                  Cas := All_Upper_Case;

               --  All other entities are in mixed case

               else
                  Cas := Mixed_Case;
               end if;

               Nlen := Length_Of_Name (Chars (Ref));

               --  Now check if we have the right casing

               if Determine_Casing
                    (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)) = Cas
               then
                  null;
               else
                  Name_Len := Integer (Nlen);
                  Name_Buffer (1 .. Name_Len) :=
                    String (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1));
                  Set_Casing (Cas);
                  Error_Msg_Name_1 := Name_Enter;
                  Error_Msg_N -- CODEFIX
                    ("(style) bad casing of %% declared in Standard", Ref);
               end if;
            end if;
         end if;
      end if;
   end Check_Identifier;

   ------------------------
   -- Missing_Overriding --
   ------------------------

   procedure Missing_Overriding (N : Node_Id; E : Entity_Id) is
   begin
      --  Note that Error_Msg_NE, which would be more natural to use here,
      --  is not visible from this generic unit ???

      Error_Msg_Name_1 := Chars (E);

      if Style_Check_Missing_Overriding and then Comes_From_Source (N) then
         if Nkind (N) = N_Subprogram_Body then
            Error_Msg_N -- CODEFIX
              ("(style) missing OVERRIDING indicator in body of%", N);
         else
            Error_Msg_N -- CODEFIX
              ("(style) missing OVERRIDING indicator in declaration of%", N);
         end if;
      end if;
   end Missing_Overriding;

   -----------------------------------
   -- Subprogram_Not_In_Alpha_Order --
   -----------------------------------

   procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is
   begin
      if Style_Check_Order_Subprograms then
         Error_Msg_N -- CODEFIX
           ("(style) subprogram body& not in alphabetical order", Name);
      end if;
   end Subprogram_Not_In_Alpha_Order;
end Style;