-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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 2, or (at your option) any later ver- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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. --
-- checking rules. For documentation of these rules, see comments on the
-- individual procedures.
+with Atree; use Atree;
with Casing; use Casing;
with Csets; use Csets;
+with Einfo; use Einfo;
with Err_Vars; use Err_Vars;
with Opt; use Opt;
with Scans; use Scans;
+with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Stylesw; use Stylesw;
-- Check that token is first token on line, or else is not preceded
-- by white space. Signal error of space not allowed if not.
+ procedure Check_Separate_Stmt_Lines_Cont;
+ -- Non-inlined continuation of Check_Separate_Stmt_Lines
+
function Determine_Token_Casing return Casing_Type;
+ -- Determine casing of current token
procedure Error_Space_Not_Allowed (S : Source_Ptr);
-- Posts an error message indicating that a space is not allowed
begin
if Style_Check_Attribute_Casing then
if Determine_Token_Casing /= Mixed_Case then
- Error_Msg_SC ("(style) bad capitalization, mixed case required");
+ Error_Msg_SC -- CODEFIX
+ ("(style) bad capitalization, mixed case required");
end if;
end if;
end Check_Attribute_Name;
end if;
end Check_Binary_Operator;
+ ----------------------------
+ -- 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_In (N, 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_In (N, 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 processig 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_In (Orig, 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 ("(style) `AND THEN` required", Sloc (Orig));
+ else
+ Error_Msg ("(style) `OR ELSE` required", Sloc (Orig));
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+ end Check_Boolean_Operator;
+
---------------
-- Check_Box --
---------------
-- 1. Any comment that is not at the start of a line, i.e. where the
-- initial minuses are not the first non-blank characters on the
- -- line must have at least one blank after the second minus.
+ -- line must have at least one blank after the second minus or a
+ -- special character as defined in rule 5.
-- 2. A row of all minuses of any length is permitted (see procedure
-- box above in the source of this routine).
-- range 16#21#..16#2F# or 16#3A#..16#3F#. This allows special
-- comments, such as those generated by gnatprep, or those that
-- appear in the SPARK annotation language to be accepted.
- --
+
-- Note: for GNAT internal files (-gnatg switch set on for the
-- compilation), the only special sequence recognized and allowed
-- is --! as generated by gnatprep.
+ -- 6. In addition, the comment must be properly indented if comment
+ -- indentation checking is active (Style_Check_Indentation non-zero).
+ -- Either the start column must be a multiple of this indentation,
+ -- or the indentation must match that of the next non-blank line.
+
procedure Check_Comment is
S : Source_Ptr;
C : Character;
-- Returns True if the last two characters on the line are -- which
-- characterizes a box comment (as for example follows this spec).
+ function Is_Special_Character (C : Character) return Boolean;
+ -- Determines if C is a special character (see rule 5 above)
+
+ function Same_Column_As_Next_Non_Blank_Line return Boolean;
+ -- Called for a full line comment. If the indentation of this comment
+ -- matches that of the next non-blank line in the source, then True is
+ -- returned, otherwise False.
+
--------------------
-- Is_Box_Comment --
--------------------
return Source (S - 1) = '-' and then Source (S - 2) = '-';
end Is_Box_Comment;
+ --------------------------
+ -- Is_Special_Character --
+ --------------------------
+
+ function Is_Special_Character (C : Character) return Boolean is
+ begin
+ if GNAT_Mode then
+ return C = '!';
+ else
+ return
+ Character'Pos (C) in 16#21# .. 16#2F#
+ or else
+ Character'Pos (C) in 16#3A# .. 16#3F#;
+ end if;
+ end Is_Special_Character;
+
+ ----------------------------------------
+ -- Same_Column_As_Next_Non_Blank_Line --
+ ----------------------------------------
+
+ function Same_Column_As_Next_Non_Blank_Line return Boolean is
+ P : Source_Ptr;
+
+ begin
+ -- Step to end of line
+
+ P := Scan_Ptr + 2;
+ while Source (P) not in Line_Terminator loop
+ P := P + 1;
+ end loop;
+
+ -- Step past blanks, and line terminators (UTF_32 case???)
+
+ while Source (P) <= ' ' and then Source (P) /= EOF loop
+ P := P + 1;
+ end loop;
+
+ -- Compare columns
+
+ return Get_Column_Number (Scan_Ptr) = Get_Column_Number (P);
+ end Same_Column_As_Next_Non_Blank_Line;
+
-- Start of processing for Check_Comment
begin
-- For a comment that is not at the start of the line, the only
-- requirement is that we cannot have a non-blank character after
- -- the second minus sign.
+ -- the second minus sign or a special character.
if Scan_Ptr /= First_Non_Blank_Location then
if Style_Check_Comments then
- if Source (Scan_Ptr + 2) > ' ' then
+ if Source (Scan_Ptr + 2) > ' '
+ and then not Is_Special_Character (Source (Scan_Ptr + 2))
+ then
Error_Msg ("(style) space required", Scan_Ptr + 2);
end if;
end if;
if Style_Check_Indentation /= 0 then
if Start_Column rem Style_Check_Indentation /= 0 then
- Error_Msg_S ("(style) bad column");
+ if not Same_Column_As_Next_Non_Blank_Line then
+ Error_Msg_S -- CODEFIX
+ ("(style) bad column");
+ end if;
+
return;
end if;
end if;
- -- If we are not checking comments, nothing to do
+ -- If we are not checking comments, nothing more to do
if not Style_Check_Comments then
return;
-- This is not permitted in internal GNAT implementation units
-- except for the case of --! as used by gnatprep output.
- if GNAT_Mode then
- if C = '!' then
- return;
- end if;
-
- else
- if Character'Pos (C) in 16#21# .. 16#2F#
- or else
- Character'Pos (C) in 16#3A# .. 16#3F#
- then
- return;
- end if;
+ if Is_Special_Character (C) then
+ return;
end if;
-- The only other case in which we allow a character after
-- In check indentation mode (-gnatyn for n a digit), a new statement or
-- declaration is required to start in a column that is a multiple of the
- -- indentiation amount.
+ -- indentation amount.
procedure Check_Indentation is
begin
end if;
end if;
- -- Check DOS line terminator (ignore EOF, since we only get called
- -- with an EOF if it is the last character in the buffer, and was
- -- therefore not present in the sources
+ -- Check DOS line terminator
if Style_Check_DOS_Line_Terminator then
+
+ -- Ignore EOF, since we only get called with an EOF if it is the last
+ -- character in the buffer (and was therefore not in the source file),
+ -- since the terminating EOF is added to stop the scan.
+
if Source (Scan_Ptr) = EOF then
null;
- elsif Source (Scan_Ptr) /= LF
- or else Source (Scan_Ptr + 1) = CR
- then
+
+ -- Bad terminator if we don't have an LF
+
+ elsif Source (Scan_Ptr) /= LF then
Error_Msg_S ("(style) incorrect line terminator");
end if;
end if;
else
if Style_Check_Blank_Lines and then Blank_Lines > 1 then
- Error_Msg
+ Error_Msg -- CODEFIX
("(style) multiple blank lines", Blank_Line_Location);
end if;
begin
if Style_Check_Pragma_Casing then
if Determine_Token_Casing /= Mixed_Case then
- Error_Msg_SC ("(style) bad capitalization, mixed case required");
+ Error_Msg_SC -- CODEFIX
+ ("(style) bad capitalization, mixed case required");
end if;
end if;
end Check_Pragma_Name;
-- Check_Right_Paren --
-----------------------
- -- In check tokens mode (-gnatyt), right paren must never be preceded by
+ -- In check tokens mode (-gnatyt), right paren must not be immediately
+ -- followed by an identifier character, and must never be preceded by
-- a space unless it is the initial non-blank character on the line.
procedure Check_Right_Paren is
begin
if Style_Check_Tokens then
+ if Identifier_Char (Source (Token_Ptr + 1)) then
+ Error_Space_Required (Token_Ptr + 1);
+ end if;
+
Check_No_Space_Before;
end if;
end Check_Right_Paren;
end if;
end Check_Semicolon;
+ -------------------------------
+ -- Check_Separate_Stmt_Lines --
+ -------------------------------
+
+ procedure Check_Separate_Stmt_Lines is
+ begin
+ if Style_Check_Separate_Stmt_Lines then
+ Check_Separate_Stmt_Lines_Cont;
+ end if;
+ end Check_Separate_Stmt_Lines;
+
+ ------------------------------------
+ -- Check_Separate_Stmt_Lines_Cont --
+ ------------------------------------
+
+ procedure Check_Separate_Stmt_Lines_Cont is
+ S : Source_Ptr;
+
+ begin
+ -- Skip past white space
+
+ S := Scan_Ptr;
+ while Is_White_Space (Source (S)) loop
+ S := S + 1;
+ end loop;
+
+ -- Line terminator is OK
+
+ if Source (S) in Line_Terminator then
+ return;
+
+ -- Comment is OK
+
+ elsif Source (S) = '-' and then Source (S + 1) = '-' then
+ return;
+
+ -- ABORT keyword is OK after THEN (THEN ABORT case)
+
+ elsif Token = Tok_Then
+ and then (Source (S + 0) = 'a' or else Source (S + 0) = 'A')
+ and then (Source (S + 1) = 'b' or else Source (S + 1) = 'B')
+ and then (Source (S + 2) = 'o' or else Source (S + 2) = 'O')
+ and then (Source (S + 3) = 'r' or else Source (S + 3) = 'R')
+ and then (Source (S + 4) = 't' or else Source (S + 4) = 'T')
+ and then (Source (S + 5) in Line_Terminator
+ or else Is_White_Space (Source (S + 5)))
+ then
+ return;
+
+ -- PRAGMA keyword is OK after ELSE
+
+ elsif Token = Tok_Else
+ and then (Source (S + 0) = 'p' or else Source (S + 0) = 'P')
+ and then (Source (S + 1) = 'r' or else Source (S + 1) = 'R')
+ and then (Source (S + 2) = 'a' or else Source (S + 2) = 'A')
+ and then (Source (S + 3) = 'g' or else Source (S + 3) = 'G')
+ and then (Source (S + 4) = 'm' or else Source (S + 4) = 'M')
+ and then (Source (S + 5) = 'a' or else Source (S + 5) = 'A')
+ and then (Source (S + 6) in Line_Terminator
+ or else Is_White_Space (Source (S + 6)))
+ then
+ return;
+
+ -- Otherwise we have the style violation we are looking for
+
+ else
+ if Token = Tok_Then then
+ Error_Msg
+ ("(style) no statements may follow THEN on same line", S);
+ else
+ Error_Msg
+ ("(style) no statements may follow ELSE on same line", S);
+ end if;
+ end if;
+ end Check_Separate_Stmt_Lines_Cont;
+
----------------
-- Check_Then --
----------------
-- Check_Unary_Plus_Or_Minus --
-------------------------------
- -- In check tokem mode (-gnatyt), unary plus or minus must not be
+ -- In check token mode (-gnatyt), unary plus or minus must not be
-- followed by a space.
procedure Check_Unary_Plus_Or_Minus is
return C = ' ' or else C = HT;
end Is_White_Space;
+ -------------------
+ -- Mode_In_Check --
+ -------------------
+
+ function Mode_In_Check return Boolean is
+ begin
+ return Style_Check and Style_Check_Mode_In;
+ end Mode_In_Check;
+
-----------------
-- No_End_Name --
-----------------
-- Non_Lower_Case_Keyword --
----------------------------
- -- In check casing mode (-gnatyk), reserved keywords must be be spelled
+ -- In check casing mode (-gnatyk), reserved keywords must be spelled
-- in all lower case (excluding keywords range, access, delta and digits
-- used as attribute designators).
procedure Non_Lower_Case_Keyword is
begin
if Style_Check_Keyword_Casing then
- Error_Msg_SC ("(style) reserved words must be all lower case");
+ Error_Msg_SC -- CODEIX
+ ("(style) reserved words must be all lower case");
end if;
end Non_Lower_Case_Keyword;
end if;
end Require_Preceding_Space;
- ---------------------
- -- RM_Column_Check --
- ---------------------
-
- function RM_Column_Check return Boolean is
- begin
- return Style_Check and Style_Check_Layout;
- end RM_Column_Check;
-
end Styleg;
OSDN Git Service
