------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S T Y L E -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2024, 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 Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Errout; use Errout; with Namet; use Namet; with Nlists; use Nlists; with Opt; use Opt; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinput; use Sinput; with Snames; use Snames; 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 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?s?", 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?A?", E1); elsif D > 1 and then No (E1) then Error_Msg_N -- CODEFIX ("(style) index number required for multi-dimensional array?A?", N); end if; end if; end Check_Array_Attribute_Index; ---------------------------- -- Check_Boolean_Operator -- ---------------------------- procedure Check_Boolean_Operator (Node : Node_Id) is function OK_Boolean_Operand (N : Node_Id) return Boolean; -- Returns True for simple variable, or "not X1" or "X1 and X2" or -- "X1 or X2" where X1, X2 are recursively OK_Boolean_Operand's. ------------------------ -- OK_Boolean_Operand -- ------------------------ function OK_Boolean_Operand (N : Node_Id) return Boolean is begin if Nkind (N) in N_Identifier | N_Expanded_Name then return True; elsif Nkind (N) = N_Op_Not then return OK_Boolean_Operand (Original_Node (Right_Opnd (N))); elsif Nkind (N) in N_Op_And | N_Op_Or then return OK_Boolean_Operand (Original_Node (Left_Opnd (N))) and then OK_Boolean_Operand (Original_Node (Right_Opnd (N))); else return False; end if; end OK_Boolean_Operand; -- Start of processing for Check_Boolean_Operator begin if Style_Check_Boolean_And_Or and then Comes_From_Source (Node) then declare Orig : constant Node_Id := Original_Node (Node); begin if Nkind (Orig) in N_Op_And | N_Op_Or then declare L : constant Node_Id := Original_Node (Left_Opnd (Orig)); R : constant Node_Id := Original_Node (Right_Opnd (Orig)); begin -- First OK case, simple boolean constants/identifiers if OK_Boolean_Operand (L) and then OK_Boolean_Operand (R) then return; -- Second OK case, modular types elsif Is_Modular_Integer_Type (Etype (Node)) then return; -- Third OK case, array types elsif Is_Array_Type (Etype (Node)) then return; -- Otherwise we have an error elsif Nkind (Orig) = N_Op_And then Error_Msg -- CODEFIX ("(style) `AND THEN` required?B?", Sloc (Orig), Orig); else Error_Msg -- CODEFIX ("(style) `OR ELSE` required?B?", Sloc (Orig), Orig); end if; end; end if; end; end if; end Check_Boolean_Operator; ---------------------- -- Check_Identifier -- ---------------------- -- In check references mode (-gnatyr), identifier uses must be cased -- the same way as the corresponding identifier declaration. If standard -- references are checked (-gnatyn), then identifiers from Standard must -- be cased as in the Reference Manual. 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, or a record component whose -- Original_Record_Component comes from source. elsif Comes_From_Source (Def) or else (Ekind (Def) in Record_Field_Kind and then Present (Original_Record_Component (Def)) and then Comes_From_Source (Original_Record_Component (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 case of operator names. This also catches the case -- 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 loop -- If end of identifiers, all done. Note that they are the -- same length. pragma Assert (Identifier_Char (Tref (Sref)) = Identifier_Char (Tdef (Sdef))); if not Identifier_Char (Tref (Sref)) then return; end if; -- Case mismatch if Tref (Sref) /= Tdef (Sdef) then Error_Msg_Node_1 := Def; Error_Msg_Sloc := Sloc (Def); Error_Msg -- CODEFIX ("(style) bad casing of & declared#?r?", Sref, Ref); return; end if; Sref := Sref + 1; Sdef := Sdef + 1; end loop; pragma Assert (False); 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 Chars (Ref) = Name_ASCII then Cas := All_Upper_Case; -- Special handling for names in package ASCII elsif Sdef = Standard_ASCII_Location then declare Nam : constant String := Get_Name_String (Chars (Def)); begin -- Bar is mixed case if Nam = "bar" then Cas := Mixed_Case; -- All names longer than 4 characters are mixed case elsif Nam'Length > 4 then Cas := Mixed_Case; -- All names shorter than 4 characters (other than Bar, -- which we already tested for specially) are Upper case. else Cas := All_Upper_Case; end if; end; -- 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?n?", Ref); end if; end if; end if; end if; end Check_Identifier; ---------------------------------- -- Check_Xtra_Parens_Precedence -- ---------------------------------- procedure Check_Xtra_Parens_Precedence (N : Node_Id) is begin if Style_Check_Xtra_Parens_Precedence and then Paren_Count (N) > (if Nkind (N) in N_Case_Expression | N_Expression_With_Actions | N_If_Expression | N_Quantified_Expression | N_Raise_Expression then 1 else 0) then Error_Msg -- CODEFIX ("(style) redundant parentheses?z?", First_Sloc (N), N); end if; end Check_Xtra_Parens_Precedence; ------------------------ -- Missing_Overriding -- ------------------------ procedure Missing_Overriding (N : Node_Id; E : Entity_Id) is Nod : Node_Id; begin -- Perform the check on source subprograms and on subprogram instances, -- because these can be primitives of untagged types. Note that such -- indicators were introduced in Ada 2005. We apply Comes_From_Source -- to Original_Node to catch the case of a procedure body declared with -- "is null" that has been rewritten as a normal empty body. -- We do not emit a warning on an inherited operation that comes from -- a type derivation. if Style_Check_Missing_Overriding and then (Comes_From_Source (Original_Node (N)) or else Is_Generic_Instance (E)) and then Ada_Version_Explicit >= Ada_2005 and then Present (Parent (E)) and then Nkind (Parent (E)) /= N_Full_Type_Declaration then -- If the subprogram is an instantiation, its declaration appears -- within a wrapper package that precedes the instance node. Place -- warning on the node to avoid references to the original generic. if Nkind (N) = N_Subprogram_Declaration and then Is_Generic_Instance (E) then Nod := Next (Parent (Parent (List_Containing (N)))); else Nod := N; end if; if Nkind (N) = N_Subprogram_Body then Error_Msg_NE -- CODEFIX ("(style) missing OVERRIDING indicator in body of&?O?", N, E); elsif Nkind (N) = N_Abstract_Subprogram_Declaration then Error_Msg_NE -- CODEFIX ("(style) missing OVERRIDING indicator in declaration of&?O?", Specification (N), E); else Error_Msg_NE -- CODEFIX ("(style) missing OVERRIDING indicator in declaration of&?O?", Nod, E); 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?o?", Name); end if; end Subprogram_Not_In_Alpha_Order; end Style;