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