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