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