New file.

From-SVN: r145833

gcc/ada/style.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         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;