--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
projects / gcc.git / commitdiff