gcc/ada/stylesw.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              S T Y L E S W                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2011, 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 with Hostparm; use Hostparm;
  27 with Opt;      use Opt;
  28
  29 package body Stylesw is
  30
  31    --  The following constant defines the default style options for -gnaty
  32
  33    Default_Style : constant String :=
  34                      "3" &  -- indentation level is 3
  35                      "a" &  -- check attribute casing
  36                      "A" &  -- check array attribute indexes
  37                      "b" &  -- check no blanks at end of lines
  38                      "c" &  -- check comment formats
  39                      "e" &  -- check end/exit labels present
  40                      "f" &  -- check no form/feeds vertical tabs in source
  41                      "h" &  -- check no horizontal tabs in source
  42                      "i" &  -- check if-then layout
  43                      "k" &  -- check casing rules for keywords
  44                      "l" &  -- check reference manual layout
  45                      "m" &  -- check line length <= 79 characters
  46                      "n" &  -- check casing of package Standard idents
  47                      "p" &  -- check pragma casing
  48                      "r" &  -- check casing for identifier references
  49                      "s" &  -- check separate subprogram specs present
  50                      "t";   -- check token separation rules
  51
  52    --  The following constant defines the GNAT style options, showing them
  53    --  as additions to the standard default style check options.
  54
  55    GNAT_Style    : constant String := Default_Style &
  56                      "d" &  -- check no DOS line terminators
  57                      "I" &  -- check mode IN
  58                      "S" &  -- check separate lines after THEN or ELSE
  59                      "u" &  -- check no unnecessary blank lines
  60                      "x";   -- check extra parentheses around conditionals
  61
  62    --  Note: we intend GNAT_Style to also include the following, but we do
  63    --  not yet have the whole tool suite clean with respect to this.
  64
  65    --                "B" &  -- check boolean operators
  66
  67    -------------------------------
  68    -- Reset_Style_Check_Options --
  69    -------------------------------
  70
  71    procedure Reset_Style_Check_Options is
  72    begin
  73       Style_Check_Indentation           := 0;
  74       Style_Check_Array_Attribute_Index := False;
  75       Style_Check_Attribute_Casing      := False;
  76       Style_Check_Blanks_At_End         := False;
  77       Style_Check_Blank_Lines           := False;
  78       Style_Check_Boolean_And_Or        := False;
  79       Style_Check_Comments              := False;
  80       Style_Check_DOS_Line_Terminator   := False;
  81       Style_Check_End_Labels            := False;
  82       Style_Check_Form_Feeds            := False;
  83       Style_Check_Horizontal_Tabs       := False;
  84       Style_Check_If_Then_Layout        := False;
  85       Style_Check_Keyword_Casing        := False;
  86       Style_Check_Layout                := False;
  87       Style_Check_Max_Line_Length       := False;
  88       Style_Check_Max_Nesting_Level     := False;
  89       Style_Check_Missing_Overriding    := False;
  90       Style_Check_Mode_In               := False;
  91       Style_Check_Order_Subprograms     := False;
  92       Style_Check_Pragma_Casing         := False;
  93       Style_Check_References            := False;
  94       Style_Check_Separate_Stmt_Lines   := False;
  95       Style_Check_Specs                 := False;
  96       Style_Check_Standard              := False;
  97       Style_Check_Tokens                := False;
  98       Style_Check_Xtra_Parens           := False;
  99    end Reset_Style_Check_Options;
 100
 101    ---------------------
 102    -- RM_Column_Check --
 103    ---------------------
 104
 105    function RM_Column_Check return Boolean is
 106    begin
 107       return Style_Check and Style_Check_Layout;
 108    end RM_Column_Check;
 109
 110    ------------------------------
 111    -- Save_Style_Check_Options --
 112    ------------------------------
 113
 114    procedure Save_Style_Check_Options (Options : out Style_Check_Options) is
 115       P : Natural := 0;
 116
 117       procedure Add (C : Character; S : Boolean);
 118       --  Add given character C to string if switch S is true
 119
 120       procedure Add_Nat (N : Nat);
 121       --  Add given natural number to string
 122
 123       ---------
 124       -- Add --
 125       ---------
 126
 127       procedure Add (C : Character; S : Boolean) is
 128       begin
 129          if S then
 130             P := P + 1;
 131             Options (P) := C;
 132          end if;
 133       end Add;
 134
 135       -------------
 136       -- Add_Nat --
 137       -------------
 138
 139       procedure Add_Nat (N : Nat) is
 140       begin
 141          if N > 9 then
 142             Add_Nat (N / 10);
 143          end if;
 144
 145          P := P + 1;
 146          Options (P) := Character'Val (Character'Pos ('0') + N mod 10);
 147       end Add_Nat;
 148
 149    --  Start of processing for Save_Style_Check_Options
 150
 151    begin
 152       for K in Options'Range loop
 153          Options (K) := ' ';
 154       end loop;
 155
 156       Add (Character'Val (Style_Check_Indentation + Character'Pos ('0')),
 157            Style_Check_Indentation /= 0);
 158
 159       Add ('a', Style_Check_Attribute_Casing);
 160       Add ('A', Style_Check_Array_Attribute_Index);
 161       Add ('b', Style_Check_Blanks_At_End);
 162       Add ('B', Style_Check_Boolean_And_Or);
 163
 164       if Style_Check_Comments_Spacing = 2 then
 165          Add ('c', Style_Check_Comments);
 166       elsif Style_Check_Comments_Spacing = 1 then
 167          Add ('C', Style_Check_Comments);
 168       end if;
 169
 170       Add ('d', Style_Check_DOS_Line_Terminator);
 171       Add ('e', Style_Check_End_Labels);
 172       Add ('f', Style_Check_Form_Feeds);
 173       Add ('h', Style_Check_Horizontal_Tabs);
 174       Add ('i', Style_Check_If_Then_Layout);
 175       Add ('I', Style_Check_Mode_In);
 176       Add ('k', Style_Check_Keyword_Casing);
 177       Add ('l', Style_Check_Layout);
 178       Add ('n', Style_Check_Standard);
 179       Add ('o', Style_Check_Order_Subprograms);
 180       Add ('O', Style_Check_Missing_Overriding);
 181       Add ('p', Style_Check_Pragma_Casing);
 182       Add ('r', Style_Check_References);
 183       Add ('s', Style_Check_Specs);
 184       Add ('S', Style_Check_Separate_Stmt_Lines);
 185       Add ('t', Style_Check_Tokens);
 186       Add ('u', Style_Check_Blank_Lines);
 187       Add ('x', Style_Check_Xtra_Parens);
 188
 189       if Style_Check_Max_Line_Length then
 190          P := P + 1;
 191          Options (P) := 'M';
 192          Add_Nat (Style_Max_Line_Length);
 193       end if;
 194
 195       if Style_Check_Max_Nesting_Level then
 196          P := P + 1;
 197          Options (P) := 'L';
 198          Add_Nat (Style_Max_Nesting_Level);
 199       end if;
 200
 201       pragma Assert (P <= Options'Last);
 202
 203       while P < Options'Last loop
 204          P := P + 1;
 205          Options (P) := ' ';
 206       end loop;
 207    end Save_Style_Check_Options;
 208
 209    -------------------------------------
 210    -- Set_Default_Style_Check_Options --
 211    -------------------------------------
 212
 213    procedure Set_Default_Style_Check_Options is
 214    begin
 215       Reset_Style_Check_Options;
 216       Set_Style_Check_Options (Default_Style);
 217    end Set_Default_Style_Check_Options;
 218
 219    ----------------------------------
 220    -- Set_GNAT_Style_Check_Options --
 221    ----------------------------------
 222
 223    procedure Set_GNAT_Style_Check_Options is
 224    begin
 225       Reset_Style_Check_Options;
 226       Set_Style_Check_Options (GNAT_Style);
 227    end Set_GNAT_Style_Check_Options;
 228
 229    -----------------------------
 230    -- Set_Style_Check_Options --
 231    -----------------------------
 232
 233    --  Version used when no error checking is required
 234
 235    procedure Set_Style_Check_Options (Options : String) is
 236       OK : Boolean;
 237       EC : Natural;
 238       pragma Warnings (Off, EC);
 239    begin
 240       Set_Style_Check_Options (Options, OK, EC);
 241       pragma Assert (OK);
 242    end Set_Style_Check_Options;
 243
 244    --  Normal version with error checking
 245
 246    procedure Set_Style_Check_Options
 247      (Options  : String;
 248       OK       : out Boolean;
 249       Err_Col  : out Natural)
 250    is
 251       C : Character;
 252
 253       On : Boolean := True;
 254       --  Set to False if minus encountered
 255       --  Set to True if plus encountered
 256
 257       Last_Option : Character := ' ';
 258       --  Set to last character encountered
 259
 260       procedure Add_Img (N : Natural);
 261       --  Concatenates image of N at end of Style_Msg_Buf
 262
 263       procedure Bad_Style_Switch (Msg : String);
 264       --  Called if bad style switch found. Msg is set in Style_Msg_Buf and
 265       --  Style_Msg_Len. OK is set False.
 266
 267       -------------
 268       -- Add_Img --
 269       -------------
 270
 271       procedure Add_Img (N : Natural) is
 272       begin
 273          if N >= 10 then
 274             Add_Img (N / 10);
 275          end if;
 276
 277          Style_Msg_Len := Style_Msg_Len + 1;
 278          Style_Msg_Buf (Style_Msg_Len) :=
 279            Character'Val (N mod 10 + Character'Pos ('0'));
 280       end Add_Img;
 281
 282       ----------------------
 283       -- Bad_Style_Switch --
 284       ----------------------
 285
 286       procedure Bad_Style_Switch (Msg : String) is
 287       begin
 288          OK := False;
 289          Style_Msg_Len := Msg'Length;
 290          Style_Msg_Buf (1 .. Style_Msg_Len) := Msg;
 291       end Bad_Style_Switch;
 292
 293    --  Start of processing for Set_Style_Check_Options
 294
 295    begin
 296       Err_Col := Options'First;
 297       while Err_Col <= Options'Last loop
 298          C := Options (Err_Col);
 299          Last_Option := C;
 300          Err_Col := Err_Col + 1;
 301
 302          --  Turning switches on
 303
 304          if On then
 305             case C is
 306
 307             when '+' =>
 308                null;
 309
 310             when '-' =>
 311                On := False;
 312
 313             when '0' .. '9' =>
 314                Style_Check_Indentation :=
 315                  Character'Pos (C) - Character'Pos ('0');
 316
 317             when 'a' =>
 318                Style_Check_Attribute_Casing      := True;
 319
 320             when 'A' =>
 321                Style_Check_Array_Attribute_Index := True;
 322
 323             when 'b' =>
 324                Style_Check_Blanks_At_End         := True;
 325
 326             when 'B' =>
 327                Style_Check_Boolean_And_Or        := True;
 328
 329             when 'c' =>
 330                Style_Check_Comments              := True;
 331                Style_Check_Comments_Spacing      := 2;
 332
 333             when 'C' =>
 334                Style_Check_Comments              := True;
 335                Style_Check_Comments_Spacing      := 1;
 336
 337             when 'd' =>
 338                Style_Check_DOS_Line_Terminator   := True;
 339
 340             when 'e' =>
 341                Style_Check_End_Labels            := True;
 342
 343             when 'f' =>
 344                Style_Check_Form_Feeds            := True;
 345
 346             when 'g' =>
 347                Set_GNAT_Style_Check_Options;
 348
 349             when 'h' =>
 350                Style_Check_Horizontal_Tabs       := True;
 351
 352             when 'i' =>
 353                Style_Check_If_Then_Layout        := True;
 354
 355             when 'I' =>
 356                Style_Check_Mode_In               := True;
 357
 358             when 'k' =>
 359                Style_Check_Keyword_Casing        := True;
 360
 361             when 'l' =>
 362                Style_Check_Layout                := True;
 363
 364             when 'L' =>
 365                Style_Max_Nesting_Level := 0;
 366
 367                if Err_Col > Options'Last
 368                  or else Options (Err_Col) not in '0' .. '9'
 369                then
 370                   Bad_Style_Switch ("invalid nesting level");
 371                   return;
 372                end if;
 373
 374                loop
 375                   Style_Max_Nesting_Level :=
 376                     Style_Max_Nesting_Level * 10 +
 377                       Character'Pos (Options (Err_Col)) - Character'Pos ('0');
 378
 379                   if Style_Max_Nesting_Level > 999 then
 380                      Bad_Style_Switch
 381                        ("max nesting level (999) exceeded in style check");
 382                      return;
 383                   end if;
 384
 385                   Err_Col := Err_Col + 1;
 386                   exit when Err_Col > Options'Last
 387                     or else Options (Err_Col) not in '0' .. '9';
 388                end loop;
 389
 390                Style_Check_Max_Nesting_Level := Style_Max_Nesting_Level /= 0;
 391
 392             when 'm' =>
 393                Style_Check_Max_Line_Length       := True;
 394                Style_Max_Line_Length             := 79;
 395
 396             when 'M' =>
 397                Style_Max_Line_Length             := 0;
 398
 399                if Err_Col > Options'Last
 400                  or else Options (Err_Col) not in '0' .. '9'
 401                then
 402                   Bad_Style_Switch
 403                     ("invalid line length in style check");
 404                   return;
 405                end if;
 406
 407                loop
 408                   Style_Max_Line_Length :=
 409                     Style_Max_Line_Length * 10 +
 410                       Character'Pos (Options (Err_Col)) - Character'Pos ('0');
 411
 412                   if Style_Max_Line_Length > Int (Max_Line_Length) then
 413                      OK := False;
 414                      Style_Msg_Buf (1 .. 27) := "max line length allowed is ";
 415                      Style_Msg_Len := 27;
 416                      Add_Img (Natural (Max_Line_Length));
 417                      return;
 418                   end if;
 419
 420                   Err_Col := Err_Col + 1;
 421                   exit when Err_Col > Options'Last
 422                     or else Options (Err_Col) not in '0' .. '9';
 423                end loop;
 424
 425                Style_Check_Max_Line_Length       := Style_Max_Line_Length /= 0;
 426
 427             when 'n' =>
 428                Style_Check_Standard              := True;
 429
 430             when 'N' =>
 431                Reset_Style_Check_Options;
 432
 433             when 'o' =>
 434                Style_Check_Order_Subprograms     := True;
 435
 436             when 'O' =>
 437                Style_Check_Missing_Overriding    := True;
 438
 439             when 'p' =>
 440                Style_Check_Pragma_Casing         := True;
 441
 442             when 'r' =>
 443                Style_Check_References            := True;
 444
 445             when 's' =>
 446                Style_Check_Specs                 := True;
 447
 448             when 'S' =>
 449                Style_Check_Separate_Stmt_Lines   := True;
 450
 451             when 't' =>
 452                Style_Check_Tokens                := True;
 453
 454             when 'u' =>
 455                Style_Check_Blank_Lines           := True;
 456
 457             when 'x' =>
 458                Style_Check_Xtra_Parens           := True;
 459
 460             when 'y' =>
 461                Set_Default_Style_Check_Options;
 462
 463             when ' ' =>
 464                null;
 465
 466             when others =>
 467                Err_Col := Err_Col - 1;
 468                Bad_Style_Switch ("invalid style switch: " & C);
 469                return;
 470             end case;
 471
 472          --  Turning switches off
 473
 474          else
 475             case C is
 476
 477             when '+' =>
 478                On := True;
 479
 480             when '-' =>
 481                null;
 482
 483             when '0' .. '9' =>
 484                Style_Check_Indentation := 0;
 485
 486             when 'a' =>
 487                Style_Check_Attribute_Casing      := False;
 488
 489             when 'A' =>
 490                Style_Check_Array_Attribute_Index := False;
 491
 492             when 'b' =>
 493                Style_Check_Blanks_At_End         := False;
 494
 495             when 'B' =>
 496                Style_Check_Boolean_And_Or        := False;
 497
 498             when 'c' | 'C' =>
 499                Style_Check_Comments              := False;
 500
 501             when 'd' =>
 502                Style_Check_DOS_Line_Terminator   := False;
 503
 504             when 'e' =>
 505                Style_Check_End_Labels            := False;
 506
 507             when 'f' =>
 508                Style_Check_Form_Feeds            := False;
 509
 510             when 'g' =>
 511                Reset_Style_Check_Options;
 512
 513             when 'h' =>
 514                Style_Check_Horizontal_Tabs       := False;
 515
 516             when 'i' =>
 517                Style_Check_If_Then_Layout        := False;
 518
 519             when 'I' =>
 520                Style_Check_Mode_In               := False;
 521
 522             when 'k' =>
 523                Style_Check_Keyword_Casing        := False;
 524
 525             when 'l' =>
 526                Style_Check_Layout                := False;
 527
 528             when 'L' =>
 529                Style_Max_Nesting_Level := 0;
 530
 531             when 'm' =>
 532                Style_Check_Max_Line_Length       := False;
 533
 534             when 'M' =>
 535                Style_Max_Line_Length             := 0;
 536                Style_Check_Max_Line_Length       := False;
 537
 538             when 'n' =>
 539                Style_Check_Standard              := False;
 540
 541             when 'o' =>
 542                Style_Check_Order_Subprograms     := False;
 543
 544             when 'O' =>
 545                Style_Check_Missing_Overriding    := False;
 546
 547             when 'p' =>
 548                Style_Check_Pragma_Casing         := False;
 549
 550             when 'r' =>
 551                Style_Check_References            := False;
 552
 553             when 's' =>
 554                Style_Check_Specs                 := False;
 555
 556             when 'S' =>
 557                Style_Check_Separate_Stmt_Lines   := False;
 558
 559             when 't' =>
 560                Style_Check_Tokens                := False;
 561
 562             when 'u' =>
 563                Style_Check_Blank_Lines           := False;
 564
 565             when 'x' =>
 566                Style_Check_Xtra_Parens           := False;
 567
 568             when ' ' =>
 569                null;
 570
 571             when others =>
 572                Err_Col := Err_Col - 1;
 573                Bad_Style_Switch ("invalid style switch: " & C);
 574                return;
 575             end case;
 576          end if;
 577       end loop;
 578
 579       --  Turn on style checking if other than N at end of string
 580
 581       Style_Check := (Last_Option /= 'N');
 582       OK := True;
 583    end Set_Style_Check_Options;
 584 end Stylesw;