From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/style.adb | 266 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 266 insertions(+) create mode 100644 gcc/ada/style.adb (limited to 'gcc/ada/style.adb') diff --git a/gcc/ada/style.adb b/gcc/ada/style.adb new file mode 100644 index 000000000..0f0ab300c --- /dev/null +++ b/gcc/ada/style.adb @@ -0,0 +1,266 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; -- cgit v1.2.3