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-2012, 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 26with Hostparm; use Hostparm; 27with Opt; use Opt; 28 29package 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; 584end Stylesw; 585