1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                               S T Y L E G                                --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2018, Free Software Foundation, Inc.         --
10--                                                                          --
11-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12-- terms of the  GNU General Public License as published  by the Free Soft- --
13-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17-- for  more details.  You should have  received  a copy of the GNU General --
18-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19-- http://www.gnu.org/licenses for a complete copy of the license.          --
20--                                                                          --
21-- GNAT was originally developed  by the GNAT team at  New York University. --
22-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23--                                                                          --
24------------------------------------------------------------------------------
25
26--  This version of the Style package implements the standard GNAT style
27--  checking rules. For documentation of these rules, see comments on the
28--  individual procedures.
29
30with Atree;    use Atree;
31with Casing;   use Casing;
32with Csets;    use Csets;
33with Einfo;    use Einfo;
34with Err_Vars; use Err_Vars;
35with Opt;      use Opt;
36with Scans;    use Scans;
37with Sinfo;    use Sinfo;
38with Sinput;   use Sinput;
39with Stylesw;  use Stylesw;
40
41package body Styleg is
42
43   use ASCII;
44
45   Blank_Lines : Nat := 0;
46   --  Counts number of empty lines seen. Reset to zero if a non-empty line
47   --  is encountered. Used to check for trailing blank lines in Check_EOF,
48   --  and for multiple blank lines.
49
50   Blank_Line_Location : Source_Ptr;
51   --  Remembers location of first blank line in a series. Used to issue an
52   --  appropriate diagnostic if subsequent blank lines or the end of file
53   --  is encountered.
54
55   -----------------------
56   -- Local Subprograms --
57   -----------------------
58
59   procedure Check_No_Space_After;
60   --  Checks that there is a non-white space character after the current
61   --  token, or white space followed by a comment, or the end of line.
62   --  Issue error message if not.
63
64   procedure Check_No_Space_Before;
65   --  Check that token is first token on line, or else is not preceded
66   --  by white space. Signal error of space not allowed if not.
67
68   procedure Check_Separate_Stmt_Lines_Cont;
69   --  Non-inlined continuation of Check_Separate_Stmt_Lines
70
71   function Determine_Token_Casing return Casing_Type;
72   --  Determine casing of current token
73
74   procedure Error_Space_Not_Allowed (S : Source_Ptr);
75   --  Posts an error message indicating that a space is not allowed
76   --  at the given source location.
77
78   procedure Error_Space_Required (S : Source_Ptr);
79   --  Posts an error message indicating that a space is required at
80   --  the given source location.
81
82   function Is_White_Space (C : Character) return Boolean;
83   pragma Inline (Is_White_Space);
84   --  Returns True for space or HT, False otherwise
85   --  What about VT and FF, should they return True ???
86
87   procedure Require_Following_Space;
88   pragma Inline (Require_Following_Space);
89   --  Require token to be followed by white space. Used only if in GNAT
90   --  style checking mode.
91
92   procedure Require_Preceding_Space;
93   pragma Inline (Require_Preceding_Space);
94   --  Require token to be preceded by white space. Used only if in GNAT
95   --  style checking mode.
96
97   ----------------------
98   -- Check_Abs_Or_Not --
99   ----------------------
100
101   --  In check token mode (-gnatyt), ABS/NOT must be followed by a space
102
103   procedure Check_Abs_Not is
104   begin
105      if Style_Check_Tokens then
106         if Source (Scan_Ptr) > ' ' then -- ???
107            Error_Space_Required (Scan_Ptr);
108         end if;
109      end if;
110   end Check_Abs_Not;
111
112   ----------------------
113   -- Check_Apostrophe --
114   ----------------------
115
116   --  Do not allow space before or after apostrophe -- OR AFTER???
117
118   procedure Check_Apostrophe is
119   begin
120      if Style_Check_Tokens then
121         Check_No_Space_After;
122      end if;
123   end Check_Apostrophe;
124
125   -----------------
126   -- Check_Arrow --
127   -----------------
128
129   --  In check tokens mode (-gnatys), arrow must be surrounded by spaces,
130   --  except that within the argument of a Depends or Refined_Depends aspect
131   --  or pragma the required format is "=>+ " rather than "=> +").
132
133   procedure Check_Arrow (Inside_Depends : Boolean := False) is
134   begin
135      if Style_Check_Tokens then
136         Require_Preceding_Space;
137
138         --  Special handling for Depends and Refined_Depends
139
140         if Inside_Depends then
141            if Source (Scan_Ptr) = ' '
142              and then Source (Scan_Ptr + 1) = '+'
143            then
144               Error_Space_Not_Allowed (Scan_Ptr);
145
146            elsif Source (Scan_Ptr) /= ' '
147              and then Source (Scan_Ptr) /= '+'
148            then
149               Require_Following_Space;
150            end if;
151
152         --  Normal case
153
154         else
155            Require_Following_Space;
156         end if;
157      end if;
158   end Check_Arrow;
159
160   --------------------------
161   -- Check_Attribute_Name --
162   --------------------------
163
164   --  In check attribute casing mode (-gnatya), attribute names must be
165   --  mixed case, i.e. start with an upper case letter, and otherwise
166   --  lower case, except after an underline character.
167
168   procedure Check_Attribute_Name (Reserved : Boolean) is
169      pragma Warnings (Off, Reserved);
170   begin
171      if Style_Check_Attribute_Casing then
172         if Determine_Token_Casing /= Mixed_Case then
173            Error_Msg_SC -- CODEFIX
174              ("(style) bad capitalization, mixed case required");
175         end if;
176      end if;
177   end Check_Attribute_Name;
178
179   ---------------------------
180   -- Check_Binary_Operator --
181   ---------------------------
182
183   --  In check token mode (-gnatyt), binary operators other than the special
184   --  case of exponentiation require surrounding space characters.
185
186   procedure Check_Binary_Operator is
187   begin
188      if Style_Check_Tokens then
189         Require_Preceding_Space;
190         Require_Following_Space;
191      end if;
192   end Check_Binary_Operator;
193
194   ----------------------------
195   -- Check_Boolean_Operator --
196   ----------------------------
197
198   procedure Check_Boolean_Operator (Node : Node_Id) is
199
200      function OK_Boolean_Operand (N : Node_Id) return Boolean;
201      --  Returns True for simple variable, or "not X1" or "X1 and X2" or
202      --  "X1 or X2" where X1, X2 are recursively OK_Boolean_Operand's.
203
204      ------------------------
205      -- OK_Boolean_Operand --
206      ------------------------
207
208      function OK_Boolean_Operand (N : Node_Id) return Boolean is
209      begin
210         if Nkind_In (N, N_Identifier, N_Expanded_Name) then
211            return True;
212
213         elsif Nkind (N) = N_Op_Not then
214            return OK_Boolean_Operand (Original_Node (Right_Opnd (N)));
215
216         elsif Nkind_In (N, N_Op_And, N_Op_Or) then
217            return OK_Boolean_Operand (Original_Node (Left_Opnd (N)))
218                     and then
219                   OK_Boolean_Operand (Original_Node (Right_Opnd (N)));
220
221         else
222            return False;
223         end if;
224      end OK_Boolean_Operand;
225
226   --  Start of processing for Check_Boolean_Operator
227
228   begin
229      if Style_Check_Boolean_And_Or
230        and then Comes_From_Source (Node)
231      then
232         declare
233            Orig : constant Node_Id := Original_Node (Node);
234
235         begin
236            if Nkind_In (Orig, N_Op_And, N_Op_Or) then
237               declare
238                  L : constant Node_Id := Original_Node (Left_Opnd  (Orig));
239                  R : constant Node_Id := Original_Node (Right_Opnd (Orig));
240
241               begin
242                  --  First OK case, simple boolean constants/identifiers
243
244                  if OK_Boolean_Operand (L)
245                       and then
246                     OK_Boolean_Operand (R)
247                  then
248                     return;
249
250                  --  Second OK case, modular types
251
252                  elsif Is_Modular_Integer_Type (Etype (Node)) then
253                     return;
254
255                  --  Third OK case, array types
256
257                  elsif Is_Array_Type (Etype (Node)) then
258                     return;
259
260                  --  Otherwise we have an error
261
262                  elsif Nkind (Orig) = N_Op_And then
263                     Error_Msg -- CODEFIX
264                       ("(style) `AND THEN` required", Sloc (Orig));
265                  else
266                     Error_Msg -- CODEFIX
267                       ("(style) `OR ELSE` required", Sloc (Orig));
268                  end if;
269               end;
270            end if;
271         end;
272      end if;
273   end Check_Boolean_Operator;
274
275   ---------------
276   -- Check_Box --
277   ---------------
278
279   --  In check token mode (-gnatyt), box must be preceded by a space or by
280   --  a left parenthesis. Spacing checking on the surrounding tokens takes
281   --  care of the remaining checks.
282
283   procedure Check_Box is
284   begin
285      if Style_Check_Tokens then
286         if Prev_Token /= Tok_Left_Paren then
287            Require_Preceding_Space;
288         end if;
289      end if;
290   end Check_Box;
291
292   -----------------
293   -- Check_Colon --
294   -----------------
295
296   --  In check token mode (-gnatyt), colon must be surrounded by spaces
297
298   procedure Check_Colon is
299   begin
300      if Style_Check_Tokens then
301         Require_Preceding_Space;
302         Require_Following_Space;
303      end if;
304   end Check_Colon;
305
306   -----------------------
307   -- Check_Colon_Equal --
308   -----------------------
309
310   --  In check token mode (-gnatyt), := must be surrounded by spaces
311
312   procedure Check_Colon_Equal is
313   begin
314      if Style_Check_Tokens then
315         Require_Preceding_Space;
316         Require_Following_Space;
317      end if;
318   end Check_Colon_Equal;
319
320   -----------------
321   -- Check_Comma --
322   -----------------
323
324   --  In check token mode (-gnatyt), comma must be either the first
325   --  token on a line, or be preceded by a non-blank character.
326   --  It must also always be followed by a blank.
327
328   procedure Check_Comma is
329   begin
330      if Style_Check_Tokens then
331         Check_No_Space_Before;
332
333         if Source (Scan_Ptr) > ' ' then
334            Error_Space_Required (Scan_Ptr);
335         end if;
336      end if;
337   end Check_Comma;
338
339   -------------------
340   -- Check_Comment --
341   -------------------
342
343   --  In check comment mode (-gnatyc) there are several requirements on the
344   --  format of comments. The following are permissible comment formats:
345
346   --    1. Any comment that is not at the start of a line, i.e. where the
347   --       initial minuses are not the first non-blank characters on the
348   --       line must have at least one blank after the second minus or a
349   --       special character as defined in rule 5.
350
351   --    2. A row of all minuses of any length is permitted (see procedure
352   --       box above in the source of this routine).
353
354   --    3. A comment line starting with two minuses and a space, and ending
355   --       with a space and two minuses. Again see the procedure title box
356   --       immediately above in the source.
357
358   --    4. A full line comment where two spaces follow the two minus signs.
359   --       This is the normal comment format in GNAT style, as typified by
360   --       the comments you are reading now.
361
362   --    5. A full line comment where the first character after the second
363   --       minus is a special character, i.e. a character in the ASCII
364   --       range 16#21#..16#2F# or 16#3A#..16#3F#. This allows special
365   --       comments, such as those generated by gnatprep, or those that
366   --       appear in the SPARK annotation language to be accepted.
367
368   --       Note: for GNAT internal files (-gnatg switch set on for the
369   --       compilation), the only special sequence recognized and allowed
370   --       is --! as generated by gnatprep.
371
372   --    6. In addition, the comment must be properly indented if comment
373   --       indentation checking is active (Style_Check_Indentation non-zero).
374   --       Either the start column must be a multiple of this indentation,
375   --       or the indentation must match that of the next non-blank line,
376   --       or must match the indentation of the immediately preciding line
377   --       if it is non-blank.
378
379   procedure Check_Comment is
380      S : Source_Ptr;
381      C : Character;
382
383      function Is_Box_Comment return Boolean;
384      --  Returns True if the last two characters on the line are -- which
385      --  characterizes a box comment (as for example follows this spec).
386
387      function Is_Special_Character (C : Character) return Boolean;
388      --  Determines if C is a special character (see rule 5 above)
389
390      function Same_Column_As_Next_Non_Blank_Line return Boolean;
391      --  Called for a full line comment. If the indentation of this comment
392      --  matches that of the next non-blank line in the source, then True is
393      --  returned, otherwise False.
394
395      function Same_Column_As_Previous_Line return Boolean;
396      --  Called for a full line comment. If the previous line is blank, then
397      --  returns False. Otherwise, if the indentation of this comment matches
398      --  that of the previous line in the source, then True is returned,
399      --  otherwise False.
400
401      --------------------
402      -- Is_Box_Comment --
403      --------------------
404
405      function Is_Box_Comment return Boolean is
406         S : Source_Ptr;
407
408      begin
409         --  Do we need to worry about UTF_32 line terminators here ???
410
411         S := Scan_Ptr + 3;
412         while Source (S) not in Line_Terminator loop
413            S := S + 1;
414         end loop;
415
416         return Source (S - 1) = '-' and then Source (S - 2) = '-';
417      end Is_Box_Comment;
418
419      --------------------------
420      -- Is_Special_Character --
421      --------------------------
422
423      function Is_Special_Character (C : Character) return Boolean is
424      begin
425         if GNAT_Mode then
426            return C = '!';
427         else
428            return
429              Character'Pos (C) in 16#21# .. 16#2F#
430                or else
431              Character'Pos (C) in 16#3A# .. 16#3F#;
432         end if;
433      end Is_Special_Character;
434
435      ----------------------------------------
436      -- Same_Column_As_Next_Non_Blank_Line --
437      ----------------------------------------
438
439      function Same_Column_As_Next_Non_Blank_Line return Boolean is
440         P : Source_Ptr;
441
442      begin
443         --  Step to end of line
444
445         P := Scan_Ptr + 2;
446         while Source (P) not in Line_Terminator loop
447            P := P + 1;
448         end loop;
449
450         --  Step past blanks, and line terminators (UTF_32 case???)
451
452         while Source (P) <= ' ' and then Source (P) /= EOF loop
453            P := P + 1;
454         end loop;
455
456         --  Compare columns
457
458         return Get_Column_Number (Scan_Ptr) = Get_Column_Number (P);
459      end Same_Column_As_Next_Non_Blank_Line;
460
461      ----------------------------------
462      -- Same_Column_As_Previous_Line --
463      ----------------------------------
464
465      function Same_Column_As_Previous_Line return Boolean is
466         S, P : Source_Ptr;
467
468      begin
469         --  Point S to start of this line, and P to start of previous line
470
471         S := Line_Start (Scan_Ptr);
472         P := S;
473         Backup_Line (P);
474
475         --  Step P to first non-blank character on line
476
477         loop
478            --  If we get back to start of current line, then the previous line
479            --  was blank, and we always return False in that situation.
480
481            if P = S then
482               return False;
483            end if;
484
485            exit when Source (P) /= ' ' and then Source (P) /= ASCII.HT;
486            P := P + 1;
487         end loop;
488
489         --  Compare columns
490
491         return Get_Column_Number (Scan_Ptr) = Get_Column_Number (P);
492      end Same_Column_As_Previous_Line;
493
494   --  Start of processing for Check_Comment
495
496   begin
497      --  Can never have a non-blank character preceding the first minus.
498      --  The "+ 3" is to leave room for a possible byte order mark (BOM);
499      --  we want to avoid a warning for a comment at the start of the
500      --  file just after the BOM.
501
502      if Style_Check_Comments then
503         if Scan_Ptr > Source_First (Current_Source_File) + 3
504           and then Source (Scan_Ptr - 1) > ' '
505         then
506            Error_Msg_S -- CODEFIX
507              ("(style) space required");
508         end if;
509      end if;
510
511      --  For a comment that is not at the start of the line, the only
512      --  requirement is that we cannot have a non-blank character after
513      --  the second minus sign or a special character.
514
515      if Scan_Ptr /= First_Non_Blank_Location then
516         if Style_Check_Comments then
517            if Source (Scan_Ptr + 2) > ' '
518              and then not Is_Special_Character (Source (Scan_Ptr + 2))
519            then
520               Error_Msg -- CODEFIX
521                 ("(style) space required", Scan_Ptr + 2);
522            end if;
523         end if;
524
525         return;
526
527      --  Case of a comment that is at the start of a line
528
529      else
530         --  First check, must be in appropriately indented column
531
532         if Style_Check_Indentation /= 0 then
533            if Start_Column rem Style_Check_Indentation /= 0 then
534               if not Same_Column_As_Next_Non_Blank_Line
535                 and then not Same_Column_As_Previous_Line
536               then
537                  Error_Msg_S -- CODEFIX
538                    ("(style) bad column");
539               end if;
540
541               return;
542            end if;
543         end if;
544
545         --  If we are not checking comments, nothing more to do
546
547         if not Style_Check_Comments then
548            return;
549         end if;
550
551         --  Case of not followed by a blank. Usually wrong, but there are
552         --  some exceptions that we permit.
553
554         if Source (Scan_Ptr + 2) /= ' ' then
555            C := Source (Scan_Ptr + 2);
556
557            --  Case of -- all on its own on a line is OK
558
559            if C < ' ' then
560               return;
561            end if;
562
563            --  Case of --x, x special character is OK (gnatprep/SPARK/etc.)
564            --  This is not permitted in internal GNAT implementation units
565            --  except for the case of --! as used by gnatprep output.
566
567            if Is_Special_Character (C) then
568               return;
569            end if;
570
571            --  The only other case in which we allow a character after
572            --  the -- other than a space is when we have a row of minus
573            --  signs (case of header lines for a box comment for example).
574
575            S := Scan_Ptr + 2;
576            while Source (S) >= ' ' loop
577               if Source (S) /= '-' then
578                  if Is_Box_Comment
579                    or else Style_Check_Comments_Spacing = 1
580                  then
581                     Error_Space_Required (Scan_Ptr + 2);
582                  else
583                     Error_Msg -- CODEFIX
584                       ("(style) two spaces required", Scan_Ptr + 2);
585                  end if;
586
587                  return;
588               end if;
589
590               S := S + 1;
591            end loop;
592
593         --  If we are followed by a blank, then the comment is OK if the
594         --  character following this blank is another blank or a format
595         --  effector, or if the required comment spacing is 1.
596
597         elsif Source (Scan_Ptr + 3) <= ' '
598           or else Style_Check_Comments_Spacing = 1
599         then
600            return;
601
602         --  Here is the case where we only have one blank after the two minus
603         --  signs, with Style_Check_Comments_Spacing set to 2, which is an
604         --  error unless the line ends with two minus signs, the case of a
605         --  box comment.
606
607         elsif not Is_Box_Comment then
608            Error_Space_Required (Scan_Ptr + 3);
609         end if;
610      end if;
611   end Check_Comment;
612
613   -------------------
614   -- Check_Dot_Dot --
615   -------------------
616
617   --  In check token mode (-gnatyt), ".." must be surrounded by spaces
618
619   procedure Check_Dot_Dot is
620   begin
621      if Style_Check_Tokens then
622         Require_Preceding_Space;
623         Require_Following_Space;
624      end if;
625   end Check_Dot_Dot;
626
627   ---------------
628   -- Check_EOF --
629   ---------------
630
631   --  In check blanks at end mode, check no blank lines precede the EOF
632
633   procedure Check_EOF is
634   begin
635      if Style_Check_Blank_Lines then
636
637         --  We expect one blank line, from the EOF, but no more than one
638
639         if Blank_Lines = 2 then
640            Error_Msg -- CODEFIX
641              ("(style) blank line not allowed at end of file",
642               Blank_Line_Location);
643
644         elsif Blank_Lines >= 3 then
645            Error_Msg -- CODEFIX
646              ("(style) blank lines not allowed at end of file",
647               Blank_Line_Location);
648         end if;
649      end if;
650   end Check_EOF;
651
652   -----------------------------------
653   -- Check_Exponentiation_Operator --
654   -----------------------------------
655
656   --  No spaces are required for the ** operator in GNAT style check mode
657
658   procedure Check_Exponentiation_Operator is
659   begin
660      null;
661   end Check_Exponentiation_Operator;
662
663   --------------
664   -- Check_HT --
665   --------------
666
667   --  In check horizontal tab mode (-gnatyh), tab characters are not allowed
668
669   procedure Check_HT is
670   begin
671      if Style_Check_Horizontal_Tabs then
672         Error_Msg_S -- CODEFIX
673           ("(style) horizontal tab not allowed");
674      end if;
675   end Check_HT;
676
677   -----------------------
678   -- Check_Indentation --
679   -----------------------
680
681   --  In check indentation mode (-gnaty? for ? a digit), a new statement or
682   --  declaration is required to start in a column that is a multiple of the
683   --  indentation amount.
684
685   procedure Check_Indentation is
686   begin
687      if Style_Check_Indentation /= 0 then
688         if Token_Ptr = First_Non_Blank_Location
689           and then Start_Column rem Style_Check_Indentation /= 0
690         then
691            Error_Msg_SC -- CODEFIX
692              ("(style) bad indentation");
693         end if;
694      end if;
695   end Check_Indentation;
696
697   ----------------------
698   -- Check_Left_Paren --
699   ----------------------
700
701   --  In check token mode (-gnatyt), left paren must not be preceded by an
702   --  identifier character or digit (a separating space is required) and may
703   --  never be followed by a space.
704
705   procedure Check_Left_Paren is
706   begin
707      if Style_Check_Tokens then
708         if Token_Ptr > Source_First (Current_Source_File)
709           and then Identifier_Char (Source (Token_Ptr - 1))
710         then
711            Error_Space_Required (Token_Ptr);
712         end if;
713
714         Check_No_Space_After;
715      end if;
716   end Check_Left_Paren;
717
718   ---------------------------
719   -- Check_Line_Max_Length --
720   ---------------------------
721
722   --  In check max line length mode (-gnatym), the line length must
723   --  not exceed the permitted maximum value.
724
725   procedure Check_Line_Max_Length (Len : Nat) is
726   begin
727      if Style_Check_Max_Line_Length then
728         if Len > Style_Max_Line_Length then
729            Error_Msg
730              ("(style) this line is too long",
731               Current_Line_Start + Source_Ptr (Style_Max_Line_Length));
732         end if;
733      end if;
734   end Check_Line_Max_Length;
735
736   ---------------------------
737   -- Check_Line_Terminator --
738   ---------------------------
739
740   --  In check blanks at end mode (-gnatyb), lines may not end with a
741   --  trailing space.
742
743   --  In check form feeds mode (-gnatyf), the line terminator may not
744   --  be either of the characters FF or VT.
745
746   --  In check DOS line terminators node (-gnatyd), the line terminator
747   --  must be a single LF, without a following CR.
748
749   procedure Check_Line_Terminator (Len : Nat) is
750      S : Source_Ptr;
751
752      L : Nat := Len;
753      --  Length of line (adjusted down for blanks at end of line)
754
755   begin
756      --  Reset count of blank lines if first line
757
758      if Get_Logical_Line_Number (Scan_Ptr) = 1 then
759         Blank_Lines := 0;
760      end if;
761
762      --  Check FF/VT terminators
763
764      if Style_Check_Form_Feeds then
765         if Source (Scan_Ptr) = ASCII.FF then
766            Error_Msg_S -- CODEFIX
767              ("(style) form feed not allowed");
768         elsif Source (Scan_Ptr) = ASCII.VT then
769            Error_Msg_S -- CODEFIX
770              ("(style) vertical tab not allowed");
771         end if;
772      end if;
773
774      --  Check DOS line terminator
775
776      if Style_Check_DOS_Line_Terminator then
777
778         --  Ignore EOF, since we only get called with an EOF if it is the last
779         --  character in the buffer (and was therefore not in the source
780         --  file), since the terminating EOF is added to stop the scan.
781
782         if Source (Scan_Ptr) = EOF then
783            null;
784
785         --  Bad terminator if we don't have an LF
786
787         elsif Source (Scan_Ptr) /= LF then
788            Error_Msg_S ("(style) incorrect line terminator");
789         end if;
790      end if;
791
792      --  Remove trailing spaces
793
794      S := Scan_Ptr;
795      while L > 0 and then Is_White_Space (Source (S - 1)) loop
796         S := S - 1;
797         L := L - 1;
798      end loop;
799
800      --  Issue message for blanks at end of line if option enabled
801
802      if Style_Check_Blanks_At_End and then L < Len then
803         Error_Msg -- CODEFIX
804           ("(style) trailing spaces not permitted", S);
805      end if;
806
807      --  Deal with empty (blank) line
808
809      if L = 0 then
810
811         --  Increment blank line count
812
813         Blank_Lines := Blank_Lines + 1;
814
815         --  If first blank line, record location for later error message
816
817         if Blank_Lines = 1 then
818            Blank_Line_Location := Scan_Ptr;
819         end if;
820
821      --  Non-blank line, check for previous multiple blank lines
822
823      else
824         if Style_Check_Blank_Lines and then Blank_Lines > 1 then
825            Error_Msg -- CODEFIX
826              ("(style) multiple blank lines", Blank_Line_Location);
827         end if;
828
829         --  And reset blank line count
830
831         Blank_Lines := 0;
832      end if;
833   end Check_Line_Terminator;
834
835   ------------------
836   -- Check_Not_In --
837   ------------------
838
839   --  In check tokens mode, only one space between NOT and IN
840
841   procedure Check_Not_In is
842   begin
843      if Style_Check_Tokens then
844         if Source (Token_Ptr - 1) /= ' '
845           or else Token_Ptr - Prev_Token_Ptr /= 4
846         then -- CODEFIX?
847            Error_Msg
848              ("(style) single space must separate NOT and IN", Token_Ptr - 1);
849         end if;
850      end if;
851   end Check_Not_In;
852
853   --------------------------
854   -- Check_No_Space_After --
855   --------------------------
856
857   procedure Check_No_Space_After is
858      S : Source_Ptr;
859
860   begin
861      if Is_White_Space (Source (Scan_Ptr)) then
862
863         --  Allow one or more spaces if followed by comment
864
865         S := Scan_Ptr + 1;
866         loop
867            if Source (S) = '-' and then Source (S + 1) = '-' then
868               return;
869
870            elsif Is_White_Space (Source (S)) then
871               S := S + 1;
872
873            else
874               exit;
875            end if;
876         end loop;
877
878         Error_Space_Not_Allowed (Scan_Ptr);
879      end if;
880   end Check_No_Space_After;
881
882   ---------------------------
883   -- Check_No_Space_Before --
884   ---------------------------
885
886   procedure Check_No_Space_Before is
887   begin
888      if Token_Ptr > First_Non_Blank_Location
889         and then Source (Token_Ptr - 1) <= ' '
890      then
891         Error_Space_Not_Allowed (Token_Ptr - 1);
892      end if;
893   end Check_No_Space_Before;
894
895   -----------------------
896   -- Check_Pragma_Name --
897   -----------------------
898
899   --  In check pragma casing mode (-gnatyp), pragma names must be mixed
900   --  case, i.e. start with an upper case letter, and otherwise lower case,
901   --  except after an underline character.
902
903   procedure Check_Pragma_Name is
904   begin
905      if Style_Check_Pragma_Casing then
906         if Determine_Token_Casing /= Mixed_Case then
907            Error_Msg_SC -- CODEFIX
908              ("(style) bad capitalization, mixed case required");
909         end if;
910      end if;
911   end Check_Pragma_Name;
912
913   -----------------------
914   -- Check_Right_Paren --
915   -----------------------
916
917   --  In check token mode (-gnatyt), right paren must not be immediately
918   --  followed by an identifier character, and must never be preceded by
919   --  a space unless it is the initial non-blank character on the line.
920
921   procedure Check_Right_Paren is
922   begin
923      if Style_Check_Tokens then
924         if Identifier_Char (Source (Token_Ptr + 1)) then
925            Error_Space_Required (Token_Ptr + 1);
926         end if;
927
928         Check_No_Space_Before;
929      end if;
930   end Check_Right_Paren;
931
932   ---------------------
933   -- Check_Semicolon --
934   ---------------------
935
936   --  In check token mode (-gnatyt), semicolon does not permit a preceding
937   --  space and a following space is required.
938
939   procedure Check_Semicolon is
940   begin
941      if Style_Check_Tokens then
942         Check_No_Space_Before;
943
944         if Source (Scan_Ptr) > ' ' then
945            Error_Space_Required (Scan_Ptr);
946         end if;
947      end if;
948   end Check_Semicolon;
949
950   -------------------------------
951   -- Check_Separate_Stmt_Lines --
952   -------------------------------
953
954   procedure Check_Separate_Stmt_Lines is
955   begin
956      if Style_Check_Separate_Stmt_Lines then
957         Check_Separate_Stmt_Lines_Cont;
958      end if;
959   end Check_Separate_Stmt_Lines;
960
961   ------------------------------------
962   -- Check_Separate_Stmt_Lines_Cont --
963   ------------------------------------
964
965   procedure Check_Separate_Stmt_Lines_Cont is
966      S : Source_Ptr;
967
968   begin
969      --  Skip past white space
970
971      S := Scan_Ptr;
972      while Is_White_Space (Source (S)) loop
973         S := S + 1;
974      end loop;
975
976      --  Line terminator is OK
977
978      if Source (S) in Line_Terminator then
979         return;
980
981      --  Comment is OK
982
983      elsif Source (S) = '-' and then Source (S + 1) = '-' then
984         return;
985
986      --  ABORT keyword is OK after THEN (THEN ABORT case)
987
988      elsif Token = Tok_Then
989        and then (Source (S + 0) = 'a' or else Source (S + 0) = 'A')
990        and then (Source (S + 1) = 'b' or else Source (S + 1) = 'B')
991        and then (Source (S + 2) = 'o' or else Source (S + 2) = 'O')
992        and then (Source (S + 3) = 'r' or else Source (S + 3) = 'R')
993        and then (Source (S + 4) = 't' or else Source (S + 4) = 'T')
994        and then (Source (S + 5) in Line_Terminator
995                   or else Is_White_Space (Source (S + 5)))
996      then
997         return;
998
999      --  PRAGMA keyword is OK after ELSE
1000
1001      elsif Token = Tok_Else
1002        and then (Source (S + 0) = 'p' or else Source (S + 0) = 'P')
1003        and then (Source (S + 1) = 'r' or else Source (S + 1) = 'R')
1004        and then (Source (S + 2) = 'a' or else Source (S + 2) = 'A')
1005        and then (Source (S + 3) = 'g' or else Source (S + 3) = 'G')
1006        and then (Source (S + 4) = 'm' or else Source (S + 4) = 'M')
1007        and then (Source (S + 5) = 'a' or else Source (S + 5) = 'A')
1008        and then (Source (S + 6) in Line_Terminator
1009                   or else Is_White_Space (Source (S + 6)))
1010      then
1011         return;
1012
1013         --  Otherwise we have the style violation we are looking for
1014
1015      else
1016         if Token = Tok_Then then
1017            Error_Msg -- CODEFIX
1018              ("(style) no statements may follow THEN on same line", S);
1019         else
1020            Error_Msg
1021              ("(style) no statements may follow ELSE on same line", S);
1022         end if;
1023      end if;
1024   end Check_Separate_Stmt_Lines_Cont;
1025
1026   ----------------
1027   -- Check_Then --
1028   ----------------
1029
1030   --  In check if then layout mode (-gnatyi), we expect a THEN keyword to
1031   --  appear either on the same line as the IF, or on a separate line if
1032   --  the IF statement extends for more than one line.
1033
1034   procedure Check_Then (If_Loc : Source_Ptr) is
1035   begin
1036      if Style_Check_If_Then_Layout then
1037         declare
1038            If_Line   : constant Physical_Line_Number :=
1039              Get_Physical_Line_Number (If_Loc);
1040            Then_Line : constant Physical_Line_Number :=
1041              Get_Physical_Line_Number (Token_Ptr);
1042         begin
1043            if If_Line = Then_Line then
1044               null;
1045            elsif Token_Ptr /= First_Non_Blank_Location then
1046               Error_Msg_SC ("(style) misplaced THEN");
1047            end if;
1048         end;
1049      end if;
1050   end Check_Then;
1051
1052   -------------------------------
1053   -- Check_Unary_Plus_Or_Minus --
1054   -------------------------------
1055
1056   --  In check token mode (-gnatyt), unary plus or minus must not be
1057   --  followed by a space.
1058
1059   --  Annoying exception: if we have the sequence =>+ within a Depends or
1060   --  Refined_Depends pragma or aspect, then we insist on a space rather
1061   --  than forbidding it.
1062
1063   procedure Check_Unary_Plus_Or_Minus (Inside_Depends : Boolean := False) is
1064   begin
1065      if Style_Check_Tokens then
1066         if Inside_Depends then
1067            Require_Following_Space;
1068         else
1069            Check_No_Space_After;
1070         end if;
1071      end if;
1072   end Check_Unary_Plus_Or_Minus;
1073
1074   ------------------------
1075   -- Check_Vertical_Bar --
1076   ------------------------
1077
1078   --  In check token mode (-gnatyt), vertical bar must be surrounded by spaces
1079
1080   procedure Check_Vertical_Bar is
1081   begin
1082      if Style_Check_Tokens then
1083         Require_Preceding_Space;
1084         Require_Following_Space;
1085      end if;
1086   end Check_Vertical_Bar;
1087
1088   -----------------------
1089   -- Check_Xtra_Parens --
1090   -----------------------
1091
1092   procedure Check_Xtra_Parens (Loc : Source_Ptr) is
1093   begin
1094      if Style_Check_Xtra_Parens then
1095         Error_Msg -- CODEFIX
1096           ("(style) redundant parentheses", Loc);
1097      end if;
1098   end Check_Xtra_Parens;
1099
1100   ----------------------------
1101   -- Determine_Token_Casing --
1102   ----------------------------
1103
1104   function Determine_Token_Casing return Casing_Type is
1105   begin
1106      return Determine_Casing (Source (Token_Ptr .. Scan_Ptr - 1));
1107   end Determine_Token_Casing;
1108
1109   -----------------------------
1110   -- Error_Space_Not_Allowed --
1111   -----------------------------
1112
1113   procedure Error_Space_Not_Allowed (S : Source_Ptr) is
1114   begin
1115      Error_Msg -- CODEFIX
1116        ("(style) space not allowed", S);
1117   end Error_Space_Not_Allowed;
1118
1119   --------------------------
1120   -- Error_Space_Required --
1121   --------------------------
1122
1123   procedure Error_Space_Required (S : Source_Ptr) is
1124   begin
1125      Error_Msg -- CODEFIX
1126        ("(style) space required", S);
1127   end Error_Space_Required;
1128
1129   --------------------
1130   -- Is_White_Space --
1131   --------------------
1132
1133   function Is_White_Space (C : Character) return Boolean is
1134   begin
1135      return C = ' ' or else C = HT;
1136   end Is_White_Space;
1137
1138   -------------------
1139   -- Mode_In_Check --
1140   -------------------
1141
1142   function Mode_In_Check return Boolean is
1143   begin
1144      return Style_Check and Style_Check_Mode_In;
1145   end Mode_In_Check;
1146
1147   -----------------
1148   -- No_End_Name --
1149   -----------------
1150
1151   --  In check end/exit labels mode (-gnatye), always require the name of
1152   --  a subprogram or package to be present on the END, so this is an error.
1153
1154   procedure No_End_Name (Name : Node_Id) is
1155   begin
1156      if Style_Check_End_Labels then
1157         Error_Msg_Node_1 := Name;
1158         Error_Msg_SP -- CODEFIX
1159           ("(style) `END &` required");
1160      end if;
1161   end No_End_Name;
1162
1163   ------------------
1164   -- No_Exit_Name --
1165   ------------------
1166
1167   --  In check end/exit labels mode (-gnatye), always require the name of
1168   --  the loop to be present on the EXIT when exiting a named loop.
1169
1170   procedure No_Exit_Name (Name : Node_Id) is
1171   begin
1172      if Style_Check_End_Labels then
1173         Error_Msg_Node_1 := Name;
1174         Error_Msg_SP -- CODEFIX
1175           ("(style) `EXIT &` required");
1176      end if;
1177   end No_Exit_Name;
1178
1179   ----------------------------
1180   -- Non_Lower_Case_Keyword --
1181   ----------------------------
1182
1183   --  In check casing mode (-gnatyk), reserved keywords must be spelled
1184   --  in all lower case (excluding keywords range, access, delta and digits
1185   --  used as attribute designators).
1186
1187   procedure Non_Lower_Case_Keyword is
1188   begin
1189      if Style_Check_Keyword_Casing then
1190         Error_Msg_SC -- CODEFIX
1191           ("(style) reserved words must be all lower case");
1192      end if;
1193   end Non_Lower_Case_Keyword;
1194
1195   -----------------------------
1196   -- Require_Following_Space --
1197   -----------------------------
1198
1199   procedure Require_Following_Space is
1200   begin
1201      if Source (Scan_Ptr) > ' ' then
1202         Error_Space_Required (Scan_Ptr);
1203      end if;
1204   end Require_Following_Space;
1205
1206   -----------------------------
1207   -- Require_Preceding_Space --
1208   -----------------------------
1209
1210   procedure Require_Preceding_Space is
1211   begin
1212      if Token_Ptr > Source_First (Current_Source_File)
1213        and then Source (Token_Ptr - 1) > ' '
1214      then
1215         Error_Space_Required (Token_Ptr);
1216      end if;
1217   end Require_Preceding_Space;
1218
1219end Styleg;
1220