Subversion Repositories openrisc_2011-10-31

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                                S T Y L E                                 --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2008, 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

              ("(style) index number not allowed for one dimensional array",

               E1);

         elsif D > 1 and then No (E1) then

            Error_Msg_N

              ("(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

                    ("(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

                    ("(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

              ("(style) missing OVERRIDING indicator in body of%", N);

         else

            Error_Msg_N

              ("(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

           ("(style) subprogram body& not in alphabetical order", Name);

      end if;

   end Subprogram_Not_In_Alpha_Order;

end Style;