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-2019, 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