1---------------------------------------------------------------------- 2-- Framework.Language - Package body -- 3-- -- 4-- This software is (c) The European Organisation for the Safety -- 5-- of Air Navigation (EUROCONTROL) and Adalog 2004-2005. The Ada -- 6-- Controller is free software; you can redistribute it and/or -- 7-- modify it under terms of the GNU General Public License as -- 8-- published by the Free Software Foundation; either version 2, or -- 9-- (at your option) any later version. This unit is distributed -- 10-- in the hope that it will be useful, but WITHOUT ANY WARRANTY; -- 11-- without even the implied warranty of MERCHANTABILITY or FITNESS -- 12-- FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 13-- for more details. You should have received a copy of the GNU -- 14-- General Public License distributed with this program; see file -- 15-- COPYING. If not, write to the Free Software Foundation, 59 -- 16-- Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- 17-- -- 18-- As a special exception, if other files instantiate generics -- 19-- from the units of this program, or if you link this unit with -- 20-- other files to produce an executable, this unit does not by -- 21-- itself cause the resulting executable to be covered by the GNU -- 22-- General Public License. This exception does not however -- 23-- invalidate any other reasons why the executable file might be -- 24-- covered by the GNU Public License. -- 25-- -- 26-- This software is distributed in the hope that it will be -- 27-- useful, but WITHOUT ANY WARRANTY; without even the implied -- 28-- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -- 29-- PURPOSE. -- 30---------------------------------------------------------------------- 31 32---------------------------------------------------------------------- 33-- !!! WARNING !!! -- 34-- -- 35-- This package must be the target of a pragma Elaborate -- 36-- for all rules that instantiate one of its generics. -- 37-- -- 38-- Therefore, this package must not contain a statement part, nor -- 39-- call any outer function (or instantiate any generic) as part -- 40-- of the elaboration of its declarations. -- 41-- -- 42-- The package cannot be made preelaborable due to dependencies -- 43-- to non-preelaborable units. -- 44-- -- 45-- (and if you don't understand what this stuff is about, just -- 46-- stick to the rule!) -- 47---------------------------------------------------------------------- 48 49-- Ada 50with 51 Ada.Characters.Handling, 52 Ada.Exceptions, 53 Ada.Strings.Wide_Fixed; 54 55-- Adactl 56with 57 Adactl_Options, 58 Framework.Language.Commands, 59 Framework.Language.Scanner, 60 Framework.Rules_Manager, 61 Framework.Variables.Shared_Types; 62package body Framework.Language is 63 use Framework.Language.Scanner, Utilities; 64 65 -- Algorithm 66 -- 67 -- This is a classical recursive descent parser, following the grammar given in the specification. 68 -- Invariant: 69 -- when a parsing subprogram is called, the current token is the first one it has to care about 70 -- when a parsing subprogram is left, it leaves in the current token the first one that is not for it. 71 72 ------------------------------------------------------ 73 -- Internal utilities -- 74 ------------------------------------------------------ 75 76 In_Parameters : Boolean := False; 77 Last_Was_Go : Boolean := True; 78 -- False if any "controlling" command (check, search, count, set) has been entered 79 -- since the last go command. 80 81 82 -- Invariants for the following parsing functions: 83 -- On entrance, Current_Token is the first token of the corresponding syntax 84 -- This is checked by the function itself, not the caller. 85 -- On exit, Current_Token is the first token not in the corresponding syntax 86 87 -------------------- 88 -- Next_Parameter -- 89 -------------------- 90 91 procedure Next_Parameter is 92 begin 93 case Current_Token.Kind is 94 when Comma => 95 Next_Token; 96 -- In_Parameters remains True 97 when Right_Parenthesis => 98 Next_Token; 99 In_Parameters := False; 100 when others => 101 Syntax_Error ("',' or ')' expected after parameter", Current_Token.Position); 102 end case; 103 end Next_Parameter; 104 105 ------------------- 106 -- Get_Rule_Name -- 107 ------------------- 108 109 function Get_Rule_Name (Allow_All : Boolean := False) return Wide_String is 110 use Framework.Rules_Manager; 111 begin 112 if Current_Token.Kind /= Name then 113 Syntax_Error ("Rule identifier expected", Current_Token.Position); 114 end if; 115 116 declare 117 Result : constant Wide_String := To_Upper (Image (Current_Token)); 118 begin 119 if not Is_Rule_Name (Result) and then not (Allow_All and Result = "ALL") then 120 Syntax_Error ("Not a rule name: " & Result, Current_Token.Position); 121 end if; 122 123 Next_Token; 124 if Current_Token.Kind = Left_Parenthesis then 125 Next_Token; 126 In_Parameters := True; 127 end if; 128 return Result; 129 end; 130 end Get_Rule_Name; 131 132 ------------------- 133 -- Close_Command -- 134 ------------------- 135 136 procedure Close_Command is 137 begin 138 if Current_Token.Kind /= Semi_Colon then 139 Syntax_Error ("Semi-colon expected", Current_Token.Position); 140 end if; 141 142 Activate_Prompt; 143 Next_Token; 144 end Close_Command; 145 146 ------------- 147 -- Compile -- 148 ------------- 149 150 procedure Compile is 151 use Rules_Manager, Framework.Language.Commands, Framework.Variables, Framework.Variables.Shared_Types; 152 153 procedure Process_Error (Occur : Ada.Exceptions.Exception_Occurrence) is 154 use Ada.Exceptions, Ada.Characters.Handling; 155 begin 156 User_Message (To_Wide_String (Exception_Message (Occur))); 157 Rule_Error_Occurred := True; 158 -- Ignore till next semi-colon (or Eof) 159 In_Parameters := False; 160 loop 161 case Current_Token.Kind is 162 when Semi_Colon => 163 Close_Command; 164 exit; 165 when Eof => 166 exit; 167 when others => 168 begin 169 Next_Token (No_Delay => True); 170 exception 171 when User_Error => 172 -- Encountered bad characters => Ignore 173 null; 174 end; 175 end case; 176 end loop; 177 end Process_Error; 178 179 procedure Process_Controls (Label : in Wide_String) is 180 -- Only controls (or '(') can follow a label 181 begin 182 if Label /= "" then 183 Next_Token; 184 if Current_Token.Kind /= Colon then 185 if Current_Token.Kind = Name and then Current_Token.Key in Type_Keys then 186 Syntax_Error ("Missing "":"" after label", Current_Token.Position); 187 else 188 Syntax_Error ("Unknown command " & Label, Current_Token.Position); 189 end if; 190 end if; 191 Next_Token; 192 end if; 193 194 loop 195 if Current_Token.Kind /= Name then 196 Syntax_Error ("Unexpected element for control", Current_Token.Position); 197 end if; 198 199 case Current_Token.Key is 200 when Key_Check => 201 Next_Token; 202 Add_Control (Label, Check, Get_Rule_Name); 203 when Key_Search => 204 Next_Token; 205 Add_Control (Label, Search, Get_Rule_Name); 206 when Key_Count => 207 Next_Token; 208 Add_Control (Label, Count, Get_Rule_Name); 209 when others => 210 Syntax_Error ("Only ""Check"", ""Search"", or ""Count"" allowed for control", 211 Current_Token.Position); 212 end case; 213 214 if Current_Token.Kind /= Comma then 215 Close_Command; 216 exit; 217 end if; 218 219 Next_Token; 220 end loop; 221 Last_Was_Go := False; 222 end Process_Controls; 223 224 begin -- Compile 225 -- Set up initial token 226 begin 227 Next_Token (No_Delay => True); 228 -- No_Delay is true to get the error here if there is a parse error in the first token 229 exception 230 when Occur : Utilities.User_Error => 231 Process_Error (Occur); 232 end; 233 234 loop 235 begin 236 case Current_Token.Kind is 237 when Eof => 238 exit; 239 240 when Name => 241 case Current_Token.Key is 242 when Key_Check => 243 Process_Controls (""); 244 245 when Key_Clear => 246 Next_Token; 247 if Current_Token.Kind /= Name then 248 Syntax_Error ("""all"" or Rule name expected", Current_Token.Position); 249 end if; 250 251 if Current_Token.Key = Key_All then 252 Next_Token; 253 Close_Command; 254 255 Command_All (Clear); 256 257 else 258 loop 259 Command (Image (Current_Token), Clear); 260 Next_Token; 261 exit when Current_Token.Kind /= Comma; 262 Next_Token; 263 if Current_Token.Kind /= Name then 264 Syntax_Error ("Rule name expected", Current_Token.Position); 265 end if; 266 end loop; 267 Close_Command; 268 end if; 269 270 when Key_Count => 271 Process_Controls (""); 272 273 when Key_Go => 274 Next_Token; 275 Close_Command; 276 Last_Was_Go := True; 277 278 Go_Command; 279 280 when Key_Help => 281 Next_Token (Force_String => True); 282 if Current_Token.Kind = Semi_Colon then 283 Close_Command; 284 285 Help_Command ("COMMANDS"); 286 Help_Command ("RULES"); 287 else 288 -- The simpler solution is to provide help messages as parameters are parsed, 289 -- but this gives unpleasant behaviour in interactive mode when there is a 290 -- syntax error. Therefore, we first accumulate names, then give all helps. 291 declare 292 use Ada.Strings, Ada.Strings.Wide_Fixed; 293 Line : constant Wide_String := Image (Current_Token); 294 Start : Natural := Line'First; 295 Stop : Natural; 296 Inx : Rules_Count := 0; 297 Rule_Names : array (Rules_Count range 1 .. Number_Of_Rules) of Unbounded_Wide_String; 298 begin 299 loop 300 if Inx = Rule_Names'Last then 301 -- This can happen only if the user specified the same rule 302 -- several times, and listed more names than there are rules (or used 303 -- some of the special keywords in addition to rule names). 304 -- Extremely unlikely in practice, but not a reason for not being careful... 305 Syntax_Error ("Too many rule names in ""Help"" command", Current_Token.Position); 306 end if; 307 Inx := Inx + 1; 308 Stop := Index (Line, ",", From => Start); 309 if Stop = 0 then 310 Stop := Line'Last+1; 311 end if; 312 Rule_Names (Inx) := To_Unbounded_Wide_String (Trim (Line (Start .. Stop-1), Both)); 313 Start := Stop + 1; 314 exit when Start > Line'Last; 315 end loop; 316 Next_Token; 317 318 Help_Command (To_Wide_String (Rule_Names (1))); 319 for I in Rules_Count range 2 .. Inx loop 320 User_Message ("----"); 321 Help_Command (To_Wide_String (Rule_Names (I))); 322 end loop; 323 324 -- Note: Close command *after* providing help, since in case of errors 325 -- we assume that the command is not yet closed (see handler) 326 Close_Command; 327 end; 328 end if; 329 330 when Key_Inhibit => 331 Next_Token; 332 333 Inhibit_Command (Get_Rule_Name (Allow_All => True)); 334 Close_Command; 335 336 when Key_Message => 337 Next_Token; 338 if Current_Token.Kind /= String_Value then 339 Syntax_Error ("Message string expected", Current_Token.Position); 340 end if; 341 declare 342 Mess : constant Wide_String := Image (Current_Token); 343 With_Pause : Boolean; 344 begin 345 Next_Token; 346 if Is_String (Current_Token, "PAUSE") then 347 With_Pause := True; 348 Next_Token; 349 else 350 With_Pause := False; 351 end if; 352 Close_Command; 353 354 Message_Command (Mess, With_Pause); 355 end; 356 357 when Key_Quit => 358 Next_Token; 359 Close_Command; 360 exit; 361 362 when Key_Search => 363 Process_Controls (""); 364 365 when Key_Set => 366 Next_Token; 367 if Current_Token.Kind /= Name then 368 Syntax_Error ("Variable name expected", Current_Token.Position); 369 end if; 370 371 declare 372 Option : constant Wide_String := To_Upper (Image (Current_Token)); 373 begin 374 -- Special options: file name, requires Next_Token (Force_String => True) 375 if Option = "OUTPUT" or Option = "NEW_OUTPUT" then 376 Next_Token (Force_String => True); 377 if Current_Token.Kind /= Name then 378 Syntax_Error ("File name expected", Current_Token.Position); 379 end if; 380 declare 381 Output : constant Wide_String := Image (Current_Token); 382 begin 383 Next_Token; 384 Close_Command; 385 386 Set_Output_Command (Output, Force_Overwrite => Option = "NEW_OUTPUT"); 387 end; 388 389 elsif Option = "TRACE" then 390 Next_Token (Force_String => True); 391 if Current_Token.Kind /= Name then 392 Syntax_Error ("File name expected", Current_Token.Position); 393 end if; 394 declare 395 Trace : constant Wide_String := Image (Current_Token); 396 begin 397 Next_Token; 398 Close_Command; 399 400 Set_Trace_Command (Trace); 401 end; 402 403 else -- Not file options, regular variables 404 Next_Token; 405 406 if Current_Token.Kind = Period then 407 -- Rule variable 408 Next_Token; 409 if Current_Token.Kind /= Name then 410 Syntax_Error ("Variable name expected", Current_Token.Position); 411 end if; 412 declare 413 Variable : constant Wide_String := Image (Current_Token); 414 begin 415 Next_Token; 416 if Current_Token.Kind in Value_Token_Kind then 417 Set_Variable (Variable => Option & '.' & Variable, 418 Val => Image (Current_Token)); 419 Next_Token; 420 else -- default 421 Set_Variable (Variable => Option & '.' & Variable, 422 Val => ""); 423 end if; 424 exception 425 when No_Such_Variable => 426 Syntax_Error ("Unknown variable " & Option & '.' & Variable, 427 Current_Token.Position); 428 when Constraint_Error => 429 Syntax_Error ("Illegal value for " & Option & '.' & Variable, 430 Current_Token.Position); 431 end; 432 else 433 begin 434 if Current_Token.Kind in Value_Token_Kind then 435 Set_Variable (Variable => Option, 436 Val => Image (Current_Token)); 437 Next_Token; 438 else -- default 439 Set_Variable (Variable => Option, 440 Val => ""); 441 end if; 442 exception 443 when No_Such_Variable => 444 Syntax_Error ("Unknown variable " & Option, 445 Current_Token.Position); 446 when Constraint_Error => 447 Syntax_Error ("Illegal value for " & Option, 448 Current_Token.Position); 449 end; 450 end if; 451 452 Close_Command; 453 end if; 454 end; 455 Last_Was_Go := False; 456 457 -- Mirror Debug and Verbose options 458 Utilities.Debug_Option := Adactl_Options.Debug_Option.Value = On; 459 Utilities.Verbose_Option := Adactl_Options.Verbose_Option.Value = On; 460 461 when Key_Source => 462 Next_Token (Force_String => True); 463 if Current_Token.Kind /= Name then 464 Syntax_Error ("File name expected", Current_Token.Position); 465 end if; 466 467 declare 468 Source : constant Wide_String := Image (Current_Token); 469 Pos : constant Location := Current_Token.Position; 470 Success : Boolean; 471 begin 472 Next_Token; 473 if (Source (1) = '/' or Source (1) = '\') 474 or else (Source'Length >= 3 475 and then Source (2) = ':' 476 and then (Source (3) = '/' or Source (3) = '\')) 477 then 478 -- Absolute path 479 Source_Command (Source, Success); 480 else 481 -- Try it relative to the current file 482 Source_Command (Reference_Dir & Source, Success); 483 if not Success then 484 -- Try it from path 485 declare 486 Path_Source : constant Wide_String := Locate_Regular_File (Source, "ADACTL_PATH"); 487 begin 488 if Path_Source /= "" then 489 Source_Command (Path_Source, Success); 490 end if; 491 end; 492 end if; 493 end if; 494 495 if Success then 496 Close_Command; 497 else 498 Syntax_Error ("Sourced file " & Source & " not found", Pos); 499 end if; 500 end; 501 502 when Not_A_Key 503 | Profile_Keys -- Profile keys allowed as labels 504 => 505 -- Must be a label 506 Process_Controls (Image (Current_Token)); 507 end case; 508 509 when String_Value => 510 Process_Controls (Image (Current_Token)); 511 512 when others => 513 Syntax_Error ("Command or label expected", Current_Token.Position); 514 end case; 515 exception 516 when Occur : Utilities.User_Error => 517 Process_Error (Occur); 518 end; 519 end loop; 520 end Compile; 521 522 --------------------------------- 523 -- Common_Enumerated_Utilities -- 524 --------------------------------- 525 526 generic 527 type Flags is (<>); 528 Prefix : Wide_String := ""; 529 Box_Pos : in Integer := -1; -- 'Pos of the modifier that corresponds to "<>", or -1 if none 530 Pars_Pos : in Integer := -1; -- 'Pos of the modifier that corresponds to "()", or -1 if none 531 package Common_Enumerated_Utilities is 532 function Image (Item : Flags; In_Case : Utilities.Casing := Utilities.Upper_Case) return Wide_String; 533 534 type Flag_Set is array (Flags) of Boolean; 535 procedure Help_On_Flags (Header : Wide_String := ""; 536 Footer : Wide_String := ""; 537 Extra_Value : Wide_String := "NONE"; 538 Expected : Flag_Set := (others => True)); 539 end Common_Enumerated_Utilities; 540 541 package body Common_Enumerated_Utilities is 542 function Image (Item : Flags; In_Case : Utilities.Casing := Utilities.Upper_Case) return Wide_String is 543 Img : constant Wide_String := Flags'Wide_Image (Item); 544 begin 545 -- Remove prefix and adjust case 546 if Flags'Pos (Item) = Box_Pos then 547 return "<>"; 548 elsif Flags'Pos (Item) = Pars_Pos then 549 return "()"; 550 elsif In_Case = Upper_Case then -- Already upper case 551 return Img (Prefix'Length + 1 .. Img'Last); 552 else 553 return Set_Casing (Img (Prefix'Length + 1 .. Img'Last), In_Case); 554 end if; 555 end Image; 556 557 procedure Help_On_Flags (Header : Wide_String := ""; 558 Footer : Wide_String := ""; 559 Extra_Value : Wide_String := "NONE"; 560 Expected : Flag_Set := (others => True)) 561 is 562 -- Pretty print of values of flags. 563 -- Values are arranged in columns. 564 -- The number of columns is computed assuming that each column is True_Width wide, 565 -- except for the first one that can contain Extra_Value if provided. 566 -- then the actual width is adjusted to what is actually needed, to make it prettier 567 -- looking. 568 -- However, if the previous (pessimistic) computation would give only one column, 569 -- we force the number of columns to 2, and see if it fits with actual lengths. 570 -- If not, we force back the number of columns to 1. 571 -- More sophisticated optimization would be overkill. 572 Display_Width : constant := 79; 573 True_Width : constant Natural := Flags'Width - Prefix'Length; 574 575 function Default_Nb_Col return Positive is 576 begin 577 if Extra_Value = "NONE" or Extra_Value = "" then 578 return Natural'Max (2, 1 + (Display_Width - Header'Length 579 - True_Width - 3 -- Width of 1st col 580 ) / (True_Width + 3)); -- 3 => " | " 581 else 582 return Natural'Max (2, 1 + (Display_Width - Header'Length 583 - Natural'Max (True_Width, Extra_Value'Length) - 3 -- Width of 1st col 584 ) / (True_Width + 3)); -- 3 => " | " 585 586 end if; 587 end Default_Nb_Col; 588 589 Buffer : Wide_String (1 .. Display_Width); 590 Index : Natural; 591 Nb_Col : Natural := Default_Nb_Col; 592 Col_Widthes : array (1 .. Nb_Col) of Natural := (others => 0); 593 Current_Col : Natural; 594 First_Flag : Flags; 595 Last_Flag : Flags; 596 begin -- Help_On_Flags 597 if Extra_Value = "NONE" then 598 Current_Col := 1; 599 First_Flag := Flags'First; 600 elsif Extra_Value = "" then 601 Current_Col := 1; 602 First_Flag := Flags'Succ (Flags'First); 603 else 604 Col_Widthes (1) := Extra_Value'Length; 605 Current_Col := 2; 606 First_Flag := Flags'Succ (Flags'First); 607 end if; 608 609 -- We assume here that Expected /= Empty_Set (not worth checking) 610 for I in reverse Expected'Range loop 611 if Expected (I) then 612 Last_Flag := I; 613 exit; 614 end if; 615 end loop; 616 617 for F in Flags range First_Flag .. Last_Flag loop 618 if Expected (F) then 619 declare 620 Length : constant Natural := Image (F)'Length; 621 begin 622 if Length > Col_Widthes (Current_Col) then 623 Col_Widthes (Current_Col) := Length; 624 end if; 625 if Current_Col = Nb_Col then 626 Current_Col := 1; 627 else 628 Current_Col := Current_Col + 1; 629 end if; 630 end; 631 end if; 632 end loop; 633 634 -- 2 colums: it may have been forced, check if it fits 635 if Nb_Col = 2 636 and then Header'Length 637 + Col_Widthes (1) + 3 638 + Col_Widthes (2) + 3 > Display_Width 639 then 640 Nb_Col := 1; 641 if Extra_Value = "NONE" then 642 Col_Widthes (1) := True_Width; 643 else 644 Col_Widthes (1) := Natural'Max (True_Width, Extra_Value'Length); 645 end if; 646 end if; 647 648 Buffer := (others => ' '); 649 Buffer (1 .. Header'Length) := Header; 650 Index := Header'Length; 651 652 Current_Col := 1; 653 if Extra_Value = "NONE" then 654 First_Flag := Flags'First; 655 elsif Extra_Value = "" then 656 First_Flag := Flags'Succ (Flags'First); 657 else 658 Index := Index + 1; -- Add space 659 Buffer (Index + 1 .. Index + Extra_Value'Length) := Extra_Value; 660 Index := Index + Col_Widthes (Current_Col) + 1; 661 662 Buffer (Index + 1) := '|'; 663 Index := Index + 1; 664 665 if Nb_Col = 1 then 666 User_Message (Buffer (1 .. Index)); 667 Current_Col := 1; 668 Buffer := (others => ' '); 669 Index := Header'Length; 670 else 671 Current_Col := 2; 672 end if; 673 674 -- Gnat warns about Constraint_Error being raised by the following statement 675 -- when instantiated with a Flag type that has only one value. 676 -- But in this case, Extra_Value must be "NONE", so it is OK. 677 pragma Warnings (Off); 678 First_Flag := Flags'Succ (Flags'First); 679 pragma Warnings (On); 680 end if; 681 682 for I in Flags range First_Flag .. Last_Flag loop 683 if Expected (I) then 684 declare 685 Img : constant Wide_String := Image (I, Lower_Case); 686 begin 687 Index := Index + 1; -- Add space 688 689 Buffer (Index + 1 .. Index + Img'Length) := Img; 690 if I = Last_Flag then 691 Index := Index + Img'Length; 692 User_Message (Buffer (1 .. Index)); 693 exit; 694 end if; 695 696 Index := Index + Col_Widthes (Current_Col) + 1; 697 Buffer (Index + 1) := '|'; 698 Index := Index + 1; 699 700 if Current_Col = Nb_Col then 701 User_Message (Buffer (1 .. Index)); 702 Current_Col := 1; 703 Buffer := (others => ' '); 704 Index := Header'Length; 705 else 706 Current_Col := Current_Col + 1; 707 end if; 708 end; 709 end if; 710 end loop; 711 712 if Footer /= "" then 713 User_Message ((1 .. Header'Length + 1 => ' ') & Footer); 714 end if; 715 end Help_On_Flags; 716 end Common_Enumerated_Utilities; 717 718 ------------------------------------------------------ 719 -- Exported subprograms -- 720 ------------------------------------------------------ 721 722 ------------- 723 -- Execute -- 724 ------------- 725 726 procedure Execute (Command_String : Wide_String) is 727 begin 728 Set_Prompt (""); 729 Start_Scan (From_String => True, Source => Command_String); 730 Compile; 731 end Execute; 732 733 --------------------- 734 -- Source_Location -- 735 --------------------- 736 737 function Source_Location return Location is 738 begin 739 return Current_Token.Position; 740 end Source_Location; 741 742 ---------------------- 743 -- Parameter_Exists -- 744 ---------------------- 745 746 function Parameter_Exists return Boolean is 747 begin 748 return In_Parameters; 749 end Parameter_Exists; 750 751 -------------------------- 752 -- Is_Integer_Parameter -- 753 -------------------------- 754 755 function Is_Integer_Parameter return Boolean is 756 begin 757 if not In_Parameters then 758 Failure ("Is_Integer_Parameter called when not in parameters"); 759 end if; 760 761 return Current_Token.Kind = Integer_Value; 762 end Is_Integer_Parameter; 763 764 ------------------------ 765 -- Is_Float_Parameter -- 766 ------------------------ 767 768 function Is_Float_Parameter return Boolean is 769 begin 770 if not In_Parameters then 771 Failure ("Is_Float_Parameter called when not in parameters"); 772 end if; 773 774 return Current_Token.Kind = Float_Value; 775 end Is_Float_Parameter; 776 777 ------------------------ 778 -- Is_String_Parameter -- 779 ------------------------ 780 781 function Is_String_Parameter return Boolean is 782 begin 783 if not In_Parameters then 784 Failure ("Is_Sting_Parameter called when not in parameters"); 785 end if; 786 787 return Current_Token.Kind = String_Value; 788 end Is_String_Parameter; 789 790 --------------------------- 791 -- Get_Integer_Parameter -- 792 --------------------------- 793 794 function Get_Integer_Parameter (Min : Thick_Queries.Biggest_Int := Thick_Queries.Biggest_Int'First; 795 Max : Thick_Queries.Biggest_Int := Thick_Queries.Biggest_Int'Last) 796 return Thick_Queries.Biggest_Int 797 is 798 use Thick_Queries; 799 begin 800 if not In_Parameters then 801 Failure ("Get_Integer_Parameter called when not in parameters"); 802 end if; 803 804 case Current_Token.Kind is 805 when Integer_Value => 806 declare 807 Result : constant Biggest_Int := Current_Token.Value; 808 begin 809 Next_Token; 810 Next_Parameter; 811 if Result not in Min .. Max then 812 if Max = Biggest_Int'Last then 813 Syntax_Error ("Parameter must be >= " 814 & Biggest_Int_Img (Min), 815 Current_Token.Position); 816 elsif Min = Biggest_Int'First then 817 Syntax_Error ("Parameter must be <= " 818 & Biggest_Int_Img (Max), 819 Current_Token.Position); 820 else 821 Syntax_Error ("Parameter must be in range " 822 & Biggest_Int_Img (Min) 823 & " .. " 824 & Biggest_Int_Img (Max), 825 Current_Token.Position); 826 end if; 827 end if; 828 return Result; 829 end; 830 when Float_Value => 831 Syntax_Error ("Integer value expected", Current_Token.Position); 832 when Bad_Integer => 833 Syntax_Error ("Bad integer value (too many digits?)", Current_Token.Position); 834 when Name | Bad_Float => 835 Syntax_Error ("Integer parameter expected", Current_Token.Position); 836 when others => 837 Syntax_Error ("Parameter expected", Current_Token.Position); 838 end case; 839 end Get_Integer_Parameter; 840 841 function Get_Integer_Parameter (Min : Asis.ASIS_Integer := Asis.ASIS_Integer'First; 842 Max : Asis.ASIS_Integer := Asis.ASIS_Integer'Last) 843 return Asis.ASIS_Integer 844 is 845 use Thick_Queries; 846 use type Asis.ASIS_Integer; -- Gela-ASIS compatibility 847 Result : constant Biggest_Int := Get_Integer_Parameter; 848 begin 849 if Result not in Biggest_Int (Min) .. Biggest_Int (Max) then 850 if Max = Asis.ASIS_Integer'Last then 851 Syntax_Error ("Parameter must be >= " 852 & ASIS_Integer_Img (Min), 853 Current_Token.Position); 854 elsif Min = Asis.ASIS_Integer'First then 855 Syntax_Error ("Parameter must be <= " 856 & ASIS_Integer_Img (Max), 857 Current_Token.Position); 858 else 859 Syntax_Error ("Parameter must be in range " 860 & ASIS_Integer_Img (Min) 861 & " .. " 862 & ASIS_Integer_Img (Max), 863 Current_Token.Position); 864 end if; 865 end if; 866 return Asis.ASIS_Integer (Result); 867 end Get_Integer_Parameter; 868 869 ------------------------- 870 -- Get_Float_Parameter -- 871 ------------------------- 872 873 function Get_Float_Parameter return Float is 874 begin 875 if not In_Parameters then 876 Failure ("Get_Float_Parameter called when not in parameters"); 877 end if; 878 879 case Current_Token.Kind is 880 when Float_Value => 881 declare 882 Result : constant Float := Current_Token.Fvalue; 883 begin 884 Next_Token; 885 Next_Parameter; 886 return Result; 887 end; 888 when Integer_Value => 889 -- Well, we can accept it... 890 declare 891 Result : constant Float := Float (Current_Token.Value); 892 begin 893 Next_Token; 894 Next_Parameter; 895 return Result; 896 end; 897 when Bad_Integer | Bad_Float => 898 Syntax_Error ("Bad real value (too many digits?)", Current_Token.Position); 899 when Name => 900 Syntax_Error ("Float parameter expected", Current_Token.Position); 901 when others => 902 Syntax_Error ("Parameter expected", Current_Token.Position); 903 end case; 904 end Get_Float_Parameter; 905 906 ------------------------ 907 -- Get_Name_Parameter -- 908 ------------------------ 909 910 function Get_Name_Parameter return Wide_String is 911 Initial_Tick : Boolean := False; 912 begin 913 if not In_Parameters then 914 Failure ("Get_Name_Parameter called when not in parameters"); 915 end if; 916 917 if Current_Token.Kind = String_Value then 918 -- Take it as an operator's name 919 declare 920 Result : constant Wide_String := '"' & To_Upper (Image (Current_Token)) & '"'; 921 begin 922 Next_Token; 923 Next_Parameter; 924 return Result; 925 end; 926 end if; 927 928 if Current_Token.Kind = Tick then 929 Initial_Tick := True; 930 Next_Token; 931 end if; 932 933 if Current_Token.Kind /= Name then 934 Syntax_Error ("Name expected", Current_Token.Position); 935 end if; 936 937 declare 938 Result : constant Wide_String := To_Upper (Image (Current_Token)); 939 begin 940 Next_Token; 941 if Current_Token.Kind = Tick then 942 -- We must accept 'class'input... 943 return Choose (Initial_Tick, "'", "") & Result & Get_Name_Parameter; 944 else 945 Next_Parameter; 946 return Choose (Initial_Tick, "'", "") & Result; 947 end if; 948 end; 949 end Get_Name_Parameter; 950 951 -------------------------- 952 -- Get_String_Parameter -- 953 -------------------------- 954 955 function Get_String_Parameter return Wide_String is 956 begin 957 if not In_Parameters then 958 Failure ("Get_String_Parameter called when not in parameters"); 959 end if; 960 961 if Current_Token.Kind /= String_Value then 962 Syntax_Error ("String expected", Current_Token.Position); 963 end if; 964 965 declare 966 Result : constant Wide_String := Image (Current_Token); 967 begin 968 Next_Token; 969 Next_Parameter; 970 return Result; 971 end; 972 end Get_String_Parameter; 973 974 -------------------------- 975 -- Get_Entity_Parameter -- 976 -------------------------- 977 978 function Get_Entity_Parameter (Allow_Extended : Boolean := False; 979 Ghost : Wide_String := "") return Entity_Specification 980 is 981 Result : constant Entity_Specification := Get_Entity_Modifier (Allow_Extended, Ghost); 982 begin 983 Next_Parameter; 984 return Result; 985 end Get_Entity_Parameter; 986 987 ------------------------- 988 -- Get_Entity_Modifier -- 989 ------------------------- 990 991 function Get_Entity_Modifier (Allow_Extended : Boolean := False; 992 Ghost : Wide_String := "") return Entity_Specification 993 is 994 -- Information set by the parsing functions: 995 Qualified : Boolean; 996 997 -- Forward declarations: 998 function Full_Name return Wide_String; 999 function Profile return Wide_String; 1000 1001 function Identifier return Wide_String is 1002 begin 1003 case Current_Token.Kind is 1004 when Name => 1005 declare 1006 Name : constant Wide_String := To_Upper (Image (Current_Token)); 1007 begin 1008 Next_Token; 1009 return Name; 1010 end; 1011 when String_Value => 1012 -- Assume it is an operator 1013 declare 1014 Name : constant Wide_String := '"' & To_Upper (Image (Current_Token)) & '"'; 1015 begin 1016 Next_Token; 1017 return Name; 1018 end; 1019 when others => 1020 Syntax_Error ("Identifier expected", Current_Token.Position); 1021 end case; 1022 end Identifier; 1023 1024 function Type_Spec return Wide_String is 1025 type Access_Forms is (No_Access, Access_Object, Access_Function, Access_Procedure); 1026 subtype Access_SP is Access_Forms range Access_Function .. Access_Procedure; 1027 Access_Form : Access_Forms := No_Access; 1028 1029 function Formatted_Name (Name : Wide_String; Add_Standard : Boolean) return Wide_String is 1030 begin 1031 case Access_Form is 1032 when No_Access => 1033 return Choose (Add_Standard, "STANDARD.", "") & Name; 1034 when Access_Object => 1035 return "*O" & Choose (Add_Standard, "STANDARD.", "") & Name; 1036 when Access_Function => 1037 return "*F" & Choose (Add_Standard, "STANDARD.", "") & Name; 1038 when Access_Procedure => 1039 return "*P" & Choose (Add_Standard, "STANDARD.", "") & Name; 1040 end case; 1041 end Formatted_Name; 1042 1043 begin -- Type_Spec 1044 if Current_Token.Kind = Name and then Current_Token.Key = Key_Access then 1045 Next_Token; 1046 if Current_Token.Kind = Name then 1047 case Current_Token.Key is 1048 when Key_Procedure => 1049 Access_Form := Access_Procedure; 1050 Next_Token; 1051 when Key_Function => 1052 Access_Form := Access_Function; 1053 Next_Token; 1054 when others => 1055 Access_Form := Access_Object; 1056 end case; 1057 else 1058 Access_Form := Access_Object; 1059 end if; 1060 end if; 1061 1062 if Access_Form in Access_SP then 1063 -- no identifier, just a profile 1064 if Current_Token.Kind /= Left_Bracket then 1065 Syntax_Error ("""{"" expected", Current_Token.Position); 1066 end if; 1067 Next_Token; 1068 1069 if Current_Token.Kind = Right_Bracket then 1070 Next_Token; 1071 return Formatted_Name ("{}", Add_Standard => False); 1072 end if; 1073 1074 declare 1075 Profile1 : constant Wide_String := Profile; 1076 begin 1077 if Current_Token.Kind /= Right_Bracket then 1078 Syntax_Error ("Missing ""}""", Current_Token.Position); 1079 end if; 1080 1081 Next_Token; 1082 return Formatted_Name ('{' & Profile1 & '}', Add_Standard => False); 1083 end; 1084 1085 else 1086 -- If not qualified, assume the identifier is declared in Standard 1087 Qualified := False; 1088 declare 1089 Raw_Name : constant Wide_String := Full_Name; -- Intermediate necessary to ensure evaluation order 1090 begin 1091 return Formatted_Name (Raw_Name, Add_Standard => not Qualified); 1092 end; 1093 end if; 1094 end Type_Spec; 1095 1096 function Profile return Wide_String is 1097 1098 function Parameter_List return Wide_String is 1099 Parameter1 : constant Wide_String := Type_Spec; 1100 begin -- Parameter_List 1101 if Current_Token.Kind = Semi_Colon then 1102 Next_Token; 1103 return Parameter1 & ';' & Parameter_List; 1104 else 1105 return Parameter1; 1106 end if; 1107 end Parameter_List; 1108 1109 begin -- Profile 1110 if Current_Token.Kind = Name and then Current_Token.Key = Key_Return then 1111 -- return alone, no parameters 1112 Next_Token; 1113 return ':' & Type_Spec; 1114 end if; 1115 1116 declare 1117 List1 : constant Wide_String := Parameter_List; 1118 begin 1119 if Current_Token.Kind /= Name or else Current_Token.Key /= Key_Return then 1120 return List1; 1121 end if; 1122 1123 -- We have a "return" here 1124 Next_Token; 1125 return List1 & ':' & Type_Spec; 1126 end; 1127 end Profile; 1128 1129 function Typed_Name return Wide_String is 1130 Name1 : constant Wide_String := Identifier; 1131 begin 1132 if Current_Token.Kind /= Left_Bracket then 1133 return Name1; 1134 end if; 1135 1136 Next_Token; 1137 if Current_Token.Kind = Right_Bracket then 1138 Next_Token; 1139 return Name1 & "{}"; 1140 end if; 1141 1142 declare 1143 Profile1 : constant Wide_String := Profile; 1144 begin 1145 if Current_Token.Kind /= Right_Bracket then 1146 Syntax_Error ("Missing ""}""", Current_Token.Position); 1147 end if; 1148 1149 Next_Token; 1150 return Name1 & '{' & Profile1 & '}'; 1151 end; 1152 end Typed_Name; 1153 1154 function Attributed_Name return Wide_String is 1155 function Attribute_List return Wide_String is 1156 Name1 : constant Wide_String := Identifier; 1157 begin 1158 if Current_Token.Kind = Tick then 1159 Next_Token; 1160 return Name1 & ''' & Attribute_List; 1161 else 1162 return Name1; 1163 end if; 1164 end Attribute_List; 1165 1166 Name1 : constant Wide_String := Typed_Name; 1167 begin -- Attributed_Name 1168 if Current_Token.Kind = Tick then 1169 Next_Token; 1170 return Name1 & ''' & Attribute_List; 1171 else 1172 return Name1; 1173 end if; 1174 end Attributed_Name; 1175 1176 function Full_Name return Wide_String is 1177 Ident1 : constant Wide_String := Attributed_Name; 1178 begin 1179 if Current_Token.Kind = Period then 1180 Next_Token; 1181 Qualified := True; 1182 return Ident1 & '.' & Full_Name; 1183 else 1184 return Ident1; 1185 end if; 1186 end Full_Name; 1187 1188 begin -- Get_Entity_Modifier 1189 if not In_Parameters then 1190 Failure ("Get_Entity_Parameter called when not in parameters"); 1191 end if; 1192 1193 case Current_Token.Kind is 1194 when Left_Angle => 1195 if not Allow_Extended then 1196 Syntax_Error ("Entity name expected", Current_Token.Position); 1197 end if; 1198 1199 Next_Token; 1200 if Current_Token.Kind /= Right_Angle then 1201 Syntax_Error (""">"" expected", Current_Token.Position); 1202 end if; 1203 1204 Next_Token; 1205 return (Kind => Box); 1206 1207 when Equal => 1208 if not Allow_Extended then 1209 Syntax_Error ("Entity name expected", Current_Token.Position); 1210 end if; 1211 1212 Next_Token; 1213 return (Kind => Equal); 1214 1215 when Left_Parenthesis => 1216 if not Allow_Extended then 1217 Syntax_Error ("Entity name expected", Current_Token.Position); 1218 end if; 1219 1220 Next_Token; 1221 if Current_Token.Kind /= Right_Parenthesis then 1222 Syntax_Error (""")"" expected", Current_Token.Position); 1223 end if; 1224 1225 Next_Token; 1226 return (Kind => Regular_Id, 1227 Specification => To_Unbounded_Wide_String ("()")); 1228 1229 when String_Value => 1230 -- Can be an operator 1231 return (Kind => Regular_Id, 1232 Specification => To_Unbounded_Wide_String (Full_Name)); 1233 1234 when Name => 1235 if Current_Token.Key /= Key_All then 1236 -- Normal case, no "all" 1237 return (Kind => Regular_Id, 1238 Specification => To_Unbounded_Wide_String (Full_Name)); 1239 end if; 1240 1241 -- "all" 1242 Next_Token; 1243 if Current_Token.Kind = Tick then 1244 -- "all 'image" 1245 Next_Token; 1246 return (Kind => All_Id, 1247 Specification => To_Unbounded_Wide_String (''' & Identifier)); 1248 else 1249 return (Kind => All_Id, 1250 Specification => To_Unbounded_Wide_String (Attributed_Name)); 1251 end if; 1252 1253 when Comma | Right_Parenthesis => 1254 -- "ghost" parameter 1255 if Ghost /= "" then 1256 return Value (Ghost); 1257 end if; 1258 1259 Syntax_Error ("Entity specification expected", Current_Token.Position); 1260 when others => 1261 Syntax_Error ("Entity specification expected", Current_Token.Position); 1262 end case; 1263 end Get_Entity_Modifier; 1264 1265 ------------------------ 1266 -- Get_File_Parameter -- 1267 ------------------------ 1268 1269 function Get_File_Parameter return Wide_String is 1270 Name : constant Wide_String := Get_String_Parameter; 1271 begin 1272 if Name = "" then 1273 Syntax_Error ("Empty file name", Current_Token.Position); 1274 end if; 1275 1276 if (Name (1) = '/' or Name (1) = '\') 1277 or else (Name'Length >= 3 and then Name (2) = ':' and then (Name (3) = '/' or Name (3) = '\')) 1278 then 1279 -- Absolute path 1280 return Name; 1281 end if; 1282 1283 -- Here we have a relative path, make it relative to the directory of the rules file 1284 return Reference_Dir & Name; 1285 end Get_File_Parameter; 1286 1287 ------------------ 1288 -- Get_Modifier -- 1289 ------------------ 1290 1291 function Get_Modifier (True_KW : Wide_String; 1292 False_KW : Wide_String := ""; 1293 Default : Boolean := False) return Boolean 1294 is 1295 begin 1296 if Current_Token.Kind = Name then 1297 if To_Upper (Image (Current_Token)) = True_KW then 1298 Next_Token; 1299 return True; 1300 elsif To_Upper (Image (Current_Token)) = False_KW then 1301 Next_Token; 1302 return False; 1303 end if; 1304 end if; 1305 return Default; 1306 end Get_Modifier; 1307 1308 ------------------------ 1309 -- Modifier_Utilities -- 1310 ------------------------ 1311 1312 package body Modifier_Utilities is 1313 package Local_Utilities is new Common_Enumerated_Utilities (Modifiers, Prefix, Box_Pos, Pars_Pos); 1314 1315 procedure Get_Modifier (Modifier : out Modifiers; Found : out Boolean; Expected : Modifier_Set) is 1316 begin 1317 case Current_Token.Kind is 1318 when Name => 1319 declare 1320 To_Compare : constant Wide_String := To_Upper (Prefix & Image (Current_Token)); 1321 begin 1322 for Idx in Modifiers loop 1323 if Expected (Idx) and then To_Compare = Modifiers'Wide_Image (Idx) then 1324 Next_Token; 1325 Modifier := Idx; 1326 Found := True; 1327 return; 1328 end if; 1329 end loop; 1330 end; 1331 when Left_Angle => 1332 if Box_Pos >= 0 and then Expected (Modifiers'Val (Box_Pos)) then 1333 Next_Token; 1334 if Current_Token.Kind /= Right_Angle then 1335 Syntax_Error (""">"" Expected", Current_Token.Position); 1336 end if; 1337 Next_Token; 1338 Modifier := Modifiers'Val (Box_Pos); 1339 Found := True; 1340 return; 1341 end if; 1342 when Left_Parenthesis => 1343 if Pars_Pos >= 0 and then Expected (Modifiers'Val (Pars_Pos)) then 1344 Next_Token; 1345 if Current_Token.Kind /= Right_Parenthesis then 1346 Syntax_Error (""")"" Expected", Current_Token.Position); 1347 end if; 1348 Next_Token; 1349 Modifier := Modifiers'Val (Pars_Pos); 1350 Found := True; 1351 return; 1352 end if; 1353 when others => 1354 null; 1355 end case; 1356 Found := False; 1357 end Get_Modifier; 1358 1359 function Get_Modifier (Required : Boolean; 1360 Expected : Modifier_Set := Full_Set; 1361 Default : Modifiers := Modifiers'First) return Modifiers 1362 is 1363 Present : Boolean; 1364 Result : Modifiers; 1365 begin 1366 if not In_Parameters then 1367 Failure ("Get_Modifier called when not in parameters"); 1368 end if; 1369 1370 Get_Modifier (Result, Present, Expected); 1371 if Present then 1372 return Result; 1373 elsif Required then 1374 Syntax_Error ("modifier expected", Current_Token.Position); 1375 else 1376 return Default; 1377 end if; 1378 end Get_Modifier; 1379 1380 function Get_Modifier_Set (No_Parameter : Boolean := False; 1381 Expected : Modifier_Set := Full_Set) 1382 return Modifier_Set 1383 is 1384 Result : Modifier_Set := Empty_Set; 1385 Modifier : Modifiers; 1386 Present : Boolean; 1387 begin 1388 if not In_Parameters then 1389 Failure ("Get_Modifier_Set called when not in parameters"); 1390 end if; 1391 1392 Get_Modifier (Modifier, Present, Expected); 1393 while Present loop 1394 Result (Modifier) := True; 1395 if No_Parameter then 1396 -- separating '|' required 1397 case Current_Token.Kind is 1398 when Vertical_Bar => 1399 Next_Token; 1400 Get_Modifier (Modifier, Present, Expected); 1401 if not Present then 1402 Syntax_Error ("Keyword expected after '|'", Current_Token.Position); 1403 end if; 1404 when Name => 1405 -- This branch not strictly necessary, but gives a more user-friendly message 1406 Syntax_Error ("'|' expected between keywords", Current_Token.Position); 1407 when others => 1408 Present := False; 1409 end case; 1410 else 1411 Get_Modifier (Modifier, Present, Expected); 1412 end if; 1413 end loop; 1414 1415 if No_Parameter then 1416 if Result = Empty_Set then 1417 Syntax_Error ("Keyword expected, use option -h <rule name> for a list of allowable keywords", 1418 Current_Token.Position); 1419 end if; 1420 Next_Parameter; 1421 end if; 1422 1423 return Result; 1424 end Get_Modifier_Set; 1425 1426 function Image (Item : Modifiers; 1427 In_Case : Utilities.Casing := Utilities.Upper_Case) return Wide_String 1428 renames Local_Utilities.Image; 1429 1430 procedure Help_On_Modifiers (Header : Wide_String := ""; 1431 Footer : Wide_String := ""; 1432 Extra_Value : Wide_String := "NONE"; 1433 Expected : Modifier_Set := Full_Set) 1434 is 1435 begin 1436 Local_Utilities.Help_On_Flags (Header, Footer, Extra_Value, Local_Utilities.Flag_Set (Expected)); 1437 end Help_On_Modifiers; 1438 1439 function Image (Set : Unconstrained_Modifier_Set; 1440 Default : Unconstrained_Modifier_Set := Empty_Set) return Wide_String 1441 is 1442 begin 1443 if Set = (Set'Range => False) or else Set = Default then 1444 return ""; 1445 elsif Set'First = Set'Last then 1446 -- only one element 1447 return Image (Set'First, Lower_Case) & ' '; 1448 else 1449 for M in Modifiers range Set'First .. Modifiers'Pred (Set'Last) loop 1450 if Set (M) then 1451 return Image (M, Lower_Case) & ' ' & Image (Set (Modifiers'Succ (M) .. Set'Last)); 1452 end if; 1453 end loop; 1454 -- If we are here, Set (Set'Last) is the only True element 1455 return Image (Set'Last, Lower_Case) & ' '; 1456 end if; 1457 end Image; 1458 1459 function Get_Modifier_List (Expected : Modifier_Set := Full_Set) return Modifier_List is 1460 Modifier : Modifiers; 1461 Present : Boolean; 1462 1463 begin 1464 if not In_Parameters then 1465 Failure ("Get_Modifier_List called when not in parameters"); 1466 end if; 1467 1468 Get_Modifier (Modifier, Present, Expected); 1469 if not Present then 1470 return Empty_List; 1471 end if; 1472 1473 return Modifier & Get_Modifier_List (Expected); 1474 end Get_Modifier_List; 1475 1476 function Image (List : Modifier_List) return Wide_String is 1477 use type Asis.ASIS_Integer; -- Gela-ASIS compatibility 1478 begin 1479 if List = Empty_List then 1480 return ""; 1481 end if; 1482 1483 return Image (List (List'First), Lower_Case) 1484 & ' ' 1485 & Image (List (List'First + 1 .. List'Last)); 1486 end Image; 1487 1488 end Modifier_Utilities; 1489 1490 -------------------- 1491 -- Flag_Utilities -- 1492 -------------------- 1493 1494 package body Flag_Utilities is 1495 package Local_Utilities is new Common_Enumerated_Utilities (Flags, Prefix); 1496 1497 ------------------------ 1498 -- Get_Flag_Parameter -- 1499 ------------------------ 1500 1501 function Get_Flag_Parameter (Allow_Any : Boolean) return Flags is 1502 begin 1503 if not In_Parameters then 1504 Failure ("Get_Flag_Parameter called when not in parameters"); 1505 end if; 1506 1507 if Current_Token.Kind = Name then 1508 declare 1509 To_Compare : constant Wide_String := To_Upper (Prefix & Image (Current_Token)); 1510 begin 1511 for Key in Flags loop 1512 if To_Compare = Flags'Wide_Image (Key) then 1513 if Allow_Any and then Key = Flags'First then 1514 -- Oops, the user specified the special value 1515 Syntax_Error ("Not a valid parameter: " & Image (Current_Token), 1516 Current_Token.Position); 1517 end if; 1518 1519 Next_Token; 1520 Next_Parameter; 1521 return Key; 1522 end if; 1523 end loop; 1524 end; 1525 end if; 1526 1527 -- Here: not a Name, or unrecognized keyword 1528 if Allow_Any then 1529 -- Keep the current token 1530 return Flags'First; 1531 end if; 1532 1533 if Current_Token.Kind = Name then 1534 Syntax_Error ("Unknown keyword """ 1535 & Image (Current_Token) 1536 & """, use option -h <rule name> for a list of allowable keywords", 1537 Current_Token.Position); 1538 else 1539 Syntax_Error ("Keyword expected, use option -h <rule name> for a list of allowable keywords", 1540 Current_Token.Position); 1541 end if; 1542 end Get_Flag_Parameter; 1543 1544 ----------- 1545 -- Image -- 1546 ----------- 1547 1548 function Image (Item : Flags; In_Case : Utilities.Casing := Utilities.Upper_Case) return Wide_String 1549 renames Local_Utilities.Image; 1550 1551 ------------------- 1552 -- Help_On_Flags -- 1553 ------------------- 1554 1555 procedure Help_On_Flags (Header : Wide_String := ""; 1556 Footer : Wide_String := ""; 1557 Extra_Value : Wide_String := "NONE") 1558 is 1559 begin 1560 Local_Utilities.Help_On_Flags (Header, Footer, Extra_Value); 1561 end Help_On_Flags; 1562 end Flag_Utilities; 1563 1564 --------------------- 1565 -- Parameter_Error -- 1566 --------------------- 1567 1568 procedure Parameter_Error (Rule : Wide_String; Message : Wide_String) is 1569 begin 1570 Parameter_Error (Rule, Message, Current_Token.Position); 1571 end Parameter_Error; 1572 1573 procedure Parameter_Error (Rule : Wide_String; Message : Wide_String; Position : Location) is 1574 begin 1575 Error (Image (Position) & ": " 1576 & "Parameter: " 1577 & Rule & ": " 1578 & Message); 1579 end Parameter_Error; 1580 1581 ------------------ 1582 -- Syntax_Error -- 1583 ------------------ 1584 1585 procedure Syntax_Error (Message : Wide_String; Position : Location) is 1586 begin 1587 Error (Image (Position) & ": " 1588 & "Syntax: " 1589 & Message); 1590 end Syntax_Error; 1591 1592 ---------------------- 1593 -- Go_Command_Found -- 1594 ---------------------- 1595 1596 function Go_Command_Found return Boolean is 1597 begin 1598 return Last_Was_Go; 1599 end Go_Command_Found; 1600 1601 ----------------- 1602 -- Had_Failure -- 1603 ----------------- 1604 1605 function Had_Failure return Boolean is 1606 begin 1607 return Failure_Occurred; 1608 end Had_Failure; 1609 1610 ---------------- 1611 -- Had_Errors -- 1612 ---------------- 1613 1614 function Had_Errors return Boolean is 1615 begin 1616 return Rule_Error_Occurred; 1617 end Had_Errors; 1618 1619end Framework.Language; 1620