From 63f693f8a8b77261173ae0e724110ecf8bf9b82e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Wed, 29 May 2024 12:28:12 +0200 Subject: [PATCH 01/16] First pass of introduction of `GNATCOLL.Opt_Parse` * Plug a `GNATCOLL.Opt_Parse` parser in `Scan_Args`/`GNATcheck.Options` * Use it for a small number of flags for the moment, to test that the concept works correctly * So far `--check-semantic`/`--charset`/`--rules-dir` have been added * Clean up Scan_Arguments interface, pass a list of args rt. an Opt_Parser This will allow us to make GNATCOLL.Opt_Parse work on the list of arguments before GNAT.Command_Line. * Factor the call to `Initialize_Option_Scan` inside of `Scan_Arguments`. This way we don't repeat sections everywhere. --- lkql_checker/src/gnatcheck-compiler.adb | 6 +- lkql_checker/src/gnatcheck-options.ads | 45 ++++-- lkql_checker/src/gnatcheck-output.adb | 10 ++ lkql_checker/src/gnatcheck-projects.adb | 139 ++++++++++-------- lkql_checker/src/gnatcheck-projects.ads | 8 +- .../src/gnatcheck-rules-rule_table.adb | 2 +- lkql_checker/src/gnatcheck-source_table.adb | 8 +- lkql_checker/src/gnatcheck_main.adb | 11 +- lkql_checker/src/rules_factory.adb | 23 ++- lkql_checker/src/rules_factory.ads | 18 +-- 10 files changed, 152 insertions(+), 118 deletions(-) diff --git a/lkql_checker/src/gnatcheck-compiler.adb b/lkql_checker/src/gnatcheck-compiler.adb index c0a2e410d..91afe9975 100644 --- a/lkql_checker/src/gnatcheck-compiler.adb +++ b/lkql_checker/src/gnatcheck-compiler.adb @@ -1646,9 +1646,11 @@ package body Gnatcheck.Compiler is Args (Num_Args) := new String'("-eL"); end if; - for Dir of Additional_Rules_Dirs loop + for Dir of Arg.Rules_Dirs.Get loop Num_Args := @ + 1; - Args (Num_Args) := new String'("--rules-dir=" & Dir); + Args (Num_Args) + := new String' + ("--rules-dir=" & Ada.Strings.Unbounded.To_String (Dir)); end loop; Num_Args := @ + 1; diff --git a/lkql_checker/src/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads index 07b157729..0602768ce 100644 --- a/lkql_checker/src/gnatcheck-options.ads +++ b/lkql_checker/src/gnatcheck-options.ads @@ -7,14 +7,16 @@ -- for all the tools. with Ada.Command_Line; use Ada.Command_Line; -with Ada.Directories; use Ada.Directories; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; + +with Ada.Directories; use Ada.Directories; with Ada.Environment_Variables; with GNAT.OS_Lib; with Gnatcheck.Projects; -with Rules_Factory; use Rules_Factory; +with GNATCOLL.Opt_Parse; use GNATCOLL.Opt_Parse; package Gnatcheck.Options is @@ -50,15 +52,9 @@ package Gnatcheck.Options is -- Target as it is specified by the command-line '--target=...' option, or -- by the 'Target attribute in the argument project file. - Charset : GNAT.OS_Lib.String_Access := new String'("iso-8859-1"); - -- Charset to use for parsing source files - Global_Report_Dir : GNAT.OS_Lib.String_Access := new String'("./"); -- The name of the directory to place the global results into - Additional_Rules_Dirs : Path_Vector; - -- Additional rules directories specified via --rules-dir - Fatal_Error : exception; -- This exception should be raised when there is no sense any more to do -- any work in the tool. When raising this exception, one has to generate @@ -112,10 +108,6 @@ package Gnatcheck.Options is -- is computed and printed out. -- '-t' - Check_Semantic : Boolean := False; - -- If True, run the compiler to check the semantic of each source file. - -- --check-semantic - Legacy : Boolean := False; -- If True, run in legacy mode, with no support for additional rule files. @@ -295,4 +287,33 @@ package Gnatcheck.Options is Gnatcheck_Prj : aliased Gnatcheck.Projects.Arg_Project_Type; + package Arg is + Parser : Argument_Parser := Create_Argument_Parser + (Help => "GNATcheck help", + Incremental => True, + Generate_Help_Flag => False); + + package Check_Semantic is new Parse_Flag + (Parser => Parser, + Long => "--check-semantic", + Help => "check semantic validity of the source files"); + + package Charset is new Parse_Option + (Parser => Parser, + Long => "--charset", + Arg_Type => Unbounded_String, + Default_Val => To_Unbounded_String ("iso-8859-1"), + Help => "specify the charset of the source files (default is " + & "latin-1)"); + + package Rules_Dirs is new Parse_Option_List + (Parser => Parser, + Long => "--rules-dir", + Arg_Type => Unbounded_String, + Accumulate => True, + Enabled => not Legacy, + Help => "specify an alternate directory containing rule files"); + + end Arg; + end Gnatcheck.Options; diff --git a/lkql_checker/src/gnatcheck-output.adb b/lkql_checker/src/gnatcheck-output.adb index daf006534..d6d026b18 100644 --- a/lkql_checker/src/gnatcheck-output.adb +++ b/lkql_checker/src/gnatcheck-output.adb @@ -684,8 +684,13 @@ package body Gnatcheck.Output is Info (" -l - full pathname for file locations"); Info (""); Info (" --brief - brief mode, only report detections in Stderr"); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" --check-semantic - check semantic validity of the source files"); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" --charset= - specify the charset of the source files"); + Info (" --kp-version= - enable all KP detectors matching GNAT "); Info (""); @@ -738,10 +743,15 @@ package body Gnatcheck.Output is Info (" --brief - brief mode, only report detections in Stderr"); Info (" --check-redefinition - issue warning if a rule parameter is redefined"); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" --check-semantic - check semantic validity of the source files"); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" --charset= - specify the charset of the source files"); if not Legacy then + -- TODO: Remove when we switch to Opt_Parse's help message Info (" --rules-dir= - specify an alternate directory containing rule files"); end if; diff --git a/lkql_checker/src/gnatcheck-projects.adb b/lkql_checker/src/gnatcheck-projects.adb index 200af4edd..7de78018b 100644 --- a/lkql_checker/src/gnatcheck-projects.adb +++ b/lkql_checker/src/gnatcheck-projects.adb @@ -13,6 +13,7 @@ with Ada.Strings; use Ada.Strings; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Strings.Unbounded; +with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.Directory_Operations; with GNAT.Regexp; use GNAT.Regexp; with GNAT.String_Split; use GNAT.String_Split; @@ -53,6 +54,9 @@ with GPR2.Project.Registry.Pack; with GPR2.Project.Registry.Pack.Description; with GPR2.Project.View; +with GNATCOLL.Opt_Parse; use GNATCOLL.Opt_Parse; +with GNATCOLL.Strings; use GNATCOLL.Strings; + with Rule_Commands; use Rule_Commands; with System.Multiprocessors; @@ -170,7 +174,6 @@ package body Gnatcheck.Projects is use GPR2; use GPR2.Project.Registry.Attribute; - Proj_Args_Parser : Opt_Parser; Ada_Idx : constant GPR2.Project.Attribute_Index.Object := GPR2.Project.Attribute_Index.Create (Ada_Language); Attr : GPR2.Project.Attribute.Object; @@ -193,16 +196,9 @@ package body Gnatcheck.Projects is Command_Line (J) := new String'(Attr.Values.Element (J).Text); end loop; - Initialize_Option_Scan - (Parser => Proj_Args_Parser, - Command_Line => Command_Line, - Switch_Char => '-', - Stop_At_First_Non_Switch => False, - Section_Delimiters => "cargs rules"); Scan_Arguments - (My_Project => My_Project, - Parser => Proj_Args_Parser, - In_Switches => False); + (My_Project => My_Project, + Args => Command_Line); Free (Command_Line); end if; @@ -961,11 +957,41 @@ package body Gnatcheck.Projects is -------------------- procedure Scan_Arguments - (My_Project : in out Arg_Project_Type; - First_Pass : Boolean := False; - Parser : Opt_Parser := Command_Line_Parser; - In_Switches : Boolean := False) + (My_Project : in out Arg_Project_Type; + First_Pass : Boolean := False; + Args : GNAT.OS_Lib.Argument_List_Access := null) is + + Unknown_Opt_Parse_Args : XString_Vector; + Args_After_Opt_Parse : Argument_List_Access; + Parser : Opt_Parser; + + function To_Arg_List (Args : XString_Vector) return Argument_List_Access; + function To_XString_Array + (Args : Argument_List_Access) return XString_Array; + + function To_Arg_List (Args : XString_Vector) return Argument_List_Access + is + Ret : constant Argument_List_Access + := new String_List (1 .. Args.Last_Index); + begin + for I in Ret'Range loop + Ret (I) := new String'(Args (I).To_String); + end loop; + return Ret; + end To_Arg_List; + + function To_XString_Array + (Args : Argument_List_Access) return XString_Array + is + Ret : XString_Array (Args'Range); + begin + for I in Args'Range loop + Ret (I) := To_XString (Args (I).all); + end loop; + return Ret; + end To_XString_Array; + procedure Process_Sections; -- Processes the 'rules' section. @@ -1037,9 +1063,9 @@ package body Gnatcheck.Projects is Lkql : constant String := Compose (Compose (Prefix, "share"), "lkql"); - In_Project_File : constant Boolean := Parser /= Command_Line_Parser; - Initial_Char : Character; - Success : Boolean; + Args_From_Project : constant Boolean := Args /= null; + Initial_Char : Character; + Success : Boolean; Print_Registry_Option : constant String := GPR2.Options.Print_GPR_Registry_Option @@ -1060,6 +1086,17 @@ package body Gnatcheck.Projects is Free (Executable); + if Arg.Parser.Parse + ((if Args /= null then To_XString_Array (Args) else No_Arguments), + Unknown_Arguments => Unknown_Opt_Parse_Args) + then + Args_After_Opt_Parse := To_Arg_List (Unknown_Opt_Parse_Args); + Initialize_Option_Scan + (Parser, Args_After_Opt_Parse, Section_Delimiters => "cargs rules"); + else + raise Parameter_Error; + end if; + loop Initial_Char := GNAT.Command_Line.Getopt @@ -1068,8 +1105,6 @@ package body Gnatcheck.Projects is "P: U X! vP! eL A: -config! " & -- project-specific options "-no-subprojects " & "-brief " & - "-charset= " & - "-check-semantic " & "-check-redefinition " & "-no_objects_dir " & "-subdirs= " & @@ -1082,7 +1117,6 @@ package body Gnatcheck.Projects is "-RTS= " & "l log " & "-include-file= " & - "-rules-dir= " & "-show-rule " & "-subprocess " & "-version -help " & @@ -1100,26 +1134,20 @@ package body Gnatcheck.Projects is declare Arg : constant String := Get_Argument (Do_Expansion => True, - Parser => Command_Line_Parser); + Parser => Parser); begin exit when Arg = ""; Success := True; - if In_Switches then - Error ("Switches attribute cannot contain argument " & - "sources"); - raise Parameter_Error; - end if; - if Gnatcheck.Projects.U_Option_Set then Gnatcheck.Projects.Store_Main_Unit - (Arg, In_Project_File or First_Pass); + (Arg, Args_From_Project or First_Pass); else Store_Sources_To_Process - (Arg, In_Project_File or First_Pass); + (Arg, Args_From_Project or First_Pass); - if not In_Project_File then + if not Args_From_Project then Argument_File_Specified := True; end if; end if; @@ -1133,8 +1161,8 @@ package body Gnatcheck.Projects is if First_Pass then Aggregated_Project := True; Gnatcheck.Projects.Aggregate.Store_Aggregated_Project - (Parameter); - elsif In_Project_File then + (Parameter (Parser => Parser)); + elsif Args_From_Project then Error ("project file should not be specified inside " & "another project file"); raise Parameter_Error; @@ -1163,7 +1191,7 @@ package body Gnatcheck.Projects is if Full_Switch (Parser => Parser) = "eL" then if First_Pass then Gnatcheck.Projects.Follow_Symbolic_Links := True; - elsif In_Project_File then + elsif Args_From_Project then Error ("-eL option cannot be set in a project file"); raise Parameter_Error; end if; @@ -1177,14 +1205,8 @@ package body Gnatcheck.Projects is Files_Switch_Used := True; Read_Args_From_File (Parameter (Parser => Parser)); - elsif In_Project_File then - if In_Switches then - Error ("-files option is not allowed " & - "for Switches attribute"); - raise Parameter_Error; - else - Read_Args_From_File (Parameter (Parser => Parser)); - end if; + elsif Args_From_Project then + Read_Args_From_File (Parameter (Parser => Parser)); end if; end if; @@ -1271,8 +1293,8 @@ package body Gnatcheck.Projects is when 'P' => if Full_Switch (Parser => Parser) = "P" then if First_Pass then - My_Project.Store_Project_Source (Parameter); - elsif In_Project_File then + My_Project.Store_Project_Source (Parameter (Parser)); + elsif Args_From_Project then Error ("project file should not be specified inside " & "another project file"); raise Parameter_Error; @@ -1304,7 +1326,7 @@ package body Gnatcheck.Projects is Gnatcheck.Projects.U_Option_Set := True; Gnatcheck.Projects.Recursive_Sources := True; - elsif In_Project_File then + elsif Args_From_Project then Error ("-U option is not allowed in a project file"); raise Parameter_Error; end if; @@ -1324,7 +1346,7 @@ package body Gnatcheck.Projects is Parameter & " for -vP"); raise Parameter_Error; end; - elsif In_Project_File then + elsif Args_From_Project then Error ("-vP option is not allowed in a project file"); raise Parameter_Error; end if; @@ -1341,8 +1363,8 @@ package body Gnatcheck.Projects is if Full_Switch (Parser => Parser) = "X" then if First_Pass then Gnatcheck.Projects.Store_External_Variable - (Var => Parameter); - elsif In_Project_File then + (Var => Parameter (Parser => Parser)); + elsif Args_From_Project then Error ("external references cannot be set in " & "a project file"); raise Parameter_Error; @@ -1356,16 +1378,9 @@ package body Gnatcheck.Projects is Short_Report := True; Brief_Mode := True; - elsif Full_Switch (Parser => Parser) = "-charset" then - Free (Charset); - Charset := new String'(Parameter (Parser => Parser)); - elsif Full_Switch (Parser => Parser) = "-check-redefinition" then Check_Param_Redefinition := True; - elsif Full_Switch (Parser => Parser) = "-check-semantic" then - Check_Semantic := True; - elsif Full_Switch (Parser => Parser) = "-ignore" then if Is_Regular_File (Parameter (Parser => Parser)) then Exempted_Units := @@ -1392,16 +1407,10 @@ package body Gnatcheck.Projects is -- to resolve its parameter to the full path, and we -- can do this only when target is fully detected. null; - - elsif Full_Switch (Parser => Parser) = "-rules-dir" - and then not Legacy - then - Additional_Rules_Dirs.Append - (Parameter (Parser => Parser)); end if; else if Full_Switch (Parser => Parser) = "-help" then - if In_Project_File then + if Args_From_Project then Error ("project file should not contain '--help' option"); raise Parameter_Error; @@ -1411,7 +1420,7 @@ package body Gnatcheck.Projects is return; elsif Full_Switch (Parser => Parser) = "-version" then - if In_Project_File then + if Args_From_Project then Error ("project file should not contain '--version' " & "option"); @@ -1434,7 +1443,7 @@ package body Gnatcheck.Projects is RTS_Path := new String'(Parameter (Parser => Parser)); elsif Full_Switch (Parser => Parser) = "-config" then - if In_Project_File then + if Args_From_Project then Error ("configuration project cannot be set in " & "a project file"); raise Parameter_Error; @@ -1471,7 +1480,7 @@ package body Gnatcheck.Projects is Print_Gpr_Registry := True; elsif Full_Switch (Parser => Parser) = "-no-subprojects" then - if not In_Project_File or else not U_Option_Set then + if not Args_From_Project or else not U_Option_Set then Recursive_Sources := False; end if; end if; @@ -1579,7 +1588,7 @@ package body Gnatcheck.Projects is Analyze_Compiler_Output := Use_gnaty_Option or Use_gnatw_Option or - Check_Restrictions or Check_Semantic; + Check_Restrictions or Arg.Check_Semantic.Get; if Analyze_Compiler_Output then Store_Compiler_Option ("-gnatec=" & Gnatcheck_Config_File.all); diff --git a/lkql_checker/src/gnatcheck-projects.ads b/lkql_checker/src/gnatcheck-projects.ads index 75d4d0093..e08531d6a 100644 --- a/lkql_checker/src/gnatcheck-projects.ads +++ b/lkql_checker/src/gnatcheck-projects.ads @@ -89,7 +89,6 @@ -- and 3 above. For step 2, see the procedure Process_Project_File -- that combines all the steps of loading and analyzing the project file. -with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.OS_Lib; use GNAT.OS_Lib; with GPR2.Containers; @@ -269,10 +268,9 @@ package Gnatcheck.Projects is -- Process all the rule options found as part of scanning arguments procedure Scan_Arguments - (My_Project : in out Arg_Project_Type; - First_Pass : Boolean := False; - Parser : Opt_Parser := Command_Line_Parser; - In_Switches : Boolean := False); + (My_Project : in out Arg_Project_Type; + First_Pass : Boolean := False; + Args : GNAT.OS_Lib.Argument_List_Access := null); -- This procedure should be redefined for each tool project type. It -- should be called immediately after the call to Initialize_Option_Scan -- that should create the Parser for it. The procedure defines the loop diff --git a/lkql_checker/src/gnatcheck-rules-rule_table.adb b/lkql_checker/src/gnatcheck-rules-rule_table.adb index 7563c9398..bec6e254b 100644 --- a/lkql_checker/src/gnatcheck-rules-rule_table.adb +++ b/lkql_checker/src/gnatcheck-rules-rule_table.adb @@ -1615,7 +1615,7 @@ package body Gnatcheck.Rules.Rule_Table is Ctx.All_Rules := Rules_Factory.All_Rules - (Ctx.LKQL_Analysis_Context, Additional_Rules_Dirs); + (Ctx.LKQL_Analysis_Context, Path_Array (Arg.Rules_Dirs.Get)); for R of Ctx.All_Rules loop declare diff --git a/lkql_checker/src/gnatcheck-source_table.adb b/lkql_checker/src/gnatcheck-source_table.adb index c65a9e97b..c86092071 100644 --- a/lkql_checker/src/gnatcheck-source_table.adb +++ b/lkql_checker/src/gnatcheck-source_table.adb @@ -1492,6 +1492,8 @@ package body Gnatcheck.Source_Table is end; end Add_Runtime_Files; + Charset : constant String := To_String (Arg.Charset.Get); + begin -- If no project specified, create an auto provider with all the source -- files listed in the command line, stored in Temporary_File_Storage, @@ -1522,9 +1524,9 @@ package body Gnatcheck.Source_Table is Temp_Storage_Iterate (Add_File'Access); Add_Runtime_Files; Ctx.Analysis_Ctx := Create_Context - (Charset => Charset.all, + (Charset => Charset, Unit_Provider => Create_Auto_Provider_Reference - (Files (1 .. Last), Charset.all), + (Files (1 .. Last), Charset), Event_Handler => EHR_Object); Unchecked_Free (Files); end; @@ -1542,7 +1544,7 @@ package body Gnatcheck.Source_Table is -- aggregate projects, which are handled specially in lalcheck.adb Ctx.Analysis_Ctx := Create_Context - (Charset => Charset.all, + (Charset => Charset, Unit_Provider => Partition (Partition'First).Provider, Event_Handler => EHR_Object); diff --git a/lkql_checker/src/gnatcheck_main.adb b/lkql_checker/src/gnatcheck_main.adb index 112973728..4911130ec 100644 --- a/lkql_checker/src/gnatcheck_main.adb +++ b/lkql_checker/src/gnatcheck_main.adb @@ -11,7 +11,6 @@ with Ada.Text_IO; use Ada.Text_IO; with Checker_App; -with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.OS_Lib; use GNAT.OS_Lib; with Gnatcheck.Compiler; use Gnatcheck.Compiler; @@ -128,8 +127,8 @@ procedure Gnatcheck_Main is procedure Print_LKQL_Rules (File : File_Type; Mode : Source_Modes) is Mode_String : constant String := (case Mode is - when General => "rules", - when Ada_Only => "ada_rules", + when General => "rules", + when Ada_Only => "ada_rules", when Spark_Only => "spark_rules"); First : Boolean := True; @@ -347,9 +346,6 @@ procedure Gnatcheck_Main is begin Initialize_Environment; - Initialize_Option_Scan - (Stop_At_First_Non_Switch => False, - Section_Delimiters => "cargs rules"); Gnatcheck_Prj.Scan_Arguments (First_Pass => True); if Print_Version then @@ -417,9 +413,6 @@ begin -- Then analyze the command-line parameters - Initialize_Option_Scan - (Stop_At_First_Non_Switch => False, - Section_Delimiters => "cargs rules"); Gnatcheck_Prj.Scan_Arguments; -- Setup LKQL_RULES_PATH to point on built-in rules diff --git a/lkql_checker/src/rules_factory.adb b/lkql_checker/src/rules_factory.adb index bed734c6c..fb1d5b886 100644 --- a/lkql_checker/src/rules_factory.adb +++ b/lkql_checker/src/rules_factory.adb @@ -8,16 +8,25 @@ with Ada.Environment_Variables; with GNAT.OS_Lib; with GNATCOLL.Utils; +with GNATCOLL.Opt_Parse; use GNATCOLL.Opt_Parse; +with GNATCOLL.Strings; use GNATCOLL.Strings; +with GNATCOLL.VFS; use GNATCOLL.VFS; package body Rules_Factory is + type Virtual_File_Array is array (Positive range <>) of Virtual_File; + + function Get_Rules_Directories + (Dirs : Path_Array) return Virtual_File_Array; + -- Return the absolute path of the directory containing the LKQL programs + --------------- -- All_Rules -- --------------- function All_Rules (Ctx : L.Analysis_Context; - Dirs : Path_Vector := Path_Vectors.Empty_Vector) return Rule_Vector + Dirs : Path_Array := No_Paths) return Rule_Vector is Rules_Dirs : constant Virtual_File_Array := Get_Rules_Directories (Dirs); Rules : Rule_Vector := Rule_Vectors.Empty_Vector; @@ -65,15 +74,15 @@ package body Rules_Factory is --------------------------- function Get_Rules_Directories - (Dirs : Path_Vector) return Virtual_File_Array + (Dirs : Path_Array) return Virtual_File_Array is function Add_Rules_Path (Path : String) return Boolean; - Lkql_Rules_Paths : Path_Vector; + Lkql_Rules_Paths : XString_Vector; function Add_Rules_Path (Path : String) return Boolean is begin - Lkql_Rules_Paths.Append (Path); + Lkql_Rules_Paths.Append (To_XString (Path)); return True; end Add_Rules_Path; begin @@ -86,17 +95,17 @@ package body Rules_Factory is declare Custom_Checkers_Dirs : Virtual_File_Array - (1 .. Integer (Dirs.Length) + Integer (Lkql_Rules_Paths.Length)); + (1 .. Integer (Dirs'Length) + Integer (Lkql_Rules_Paths.Length)); Index : Positive := 1; begin for Dir of Dirs loop - Custom_Checkers_Dirs (Index) := Create (+Dir); + Custom_Checkers_Dirs (Index) := Create (+To_String (Dir)); Index := @ + 1; end loop; for Dir of Lkql_Rules_Paths loop - Custom_Checkers_Dirs (Index) := Create (+Dir); + Custom_Checkers_Dirs (Index) := Create (+To_String (Dir)); Index := @ + 1; end loop; diff --git a/lkql_checker/src/rules_factory.ads b/lkql_checker/src/rules_factory.ads index 1bef92c18..bb7417a90 100644 --- a/lkql_checker/src/rules_factory.ads +++ b/lkql_checker/src/rules_factory.ads @@ -3,13 +3,11 @@ -- SPDX-License-Identifier: GPL-3.0-or-later -- -with Ada.Containers.Indefinite_Vectors; with Ada.Containers.Vectors; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Gnatcheck.String_Utilities; use Gnatcheck.String_Utilities; -with GNATCOLL.VFS; use GNATCOLL.VFS; - with Liblkqllang.Analysis; with Rule_Commands; use Rule_Commands; @@ -24,21 +22,13 @@ package Rules_Factory is subtype Rule_Set is String_Sets.Set; - package Path_Vectors is new - Ada.Containers.Indefinite_Vectors (Positive, String); - subtype Path_Vector is Path_Vectors.Vector; + type Path_Array is array (Positive range <>) of Unbounded_String; + No_Paths : Path_Array (1 .. 0) := [others => <>]; function All_Rules (Ctx : L.Analysis_Context; - Dirs : Path_Vector := Path_Vectors.Empty_Vector) return Rule_Vector; + Dirs : Path_Array := No_Paths) return Rule_Vector; -- Return a vector containing Rule_Command values for every implemented -- check. -private - type Virtual_File_Array is array (Positive range <>) of Virtual_File; - - function Get_Rules_Directories - (Dirs : Path_Vector) return Virtual_File_Array; - -- Return the absolute path of the directory containing the LKQL programs - end Rules_Factory; From a5a0f15d2e81f673152bc285dcb1e54a7388a55d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Mon, 10 Jun 2024 17:08:06 +0200 Subject: [PATCH 02/16] Opt_Parse: Transition --no-subprojects --- lkql_checker/src/gnatcheck-options.ads | 5 +++++ lkql_checker/src/gnatcheck-output.adb | 6 ++++++ lkql_checker/src/gnatcheck-projects.adb | 10 ++-------- lkql_checker/src/gnatcheck-projects.ads | 4 ---- 4 files changed, 13 insertions(+), 12 deletions(-) diff --git a/lkql_checker/src/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads index 0602768ce..eda38bc93 100644 --- a/lkql_checker/src/gnatcheck-options.ads +++ b/lkql_checker/src/gnatcheck-options.ads @@ -298,6 +298,11 @@ package Gnatcheck.Options is Long => "--check-semantic", Help => "check semantic validity of the source files"); + package No_Subprojects is new Parse_Flag + (Parser => Parser, + Long => "--no-subprojects", + Help => "process only sources of root project"); + package Charset is new Parse_Option (Parser => Parser, Long => "--charset", diff --git a/lkql_checker/src/gnatcheck-output.adb b/lkql_checker/src/gnatcheck-output.adb index d6d026b18..31c6bf25b 100644 --- a/lkql_checker/src/gnatcheck-output.adb +++ b/lkql_checker/src/gnatcheck-output.adb @@ -668,7 +668,10 @@ package body Gnatcheck.Output is Info (" -Pproject - Use project file project. Only one such switch can be used"); Info (" -U - check all sources of the argument project"); Info (" -U main - check the closure of units rooted at unit main"); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" --no-subprojects - process only sources of root project"); + Info (" -Xname=value - specify an external reference for argument project file"); Info (" --subdirs=dir - specify subdirectory to place the result files into"); Info (" -eL - follow all symbolic links when processing project files"); @@ -713,7 +716,10 @@ package body Gnatcheck.Output is Info (" -Pproject - Use project file project. Only one such switch can be used"); Info (" -U - check all sources of the argument project"); Info (" -U main - check the closure of units rooted at unit main"); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" --no-subprojects - process only sources of root project"); + Info (" -Xname=value - specify an external reference for argument project file"); Info (" --subdirs=dir - specify subdirectory to place the result files into"); Info (" --no_objects_dir - place results into current dir instead of project dir"); diff --git a/lkql_checker/src/gnatcheck-projects.adb b/lkql_checker/src/gnatcheck-projects.adb index 7de78018b..d36508327 100644 --- a/lkql_checker/src/gnatcheck-projects.adb +++ b/lkql_checker/src/gnatcheck-projects.adb @@ -295,11 +295,11 @@ package body Gnatcheck.Projects is My_Project.Tree.For_Each_Ada_Closure (Action => Store_Source'Access, Mains => Main_Unit, - Root_Project_Only => not Recursive_Sources, + Root_Project_Only => Arg.No_Subprojects.Get, Externally_Built => False); end if; else - if Recursive_Sources then + if not Arg.No_Subprojects.Get then if Root.Has_Mains and then Only_Ada_Mains (Root) then @@ -1103,7 +1103,6 @@ package body Gnatcheck.Projects is ("v q t h hx s " & "m? files= a " & "P: U X! vP! eL A: -config! " & -- project-specific options - "-no-subprojects " & "-brief " & "-check-redefinition " & "-no_objects_dir " & @@ -1325,7 +1324,6 @@ package body Gnatcheck.Projects is end if; Gnatcheck.Projects.U_Option_Set := True; - Gnatcheck.Projects.Recursive_Sources := True; elsif Args_From_Project then Error ("-U option is not allowed in a project file"); raise Parameter_Error; @@ -1479,10 +1477,6 @@ package body Gnatcheck.Projects is then Print_Gpr_Registry := True; - elsif Full_Switch (Parser => Parser) = "-no-subprojects" then - if not Args_From_Project or else not U_Option_Set then - Recursive_Sources := False; - end if; end if; end if; diff --git a/lkql_checker/src/gnatcheck-projects.ads b/lkql_checker/src/gnatcheck-projects.ads index e08531d6a..3c3ac82d2 100644 --- a/lkql_checker/src/gnatcheck-projects.ads +++ b/lkql_checker/src/gnatcheck-projects.ads @@ -123,10 +123,6 @@ package Gnatcheck.Projects is -- getting the list of files from the project - '-U' should be ignored if -- '-files=...' is specified. - Recursive_Sources : Boolean := True; - -- Indicates that all sources of all projects should be processed - -- as opposed to sources of the root project only. - U_Option_Set : Boolean := False; -- Indicates if -U option is specified for the project (to process all the -- units of the closure of the argument project or to process the closure From f1888d8b0511600e5346e5a3d9b1a45aa939a53c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Thu, 13 Jun 2024 11:05:14 +0200 Subject: [PATCH 03/16] Opt_Parse: Transition -U --- lkql_checker/src/gnatcheck-compiler.adb | 4 +-- lkql_checker/src/gnatcheck-options.ads | 8 +++++ lkql_checker/src/gnatcheck-output.adb | 4 +++ lkql_checker/src/gnatcheck-projects.adb | 36 ++++++++++----------- lkql_checker/src/gnatcheck-projects.ads | 5 --- lkql_checker/src/gnatcheck-source_table.adb | 3 +- 6 files changed, 33 insertions(+), 27 deletions(-) diff --git a/lkql_checker/src/gnatcheck-compiler.adb b/lkql_checker/src/gnatcheck-compiler.adb index 91afe9975..df9d22581 100644 --- a/lkql_checker/src/gnatcheck-compiler.adb +++ b/lkql_checker/src/gnatcheck-compiler.adb @@ -1796,7 +1796,7 @@ package body Gnatcheck.Compiler is -- If files are specified explicitly, only compile these files - if (Argument_File_Specified and then not U_Option_Set) + if (Argument_File_Specified and then not Arg.Transitive_Closure.Get) or else File_List_Specified then Num_Args := @ + 1; @@ -1807,7 +1807,7 @@ package body Gnatcheck.Compiler is Args (Num_Args) := new String'(Short_Source_Name (SF)); end loop; else - if U_Option_Set then + if Arg.Transitive_Closure.Get then Num_Args := @ + 1; Args (Num_Args) := new String'("-U"); end if; diff --git a/lkql_checker/src/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads index eda38bc93..64639204e 100644 --- a/lkql_checker/src/gnatcheck-options.ads +++ b/lkql_checker/src/gnatcheck-options.ads @@ -303,6 +303,14 @@ package Gnatcheck.Options is Long => "--no-subprojects", Help => "process only sources of root project"); + package Transitive_Closure is new Parse_Flag + (Parser => Parser, + Short => "-U", + Name => "Closure", + Help => "process all units of the closure rooted in the mains " + & "passed as arguments (or mains of the project if list " + & "is empty)"); + package Charset is new Parse_Option (Parser => Parser, Long => "--charset", diff --git a/lkql_checker/src/gnatcheck-output.adb b/lkql_checker/src/gnatcheck-output.adb index 31c6bf25b..ec14ad91e 100644 --- a/lkql_checker/src/gnatcheck-output.adb +++ b/lkql_checker/src/gnatcheck-output.adb @@ -666,6 +666,8 @@ package body Gnatcheck.Output is Info (" --help - Display usage and exit"); Info (""); Info (" -Pproject - Use project file project. Only one such switch can be used"); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" -U - check all sources of the argument project"); Info (" -U main - check the closure of units rooted at unit main"); @@ -714,6 +716,8 @@ package body Gnatcheck.Output is Info (" --help - Display usage and exit"); Info (""); Info (" -Pproject - Use project file project. Only one such switch can be used"); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" -U - check all sources of the argument project"); Info (" -U main - check the closure of units rooted at unit main"); diff --git a/lkql_checker/src/gnatcheck-projects.adb b/lkql_checker/src/gnatcheck-projects.adb index d36508327..aa1b1e9de 100644 --- a/lkql_checker/src/gnatcheck-projects.adb +++ b/lkql_checker/src/gnatcheck-projects.adb @@ -275,13 +275,13 @@ package body Gnatcheck.Projects is My_Project.Tree.Namespace_Root_Projects.First_Element; begin - if (Argument_File_Specified and then not U_Option_Set) + if (Argument_File_Specified and then not Arg.Transitive_Closure.Get) or else File_List_Specified then return; end if; - if U_Option_Set then + if Arg.Transitive_Closure.Get then if Main_Unit.Is_Empty then -- No argument sources, -U specified. Process recursively -- all sources. @@ -1086,6 +1086,14 @@ package body Gnatcheck.Projects is Free (Executable); + -- Disallow arguments that are not allowed to be specified in project + -- files + -- TODO: It might be possible to have a list of subparsers and do a for + -- loop + if Args_From_Project then + Disallow (Arg.Transitive_Closure.This, "forbidden in project file"); + end if; + if Arg.Parser.Parse ((if Args /= null then To_XString_Array (Args) else No_Arguments), Unknown_Arguments => Unknown_Opt_Parse_Args) @@ -1097,12 +1105,17 @@ package body Gnatcheck.Projects is raise Parameter_Error; end if; + -- Reallow arguments that were disallowed + if Args_From_Project then + Allow (Arg.Transitive_Closure.This); + end if; + loop Initial_Char := GNAT.Command_Line.Getopt ("v q t h hx s " & "m? files= a " & - "P: U X! vP! eL A: -config! " & -- project-specific options + "P: X! vP! eL A: -config! " & -- project-specific options "-brief " & "-check-redefinition " & "-no_objects_dir " & @@ -1139,7 +1152,7 @@ package body Gnatcheck.Projects is exit when Arg = ""; Success := True; - if Gnatcheck.Projects.U_Option_Set then + if Options.Arg.Transitive_Closure.Get then Gnatcheck.Projects.Store_Main_Unit (Arg, Args_From_Project or First_Pass); else @@ -1315,21 +1328,6 @@ package body Gnatcheck.Projects is Compute_Timing := True; end if; - when 'U' => - if Full_Switch (Parser => Parser) = "U" then - if First_Pass then - if Gnatcheck.Projects.U_Option_Set then - Error ("-U can be specified only once"); - raise Parameter_Error; - end if; - - Gnatcheck.Projects.U_Option_Set := True; - elsif Args_From_Project then - Error ("-U option is not allowed in a project file"); - raise Parameter_Error; - end if; - end if; - when 'v' => if Full_Switch (Parser => Parser) = "v" then Verbose_Mode := True; diff --git a/lkql_checker/src/gnatcheck-projects.ads b/lkql_checker/src/gnatcheck-projects.ads index 3c3ac82d2..4caddf703 100644 --- a/lkql_checker/src/gnatcheck-projects.ads +++ b/lkql_checker/src/gnatcheck-projects.ads @@ -123,11 +123,6 @@ package Gnatcheck.Projects is -- getting the list of files from the project - '-U' should be ignored if -- '-files=...' is specified. - U_Option_Set : Boolean := False; - -- Indicates if -U option is specified for the project (to process all the - -- units of the closure of the argument project or to process the closure - -- of the main unit if the main unit is set) - Main_Unit : GPR2.Containers.Filename_Set; -- If the tool is called with "... Pproj -U main_unit1 main_unit2 ...", -- main units are stored here. diff --git a/lkql_checker/src/gnatcheck-source_table.adb b/lkql_checker/src/gnatcheck-source_table.adb index c86092071..4c16dfca5 100644 --- a/lkql_checker/src/gnatcheck-source_table.adb +++ b/lkql_checker/src/gnatcheck-source_table.adb @@ -1087,7 +1087,8 @@ package body Gnatcheck.Source_Table is -- Only warn if no sources are specified explicitly elsif not (File_List_Specified - or else (Argument_File_Specified and then not U_Option_Set)) + or else (Argument_File_Specified + and then not Arg.Transitive_Closure.Get)) then Gnatcheck.Output.Warning ("exemption: source " & Fname & " not found"); From b468d737fcbc6671b4e426a72aff21d7c0ce04f7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 14 Jun 2024 12:45:59 +0200 Subject: [PATCH 04/16] Opt_Parse: Transition -P --- lkql_checker/src/gnatcheck-options.ads | 8 ++++++++ lkql_checker/src/gnatcheck-output.adb | 4 ++++ lkql_checker/src/gnatcheck-projects.adb | 21 ++++++++------------- lkql_checker/src/gnatcheck_main.adb | 6 ++++++ 4 files changed, 26 insertions(+), 13 deletions(-) diff --git a/lkql_checker/src/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads index 64639204e..3b78c2785 100644 --- a/lkql_checker/src/gnatcheck-options.ads +++ b/lkql_checker/src/gnatcheck-options.ads @@ -327,6 +327,14 @@ package Gnatcheck.Options is Enabled => not Legacy, Help => "specify an alternate directory containing rule files"); + package Project_File is new Parse_Option + (Parser => Parser, + Short => "-P", + Long => "--project", + Arg_Type => Unbounded_String, + Default_Val => Null_Unbounded_String, + Help => "project file to use"); + end Arg; end Gnatcheck.Options; diff --git a/lkql_checker/src/gnatcheck-output.adb b/lkql_checker/src/gnatcheck-output.adb index ec14ad91e..debf96dd4 100644 --- a/lkql_checker/src/gnatcheck-output.adb +++ b/lkql_checker/src/gnatcheck-output.adb @@ -665,6 +665,8 @@ package body Gnatcheck.Output is Info (" --version - Display version and exit"); Info (" --help - Display usage and exit"); Info (""); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" -Pproject - Use project file project. Only one such switch can be used"); -- TODO: Remove when we switch to Opt_Parse's help message @@ -715,6 +717,8 @@ package body Gnatcheck.Output is Info (" --version - Display version and exit"); Info (" --help - Display usage and exit"); Info (""); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" -Pproject - Use project file project. Only one such switch can be used"); -- TODO: Remove when we switch to Opt_Parse's help message diff --git a/lkql_checker/src/gnatcheck-projects.adb b/lkql_checker/src/gnatcheck-projects.adb index aa1b1e9de..90cfdfc61 100644 --- a/lkql_checker/src/gnatcheck-projects.adb +++ b/lkql_checker/src/gnatcheck-projects.adb @@ -1091,7 +1091,12 @@ package body Gnatcheck.Projects is -- TODO: It might be possible to have a list of subparsers and do a for -- loop if Args_From_Project then - Disallow (Arg.Transitive_Closure.This, "forbidden in project file"); + declare + In_Project_Msg : constant String := "forbidden in project file"; + begin + Disallow (Arg.Project_File.This, In_Project_Msg); + Disallow (Arg.Transitive_Closure.This, In_Project_Msg); + end; end if; if Arg.Parser.Parse @@ -1108,6 +1113,7 @@ package body Gnatcheck.Projects is -- Reallow arguments that were disallowed if Args_From_Project then Allow (Arg.Transitive_Closure.This); + Allow (Arg.Project_File.This); end if; loop @@ -1115,7 +1121,7 @@ package body Gnatcheck.Projects is GNAT.Command_Line.Getopt ("v q t h hx s " & "m? files= a " & - "P: X! vP! eL A: -config! " & -- project-specific options + "X! vP! eL A: -config! " & -- project-specific options "-brief " & "-check-redefinition " & "-no_objects_dir " & @@ -1302,17 +1308,6 @@ package body Gnatcheck.Projects is end if; end if; - when 'P' => - if Full_Switch (Parser => Parser) = "P" then - if First_Pass then - My_Project.Store_Project_Source (Parameter (Parser)); - elsif Args_From_Project then - Error ("project file should not be specified inside " & - "another project file"); - raise Parameter_Error; - end if; - end if; - when 'q' => if not First_Pass then Quiet_Mode := True; diff --git a/lkql_checker/src/gnatcheck_main.adb b/lkql_checker/src/gnatcheck_main.adb index 4911130ec..bd9b90ea7 100644 --- a/lkql_checker/src/gnatcheck_main.adb +++ b/lkql_checker/src/gnatcheck_main.adb @@ -357,6 +357,12 @@ begin OS_Exit (E_Success); end if; + -- Store project file + if Arg.Project_File.Get /= Null_Unbounded_String then + Gnatcheck_Prj.Store_Project_Source + (To_String (Arg.Project_File.Get)); + end if; + -- Register GNATcheck GPR attributes Register_Tool_Attributes (Gnatcheck_Prj); From 078dab4e5f80ff39a3f0771a706e4480fc5de26d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 14 Jun 2024 12:50:40 +0200 Subject: [PATCH 05/16] Opt_Parse: Transition -A --- lkql_checker/src/gnatcheck-compiler.adb | 2 +- lkql_checker/src/gnatcheck-diagnoses.adb | 4 ++-- lkql_checker/src/gnatcheck-options.ads | 19 +++++++++++------ lkql_checker/src/gnatcheck-output.adb | 6 +++--- lkql_checker/src/gnatcheck-projects.adb | 27 +++++++----------------- lkql_checker/src/gnatcheck_main.adb | 11 ++++++++-- 6 files changed, 36 insertions(+), 33 deletions(-) diff --git a/lkql_checker/src/gnatcheck-compiler.adb b/lkql_checker/src/gnatcheck-compiler.adb index df9d22581..f1a5fc1da 100644 --- a/lkql_checker/src/gnatcheck-compiler.adb +++ b/lkql_checker/src/gnatcheck-compiler.adb @@ -1610,7 +1610,7 @@ package body Gnatcheck.Compiler is end if; end if; - if Aggregated_Project then + if Arg.Aggregated_Project then Num_Args := @ + 1; Args (Num_Args) := new String'("-A"); Num_Args := @ + 1; diff --git a/lkql_checker/src/gnatcheck-diagnoses.adb b/lkql_checker/src/gnatcheck-diagnoses.adb index d8c27e621..91fb32f87 100644 --- a/lkql_checker/src/gnatcheck-diagnoses.adb +++ b/lkql_checker/src/gnatcheck-diagnoses.adb @@ -591,7 +591,7 @@ package body Gnatcheck.Diagnoses is Prj_Out_Dot := Prj_Out_Dot - 1; end if; - if Aggregated_Project then + if Arg.Aggregated_Project then -- in case of aggregated project we have to move the index in the -- Prj_Out_File after S. That is, we do not need -- gnatcheck_1-source-list.out, we need gnatcheck-source-list_1.out @@ -863,7 +863,7 @@ package body Gnatcheck.Diagnoses is if Gnatcheck_Prj.Is_Specified then XML_Report (" project=""" & - (if Aggregated_Project then + (if Arg.Aggregated_Project then Get_Aggregated_Project else Gnatcheck_Prj.Source_Prj) & """>"); diff --git a/lkql_checker/src/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads index 3b78c2785..cef84ece6 100644 --- a/lkql_checker/src/gnatcheck-options.ads +++ b/lkql_checker/src/gnatcheck-options.ads @@ -135,12 +135,6 @@ package Gnatcheck.Options is -- such units either are not processed or the tool does not generate -- results for them). - Aggregated_Project : Boolean := False; - -- '-A - -- True if this is a tool call spawned from an original tool call with - -- aggregated project as a parameter. In this mode the tool processes only - -- one (non-aggregate) project from the projects being aggregated. - In_Aggregate_Project : Boolean := False; -- True if the tool is called for an aggregate project that aggregates more -- than one (non-aggregate) project/ @@ -335,6 +329,19 @@ package Gnatcheck.Options is Default_Val => Null_Unbounded_String, Help => "project file to use"); + -- TODO: This needs to be private (undocumented) + package Aggregate_Subproject is new Parse_Option + (Parser => Parser, + Short => "-A", + Name => "Aggregate project", + Arg_Type => Unbounded_String, + Default_Val => Null_Unbounded_String, + Help => "private flag - used when processing a subproject of " + & "a root aggregate project"); + + function Aggregated_Project return Boolean + is (Aggregate_Subproject.Get /= Null_Unbounded_String); + end Arg; end Gnatcheck.Options; diff --git a/lkql_checker/src/gnatcheck-output.adb b/lkql_checker/src/gnatcheck-output.adb index debf96dd4..41b0f7760 100644 --- a/lkql_checker/src/gnatcheck-output.adb +++ b/lkql_checker/src/gnatcheck-output.adb @@ -142,7 +142,7 @@ package body Gnatcheck.Output is Idx_1, Idx_2 : Natural; begin - if not Aggregated_Project then + if not Arg.Aggregated_Project then return ""; end if; @@ -477,7 +477,7 @@ package body Gnatcheck.Output is Mode : constant File_Mode := Out_File; Ignored : Boolean; begin - if not Aggregated_Project then + if not Arg.Aggregated_Project then if Report_File_Name /= null and then Is_Absolute_Path (Report_File_Name.all) @@ -521,7 +521,7 @@ package body Gnatcheck.Output is Mode : constant File_Mode := Out_File; Ignored : Boolean; begin - if not Aggregated_Project then + if not Arg.Aggregated_Project then if XML_Report_File_Name /= null and then Is_Absolute_Path (XML_Report_File_Name.all) then diff --git a/lkql_checker/src/gnatcheck-projects.adb b/lkql_checker/src/gnatcheck-projects.adb index 90cfdfc61..c17527751 100644 --- a/lkql_checker/src/gnatcheck-projects.adb +++ b/lkql_checker/src/gnatcheck-projects.adb @@ -136,7 +136,7 @@ package body Gnatcheck.Projects is procedure Load_Aggregated_Project (My_Project : in out Arg_Project_Type'Class) - with Pre => Aggregated_Project; + with Pre => Arg.Aggregated_Project; -- Loads My_Project (that is supposed to be an aggregate project), then -- unloads it and loads in the same environment the project passes as a -- parameter of '-A option' (which is supposed to be a (non-aggregate) @@ -549,7 +549,7 @@ package body Gnatcheck.Projects is begin Set_External_Values (My_Project); - if Aggregated_Project then + if Arg.Aggregated_Project then Load_Aggregated_Project (My_Project); else Load_Tool_Project (My_Project); @@ -1121,7 +1121,7 @@ package body Gnatcheck.Projects is GNAT.Command_Line.Getopt ("v q t h hx s " & "m? files= a " & - "X! vP! eL A: -config! " & -- project-specific options + "X! vP! eL -config! " & -- project-specific options "-brief " & "-check-redefinition " & "-no_objects_dir " & @@ -1174,19 +1174,6 @@ package body Gnatcheck.Projects is exit when not Success; - when 'A' => - if Full_Switch (Parser => Parser) = "A" then - if First_Pass then - Aggregated_Project := True; - Gnatcheck.Projects.Aggregate.Store_Aggregated_Project - (Parameter (Parser => Parser)); - elsif Args_From_Project then - Error ("project file should not be specified inside " & - "another project file"); - raise Parameter_Error; - end if; - end if; - when 'a' => -- Ignore -a for compatibility @@ -1520,7 +1507,7 @@ package body Gnatcheck.Projects is procedure Check_Parameters is begin - if Verbose_Mode and then not Aggregated_Project then + if Verbose_Mode and then not Arg.Aggregated_Project then -- When procressing aggregated projects one by one, we want -- Verbose_Mode to print this only in the outer invocation. Print_Version_Info (2004); @@ -1528,11 +1515,13 @@ package body Gnatcheck.Projects is -- We generate the rule help unconditionally - if Generate_Rules_Help then + if Generate_Rules_Help and then not Arg.Aggregated_Project then Rules_Help; end if; - if Gnatcheck.Options.Generate_XML_Help then + if Gnatcheck.Options.Generate_XML_Help + and then not Arg.Aggregated_Project + then XML_Help; end if; diff --git a/lkql_checker/src/gnatcheck_main.adb b/lkql_checker/src/gnatcheck_main.adb index bd9b90ea7..7ed34d6a0 100644 --- a/lkql_checker/src/gnatcheck_main.adb +++ b/lkql_checker/src/gnatcheck_main.adb @@ -7,6 +7,7 @@ with Ada.Calendar; with Ada.Command_Line; with Ada.Directories; with Ada.Environment_Variables; +with Ada.Strings.Unbounded; with Ada.Text_IO; use Ada.Text_IO; with Checker_App; @@ -343,6 +344,7 @@ procedure Gnatcheck_Main is end; end Schedule_Files; + use Ada.Strings.Unbounded; begin Initialize_Environment; @@ -359,8 +361,13 @@ begin -- Store project file if Arg.Project_File.Get /= Null_Unbounded_String then - Gnatcheck_Prj.Store_Project_Source - (To_String (Arg.Project_File.Get)); + Gnatcheck_Prj.Store_Project_Source (To_String (Arg.Project_File.Get)); + end if; + + -- Store aggregate subproject file + if Arg.Aggregate_Subproject.Get /= Null_Unbounded_String then + Gnatcheck.Projects.Aggregate.Store_Aggregated_Project + (To_String (Arg.Aggregate_Subproject.Get)); end if; -- Register GNATcheck GPR attributes From a3bff7458738eb395e0383702b802948177a560f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 14 Jun 2024 12:52:33 +0200 Subject: [PATCH 06/16] Opt_Parse: Transition -d* flags --- lkql_checker/src/gnatcheck-compiler.adb | 8 ++++---- lkql_checker/src/gnatcheck-diagnoses.adb | 2 +- lkql_checker/src/gnatcheck-options.ads | 20 +++++++++++-------- lkql_checker/src/gnatcheck-output.adb | 2 +- .../src/gnatcheck-projects-aggregate.adb | 2 +- lkql_checker/src/gnatcheck-projects.adb | 16 +-------------- .../src/gnatcheck-rules-rule_table.adb | 2 +- lkql_checker/src/gnatcheck-source_table.adb | 6 +++--- lkql_checker/src/gnatcheck_main.adb | 8 ++++---- 9 files changed, 28 insertions(+), 38 deletions(-) diff --git a/lkql_checker/src/gnatcheck-compiler.adb b/lkql_checker/src/gnatcheck-compiler.adb index f1a5fc1da..6085ee574 100644 --- a/lkql_checker/src/gnatcheck-compiler.adb +++ b/lkql_checker/src/gnatcheck-compiler.adb @@ -1636,7 +1636,7 @@ package body Gnatcheck.Compiler is Args (Num_Args) := new String'("--config=" & CGPR); end if; - if Debug_Mode then + if Arg.Debug_Mode.Get then Num_Args := @ + 1; Args (Num_Args) := new String'("-d"); end if; @@ -1661,7 +1661,7 @@ package body Gnatcheck.Compiler is Num_Args := @ + 1; Args (Num_Args) := new String'("--rules-from=" & Rule_File); - if Debug_Mode then + if Arg.Debug_Mode.Get then -- For debug purposes, we don't want to put the full path to the -- worker command, if it is a full path. We just want the base name Put (Base_Name (Worker.all)); @@ -1725,7 +1725,7 @@ package body Gnatcheck.Compiler is Args (Num_Args) := new String'(LKQL_RF_Name); -- Output the called command if in debug mode - if Debug_Mode then + if Arg.Debug_Mode.Get then Put (Base_Name (Worker.all)); for J in 1 .. Num_Args loop Put (" " & Args (J).all); @@ -1822,7 +1822,7 @@ package body Gnatcheck.Compiler is Append_Variables (Args, Num_Args); - if Debug_Mode then + if Arg.Debug_Mode.Get then Put (GPRbuild_Exec); for J in 1 .. Num_Args loop diff --git a/lkql_checker/src/gnatcheck-diagnoses.adb b/lkql_checker/src/gnatcheck-diagnoses.adb index 91fb32f87..a46c6b3d4 100644 --- a/lkql_checker/src/gnatcheck-diagnoses.adb +++ b/lkql_checker/src/gnatcheck-diagnoses.adb @@ -1805,7 +1805,7 @@ package body Gnatcheck.Diagnoses is function Preprocess_Diag (Diag : String) return String is begin - if Progress_Indicator_Mode then + if Arg.Progress_Indicator_Mode.Get then declare Idx : constant Natural := Index (Diag, ": "); begin diff --git a/lkql_checker/src/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads index cef84ece6..3fcdf9f92 100644 --- a/lkql_checker/src/gnatcheck-options.ads +++ b/lkql_checker/src/gnatcheck-options.ads @@ -90,14 +90,6 @@ package Gnatcheck.Options is -- Brief mode: like quiet mode except that messages are emitted on stderr -- '--brief' - Debug_Mode : Boolean := False; - -- Internal debug mode - -- '-d' - - Progress_Indicator_Mode : Boolean := False; - -- Generate the output to be used for GPS progress indicator. - -- '-dd' - Generate_XML_Help : Boolean := False; -- If this file is ON, the tool generates the XML description of the tool -- parameters to be used for creating the GUI in GPS. @@ -329,6 +321,18 @@ package Gnatcheck.Options is Default_Val => Null_Unbounded_String, Help => "project file to use"); + package Debug_Mode is new Parse_Flag + (Parser => Parser, + Short => "-d", + Name => "Debug mode", + Help => "activate debug mode"); + + package Progress_Indicator_Mode is new Parse_Flag + (Parser => Parser, + Short => "-dd", + Name => "Progress indicator mode", + Help => "activate progress indicator mode"); + -- TODO: This needs to be private (undocumented) package Aggregate_Subproject is new Parse_Option (Parser => Parser, diff --git a/lkql_checker/src/gnatcheck-output.adb b/lkql_checker/src/gnatcheck-output.adb index 41b0f7760..bd6981235 100644 --- a/lkql_checker/src/gnatcheck-output.adb +++ b/lkql_checker/src/gnatcheck-output.adb @@ -412,7 +412,7 @@ package body Gnatcheck.Output is procedure Report_Unhandled_Exception (Ex : Exception_Occurrence) is begin Error (Exception_Message (Ex)); - if not Debug_Mode then + if not Arg.Debug_Mode.Get then Put_Line (Standard_Error, GNAT.Traceback.Symbolic.Symbolic_Traceback_No_Hex (Ex)); diff --git a/lkql_checker/src/gnatcheck-projects-aggregate.adb b/lkql_checker/src/gnatcheck-projects-aggregate.adb index 8f3af2453..6c6fd218e 100644 --- a/lkql_checker/src/gnatcheck-projects-aggregate.adb +++ b/lkql_checker/src/gnatcheck-projects-aggregate.adb @@ -290,7 +290,7 @@ package body Gnatcheck.Projects.Aggregate is else "")); - if Debug_Mode then + if Arg.Debug_Mode.Get then Put (Full_Tool_Name.all); for Arg of Prj_Args loop diff --git a/lkql_checker/src/gnatcheck-projects.adb b/lkql_checker/src/gnatcheck-projects.adb index c17527751..413f28215 100644 --- a/lkql_checker/src/gnatcheck-projects.adb +++ b/lkql_checker/src/gnatcheck-projects.adb @@ -157,7 +157,7 @@ package body Gnatcheck.Projects is Gprbuild : constant String := Global_Report_Dir.all & "gprbuild.err"; begin - if not Debug_Mode then + if not Arg.Debug_Mode.Get then Delete_File (Gprbuild, Success); Delete_File (Gprbuild & ".out", Success); end if; @@ -1129,7 +1129,6 @@ package body Gnatcheck.Projects is "-target= " & "-kp-version= " & "j! " & - "d dd dkp " & "o= " & "ox= " & "-RTS= " & @@ -1179,19 +1178,6 @@ package body Gnatcheck.Projects is null; - when 'd' => - if First_Pass then - if Full_Switch (Parser => Parser) = "dkp" then - Gnatkp_Mode := True; - end if; - else - if Full_Switch (Parser => Parser) = "d" then - Debug_Mode := True; - elsif Full_Switch (Parser => Parser) = "dd" then - Progress_Indicator_Mode := True; - end if; - end if; - when 'e' => if Full_Switch (Parser => Parser) = "eL" then if First_Pass then diff --git a/lkql_checker/src/gnatcheck-rules-rule_table.adb b/lkql_checker/src/gnatcheck-rules-rule_table.adb index bec6e254b..fe1722d5e 100644 --- a/lkql_checker/src/gnatcheck-rules-rule_table.adb +++ b/lkql_checker/src/gnatcheck-rules-rule_table.adb @@ -855,7 +855,7 @@ package body Gnatcheck.Rules.Rule_Table is Map_JSON_Object (Config_JSON.Value, Rule_Object_Mapper'Access); -- Delete the temporary JSON files if not it debug mode - if not Debug_Mode then + if not Arg.Debug_Mode.Get then Delete_File (JSON_Config_File_Name, Success); Delete_File (Error_File_Name, Success); end if; diff --git a/lkql_checker/src/gnatcheck-source_table.adb b/lkql_checker/src/gnatcheck-source_table.adb index 4c16dfca5..cfea4fc44 100644 --- a/lkql_checker/src/gnatcheck-source_table.adb +++ b/lkql_checker/src/gnatcheck-source_table.adb @@ -796,7 +796,7 @@ package body Gnatcheck.Source_Table is procedure Output_Source (SF : SF_Id) is N : constant String := Natural'Image (Sources_Left); begin - if Progress_Indicator_Mode then + if Arg.Progress_Indicator_Mode.Get then declare Current : constant Integer := Total_Sources - Sources_Left + 1; Percent : String := @@ -813,7 +813,7 @@ package body Gnatcheck.Source_Table is Info_No_EOL ("[" & N (2 .. N'Last) & "] "); Info (Short_Source_Name (SF)); - elsif not (Quiet_Mode or Progress_Indicator_Mode) then + elsif not (Quiet_Mode or Arg.Progress_Indicator_Mode.Get) then Info_No_EOL ("Units remaining:"); Info_No_EOL (N); Info_No_EOL (" " & ASCII.CR); @@ -1384,7 +1384,7 @@ package body Gnatcheck.Source_Table is Check_Unclosed_Rule_Exemptions (Next_SF, Unit); exception when E : others => - if Debug_Mode then + if Arg.Debug_Mode.Get then declare Msg : constant String := File_Name (Next_SF) & ":1:01: internal error: " & diff --git a/lkql_checker/src/gnatcheck_main.adb b/lkql_checker/src/gnatcheck_main.adb index 7ed34d6a0..4aed61b73 100644 --- a/lkql_checker/src/gnatcheck_main.adb +++ b/lkql_checker/src/gnatcheck_main.adb @@ -195,7 +195,7 @@ procedure Gnatcheck_Main is Total_Jobs := Num_Jobs + (if Analyze_Compiler_Output then 1 else 0); - if not Quiet_Mode and not Progress_Indicator_Mode then + if not Quiet_Mode and not Arg.Progress_Indicator_Mode.Get then Info_No_EOL ("Jobs remaining:"); Info_No_EOL (Integer'Image (Total_Jobs) & ASCII.CR); end if; @@ -236,7 +236,7 @@ procedure Gnatcheck_Main is Current := @ + 1; - if Progress_Indicator_Mode then + if Arg.Progress_Indicator_Mode.Get then declare Percent : String := Integer'Image ((Current * 100) / Total_Jobs); @@ -263,7 +263,7 @@ procedure Gnatcheck_Main is Analyze_Output (File_Name ("out", Job), Status); Process_Found := True; - if not Debug_Mode then + if not Arg.Debug_Mode.Get then Delete_File (File_Name ("out", Job), Status); Delete_File (File_Name ("files", Job), Status); end if; @@ -338,7 +338,7 @@ procedure Gnatcheck_Main is Wait_Gnatcheck; end loop; - if not Debug_Mode then + if not Arg.Debug_Mode.Get then Delete_File (File_Name ("rules", 0), Status); end if; end; From 227c4809de0a1d1f43ec5edee254279ed1caf42c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 14 Jun 2024 12:54:49 +0200 Subject: [PATCH 07/16] Opt_Parse: Transition -X --- lkql_checker/src/gnatcheck-options.ads | 8 ++++++++ lkql_checker/src/gnatcheck-output.adb | 4 ++++ lkql_checker/src/gnatcheck-projects.adb | 16 +++------------- lkql_checker/src/gnatcheck_main.adb | 5 +++++ 4 files changed, 20 insertions(+), 13 deletions(-) diff --git a/lkql_checker/src/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads index 3fcdf9f92..ed74035a5 100644 --- a/lkql_checker/src/gnatcheck-options.ads +++ b/lkql_checker/src/gnatcheck-options.ads @@ -321,6 +321,14 @@ package Gnatcheck.Options is Default_Val => Null_Unbounded_String, Help => "project file to use"); + package Scenario_Vars is new Parse_Option_List + (Parser => Parser, + Short => "-X", + Name => "Scenario variable", + Arg_Type => Unbounded_String, + Accumulate => True, + Help => "scenario variables to pass to the project file"); + package Debug_Mode is new Parse_Flag (Parser => Parser, Short => "-d", diff --git a/lkql_checker/src/gnatcheck-output.adb b/lkql_checker/src/gnatcheck-output.adb index bd6981235..3ff920701 100644 --- a/lkql_checker/src/gnatcheck-output.adb +++ b/lkql_checker/src/gnatcheck-output.adb @@ -676,7 +676,9 @@ package body Gnatcheck.Output is -- TODO: Remove when we switch to Opt_Parse's help message Info (" --no-subprojects - process only sources of root project"); + -- TODO: Remove when we switch to Opt_Parse's help message Info (" -Xname=value - specify an external reference for argument project file"); + Info (" --subdirs=dir - specify subdirectory to place the result files into"); Info (" -eL - follow all symbolic links when processing project files"); Info (" -o filename - specify the name of the report file"); @@ -728,7 +730,9 @@ package body Gnatcheck.Output is -- TODO: Remove when we switch to Opt_Parse's help message Info (" --no-subprojects - process only sources of root project"); + -- TODO: Remove when we switch to Opt_Parse's help message Info (" -Xname=value - specify an external reference for argument project file"); + Info (" --subdirs=dir - specify subdirectory to place the result files into"); Info (" --no_objects_dir - place results into current dir instead of project dir"); Info (" -eL - follow all symbolic links when processing project files"); diff --git a/lkql_checker/src/gnatcheck-projects.adb b/lkql_checker/src/gnatcheck-projects.adb index 413f28215..f93f9888f 100644 --- a/lkql_checker/src/gnatcheck-projects.adb +++ b/lkql_checker/src/gnatcheck-projects.adb @@ -1096,6 +1096,7 @@ package body Gnatcheck.Projects is begin Disallow (Arg.Project_File.This, In_Project_Msg); Disallow (Arg.Transitive_Closure.This, In_Project_Msg); + Disallow (Arg.Scenario_Vars.This, In_Project_Msg); end; end if; @@ -1114,6 +1115,7 @@ package body Gnatcheck.Projects is if Args_From_Project then Allow (Arg.Transitive_Closure.This); Allow (Arg.Project_File.This); + Allow (Arg.Scenario_Vars.This); end if; loop @@ -1121,7 +1123,7 @@ package body Gnatcheck.Projects is GNAT.Command_Line.Getopt ("v q t h hx s " & "m? files= a " & - "X! vP! eL -config! " & -- project-specific options + "vP! eL -config! " & -- project-specific options "-brief " & "-check-redefinition " & "-no_objects_dir " & @@ -1323,18 +1325,6 @@ package body Gnatcheck.Projects is end if; end if; - when 'X' => - if Full_Switch (Parser => Parser) = "X" then - if First_Pass then - Gnatcheck.Projects.Store_External_Variable - (Var => Parameter (Parser => Parser)); - elsif Args_From_Project then - Error ("external references cannot be set in " & - "a project file"); - raise Parameter_Error; - end if; - end if; - when '-' => if not First_Pass then if Full_Switch (Parser => Parser) = "-brief" then diff --git a/lkql_checker/src/gnatcheck_main.adb b/lkql_checker/src/gnatcheck_main.adb index 4aed61b73..d0994d3a1 100644 --- a/lkql_checker/src/gnatcheck_main.adb +++ b/lkql_checker/src/gnatcheck_main.adb @@ -370,6 +370,11 @@ begin (To_String (Arg.Aggregate_Subproject.Get)); end if; + -- Store scenario variables + for Var of Arg.Scenario_Vars.Get loop + Store_External_Variable (To_String (Var)); + end loop; + -- Register GNATcheck GPR attributes Register_Tool_Attributes (Gnatcheck_Prj); From 948d3021173fc9d17950bd22cee448a7b4336797 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Mon, 17 Jun 2024 11:50:00 +0200 Subject: [PATCH 08/16] Opt_Parse: Add custom error handler --- lkql_checker/src/gnatcheck-options.adb | 14 ++++++++++++++ lkql_checker/src/gnatcheck-options.ads | 14 +++++++++++--- 2 files changed, 25 insertions(+), 3 deletions(-) create mode 100644 lkql_checker/src/gnatcheck-options.adb diff --git a/lkql_checker/src/gnatcheck-options.adb b/lkql_checker/src/gnatcheck-options.adb new file mode 100644 index 000000000..8988f6e1d --- /dev/null +++ b/lkql_checker/src/gnatcheck-options.adb @@ -0,0 +1,14 @@ +with Gnatcheck.Output; use Gnatcheck.Output; + +package body Gnatcheck.Options is + procedure Warning (Self : in out Gnatcheck_Error_Handler; Msg : String) is + begin + Warning (Msg); + end Warning; + + procedure Error (Self : in out Gnatcheck_Error_Handler; Msg : String) is + begin + Error (Msg); + end Error; + +end Gnatcheck.Options; diff --git a/lkql_checker/src/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads index ed74035a5..ab66e6afb 100644 --- a/lkql_checker/src/gnatcheck-options.ads +++ b/lkql_checker/src/gnatcheck-options.ads @@ -273,11 +273,19 @@ package Gnatcheck.Options is Gnatcheck_Prj : aliased Gnatcheck.Projects.Arg_Project_Type; + type Gnatcheck_Error_Handler is new Error_Handler with null record; + + procedure Warning (Self : in out Gnatcheck_Error_Handler; Msg : String); + procedure Error (Self : in out Gnatcheck_Error_Handler; Msg : String); + procedure On_Fail (Self : in out Gnatcheck_Error_Handler); + package Arg is Parser : Argument_Parser := Create_Argument_Parser - (Help => "GNATcheck help", - Incremental => True, - Generate_Help_Flag => False); + (Help => "GNATcheck help", + Incremental => True, + Generate_Help_Flag => False, + Custom_Error_Handler => + Create (Gnatcheck_Error_Handler'(null record))); package Check_Semantic is new Parse_Flag (Parser => Parser, From 70e7e504b6d96bcc4ee66e760cdbbf82ab729c93 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Mon, 17 Jun 2024 11:50:17 +0200 Subject: [PATCH 09/16] Opt_Parse: Transition --config/--target --- lkql_checker/src/gnatcheck-compiler.adb | 10 ++-- lkql_checker/src/gnatcheck-options.ads | 18 +++++- lkql_checker/src/gnatcheck-output.adb | 9 +++ lkql_checker/src/gnatcheck-projects.adb | 57 ++++--------------- .../src/gnatcheck-rules-rule_table.adb | 4 +- lkql_checker/src/gnatcheck_main.adb | 8 +++ 6 files changed, 53 insertions(+), 53 deletions(-) diff --git a/lkql_checker/src/gnatcheck-compiler.adb b/lkql_checker/src/gnatcheck-compiler.adb index 6085ee574..f238eb68c 100644 --- a/lkql_checker/src/gnatcheck-compiler.adb +++ b/lkql_checker/src/gnatcheck-compiler.adb @@ -1524,11 +1524,12 @@ package body Gnatcheck.Compiler is ---------------- function Gnatls_Exec return String is + use Ada.Strings.Unbounded; begin if Has_Access_To_Codepeer then return "codepeer-gnatls"; - elsif Target.all /= "" then - return Target.all & "-gnatls"; + elsif To_String (Target) /= "" then + return To_String (Target) & "-gnatls"; else return "gnatls"; end if; @@ -1578,6 +1579,7 @@ package body Gnatcheck.Compiler is Args : Argument_List (1 .. 128); Num_Args : Integer := 0; + use Ada.Strings.Unbounded; begin -- Split the worker command into the name of the executable plus its -- arguments. We do that because the call to Non_Blocking_Spawn expects @@ -1623,9 +1625,9 @@ package body Gnatcheck.Compiler is Args (Num_Args) := new String'("--RTS=" & RTS_Path.all); end if; - if Target.all /= "" then + if Target /= Null_Unbounded_String then Num_Args := @ + 1; - Args (Num_Args) := new String'("--target=" & Target.all); + Args (Num_Args) := new String'("--target=" & To_String (Target)); elsif Has_Access_To_Codepeer then Num_Args := @ + 1; Args (Num_Args) := new String'("--target=codepeer"); diff --git a/lkql_checker/src/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads index ab66e6afb..843e2d059 100644 --- a/lkql_checker/src/gnatcheck-options.ads +++ b/lkql_checker/src/gnatcheck-options.ads @@ -48,7 +48,7 @@ package Gnatcheck.Options is RTS_Path : GNAT.OS_Lib.String_Access := new String'(""); -- Runtime as specified via --RTS= or Runtime attribute - Target : GNAT.OS_Lib.String_Access := new String'(""); + Target : Unbounded_String := Null_Unbounded_String; -- Target as it is specified by the command-line '--target=...' option, or -- by the 'Target attribute in the argument project file. @@ -337,6 +337,22 @@ package Gnatcheck.Options is Accumulate => True, Help => "scenario variables to pass to the project file"); + package Config_File is new Parse_Option + (Parser => Parser, + Long => "--config", + Arg_Type => Unbounded_String, + Default_Val => Null_Unbounded_String, + Help => "name of the configuration project file. If passed, " + & "this file must exist and neither --target nor --RTS" + & "must be passed."); + + package Target is new Parse_Option + (Parser => Parser, + Long => "--target", + Arg_Type => Unbounded_String, + Default_Val => Null_Unbounded_String, + Help => "name of the target to use when loading the project"); + package Debug_Mode is new Parse_Flag (Parser => Parser, Short => "-d", diff --git a/lkql_checker/src/gnatcheck-output.adb b/lkql_checker/src/gnatcheck-output.adb index 3ff920701..fd603d6ec 100644 --- a/lkql_checker/src/gnatcheck-output.adb +++ b/lkql_checker/src/gnatcheck-output.adb @@ -683,7 +683,10 @@ package body Gnatcheck.Output is Info (" -eL - follow all symbolic links when processing project files"); Info (" -o filename - specify the name of the report file"); Info (""); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" --target=targetname - specify a target for cross platforms"); + Info (" --RTS= - use runtime "); Info (""); Info (" -h - print out the list of the available kp detectors"); @@ -738,9 +741,15 @@ package body Gnatcheck.Output is Info (" -eL - follow all symbolic links when processing project files"); Info (""); Info (" --ignore-project-switches - ignore switches specified in the project file"); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" --target=targetname - specify a target for cross platforms"); + Info (" --RTS= - use runtime "); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" --config= - use configuration project "); + Info (""); Info (" -h - print out the list of the currently implemented rules"); Info (" -mn - n is the maximal number of diagnoses in Stderr"); diff --git a/lkql_checker/src/gnatcheck-projects.adb b/lkql_checker/src/gnatcheck-projects.adb index f93f9888f..61a005e18 100644 --- a/lkql_checker/src/gnatcheck-projects.adb +++ b/lkql_checker/src/gnatcheck-projects.adb @@ -417,21 +417,16 @@ package body Gnatcheck.Projects is -- Load_Tool_Project -- ----------------------- - ----------------------- - -- Load_Tool_Project -- - ----------------------- - procedure Load_Tool_Project (My_Project : in out Arg_Project_Type'Class; Load_Sources : Boolean := True) is - use GPR2; use GPR2.Containers; + use Ada.Strings.Unbounded; Log : GPR2.Log.Object; Has_Error : Boolean; - begin -- Set reporting verbosity when loading the project tree and the sources if Verbose_Mode then @@ -467,8 +462,8 @@ package body Gnatcheck.Projects is Project_Options.Add_Switch (GPR2.Options.RTS, RTS_Path.all); end if; - if Target.all /= "" then - Project_Options.Add_Switch (GPR2.Options.Target, Target.all); + if Target /= "" then + Project_Options.Add_Switch (GPR2.Options.Target, To_String (Target)); end if; if Follow_Symbolic_Links then @@ -507,8 +502,7 @@ package body Gnatcheck.Projects is Gnatcheck.Projects.Aggregate.Collect_Aggregated_Projects (My_Project.Tree); - Free (Target); - Target := new String'(String (My_Project.Tree.Target)); + Set_Unbounded_String (Target, String (My_Project.Tree.Target)); end if; My_Project.Tree.Update_Sources (Messages => Log); @@ -1094,6 +1088,7 @@ package body Gnatcheck.Projects is declare In_Project_Msg : constant String := "forbidden in project file"; begin + Disallow (Arg.Aggregate_Subproject.This, In_Project_Msg); Disallow (Arg.Project_File.This, In_Project_Msg); Disallow (Arg.Transitive_Closure.This, In_Project_Msg); Disallow (Arg.Scenario_Vars.This, In_Project_Msg); @@ -1114,8 +1109,9 @@ package body Gnatcheck.Projects is -- Reallow arguments that were disallowed if Args_From_Project then Allow (Arg.Transitive_Closure.This); - Allow (Arg.Project_File.This); Allow (Arg.Scenario_Vars.This); + Allow (Arg.Aggregate_Subproject.This); + Allow (Arg.Project_File.This); end if; loop @@ -1123,12 +1119,11 @@ package body Gnatcheck.Projects is GNAT.Command_Line.Getopt ("v q t h hx s " & "m? files= a " & - "vP! eL -config! " & -- project-specific options + "vP! eL " & -- project-specific options "-brief " & "-check-redefinition " & "-no_objects_dir " & "-subdirs= " & - "-target= " & "-kp-version= " & "j! " & "o= " & @@ -1388,41 +1383,10 @@ package body Gnatcheck.Projects is then Ignore_Project_Switches := True; - elsif Full_Switch (Parser => Parser) = "-target" then - Free (Target); - Target := new String'(Parameter (Parser => Parser)); - elsif Full_Switch (Parser => Parser) = "-RTS" then Free (RTS_Path); RTS_Path := new String'(Parameter (Parser => Parser)); - elsif Full_Switch (Parser => Parser) = "-config" then - if Args_From_Project then - Error ("configuration project cannot be set in " & - "a project file"); - raise Parameter_Error; - else - declare - Arg : constant String := - Parameter (Parser => Parser); - begin - -- Mimicking gprtools behaviour, --config accepts - -- only '=' as a delimiter. - if Arg'Length > 1 and then Arg (Arg'First) = '=' - then - My_Project.Store_CGPR_Source - (Arg (Arg'First + 1 .. Arg'Last)); - else - Error - ("invalid switch: " - & Full_Switch (Parser => Parser) - & Parameter (Parser => Parser)); - raise Parameter_Error; - end if; - - end; - end if; - elsif Full_Switch (Parser => Parser) = "-subdirs" then Set_Subdir_Name (Parameter (Parser => Parser)); @@ -1482,6 +1446,7 @@ package body Gnatcheck.Projects is ---------------------- procedure Check_Parameters is + use Ada.Strings.Unbounded; begin if Verbose_Mode and then not Arg.Aggregated_Project then -- When procressing aggregated projects one by one, we want @@ -1574,8 +1539,8 @@ package body Gnatcheck.Projects is and then Match (KP_Version.all, Rule.Impact.all) then if Rule.Target /= null - and then Target.all /= "" - and then not Match (Target.all, Rule.Target.all) + and then Target /= Null_Unbounded_String + and then not Match (To_String (Target), Rule.Target.all) then if not Quiet_Mode then Info diff --git a/lkql_checker/src/gnatcheck-rules-rule_table.adb b/lkql_checker/src/gnatcheck-rules-rule_table.adb index fe1722d5e..50d20b600 100644 --- a/lkql_checker/src/gnatcheck-rules-rule_table.adb +++ b/lkql_checker/src/gnatcheck-rules-rule_table.adb @@ -1362,8 +1362,8 @@ package body Gnatcheck.Rules.Rule_Table is (Match (KP_Version.all, All_Rules (Rule).Impact.all) and then (All_Rules (Rule).Target = null - or else Target.all = "" - or else Match (Target.all, + or else To_String (Target) = "" + or else Match (To_String (Target), All_Rules (Rule).Target.all))) then Set.Include (All_Rules (Rule)); diff --git a/lkql_checker/src/gnatcheck_main.adb b/lkql_checker/src/gnatcheck_main.adb index d0994d3a1..238c0c547 100644 --- a/lkql_checker/src/gnatcheck_main.adb +++ b/lkql_checker/src/gnatcheck_main.adb @@ -375,6 +375,14 @@ begin Store_External_Variable (To_String (Var)); end loop; + -- Store .cgpr + if Arg.Config_File.Get /= Null_Unbounded_String then + Gnatcheck_Prj.Store_CGPR_Source (To_String (Arg.Config_File.Get)); + end if; + + -- Store target from project file + Gnatcheck.Options.Target := Arg.Target.Get; + -- Register GNATcheck GPR attributes Register_Tool_Attributes (Gnatcheck_Prj); From 3ea4396477727194c5311caeb2d5ef7042654fd8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 14 Jun 2024 14:50:56 +0200 Subject: [PATCH 10/16] Opt_Parse: Transition --RTS --- lkql_checker/src/gnatcheck-compiler.adb | 4 ++-- lkql_checker/src/gnatcheck-diagnoses.adb | 6 +++--- lkql_checker/src/gnatcheck-options.ads | 10 +++++++++- lkql_checker/src/gnatcheck-output.adb | 5 +---- lkql_checker/src/gnatcheck-projects.adb | 17 ++++++----------- lkql_checker/src/gnatcheck_main.adb | 3 +++ 6 files changed, 24 insertions(+), 21 deletions(-) diff --git a/lkql_checker/src/gnatcheck-compiler.adb b/lkql_checker/src/gnatcheck-compiler.adb index f238eb68c..a8b42bb83 100644 --- a/lkql_checker/src/gnatcheck-compiler.adb +++ b/lkql_checker/src/gnatcheck-compiler.adb @@ -1620,9 +1620,9 @@ package body Gnatcheck.Compiler is end if; if CGPR = "" then - if RTS_Path.all /= "" then + if RTS_Path /= Null_Unbounded_String then Num_Args := @ + 1; - Args (Num_Args) := new String'("--RTS=" & RTS_Path.all); + Args (Num_Args) := new String'("--RTS=" & To_String (RTS_Path)); end if; if Target /= Null_Unbounded_String then diff --git a/lkql_checker/src/gnatcheck-diagnoses.adb b/lkql_checker/src/gnatcheck-diagnoses.adb index a46c6b3d4..1ce5ffdaa 100644 --- a/lkql_checker/src/gnatcheck-diagnoses.adb +++ b/lkql_checker/src/gnatcheck-diagnoses.adb @@ -1952,11 +1952,11 @@ package body Gnatcheck.Diagnoses is procedure Print_Runtime (XML : Boolean := False) is begin - if RTS_Path.all /= "" then + if RTS_Path /= Null_Unbounded_String then if XML then - XML_Report (RTS_Path.all); + XML_Report (To_String (RTS_Path)); else - Report (RTS_Path.all); + Report (To_String (RTS_Path)); end if; else if XML then diff --git a/lkql_checker/src/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads index 843e2d059..0d7975faa 100644 --- a/lkql_checker/src/gnatcheck-options.ads +++ b/lkql_checker/src/gnatcheck-options.ads @@ -45,7 +45,7 @@ package Gnatcheck.Options is else Default_Worker); -- The name of the worker to use. - RTS_Path : GNAT.OS_Lib.String_Access := new String'(""); + RTS_Path : Unbounded_String := Null_Unbounded_String; -- Runtime as specified via --RTS= or Runtime attribute Target : Unbounded_String := Null_Unbounded_String; @@ -353,6 +353,14 @@ package Gnatcheck.Options is Default_Val => Null_Unbounded_String, Help => "name of the target to use when loading the project"); + package RTS is new Parse_Option + (Parser => Parser, + Long => "--RTS", + Arg_Type => Unbounded_String, + Default_Val => Null_Unbounded_String, + Help => "name of the runtime (RTS) to use when loading the " + & "project"); + package Debug_Mode is new Parse_Flag (Parser => Parser, Short => "-d", diff --git a/lkql_checker/src/gnatcheck-output.adb b/lkql_checker/src/gnatcheck-output.adb index fd603d6ec..48c78ff5a 100644 --- a/lkql_checker/src/gnatcheck-output.adb +++ b/lkql_checker/src/gnatcheck-output.adb @@ -686,8 +686,8 @@ package body Gnatcheck.Output is -- TODO: Remove when we switch to Opt_Parse's help message Info (" --target=targetname - specify a target for cross platforms"); - Info (" --RTS= - use runtime "); + Info (""); Info (" -h - print out the list of the available kp detectors"); Info (" -jn - n is the maximal number of processes"); @@ -744,10 +744,7 @@ package body Gnatcheck.Output is -- TODO: Remove when we switch to Opt_Parse's help message Info (" --target=targetname - specify a target for cross platforms"); - Info (" --RTS= - use runtime "); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" --config= - use configuration project "); Info (""); diff --git a/lkql_checker/src/gnatcheck-projects.adb b/lkql_checker/src/gnatcheck-projects.adb index 61a005e18..a956d180c 100644 --- a/lkql_checker/src/gnatcheck-projects.adb +++ b/lkql_checker/src/gnatcheck-projects.adb @@ -458,11 +458,11 @@ package body Gnatcheck.Projects is Project_Options.Add_Switch (GPR2.Options.Subdirs, Subdir_Name.all); end if; - if RTS_Path.all /= "" then - Project_Options.Add_Switch (GPR2.Options.RTS, RTS_Path.all); + if RTS_Path /= Null_Unbounded_String then + Project_Options.Add_Switch (GPR2.Options.RTS, To_String (RTS_Path)); end if; - if Target /= "" then + if Target /= Null_Unbounded_String then Project_Options.Add_Switch (GPR2.Options.Target, To_String (Target)); end if; @@ -484,12 +484,12 @@ package body Gnatcheck.Projects is raise Parameter_Error; end if; - if RTS_Path.all = "" + if RTS_Path = Null_Unbounded_String and then My_Project.Tree.Runtime (Ada_Language) /= "" then - Free (RTS_Path); RTS_Path := - new String'(String (My_Project.Tree.Runtime (Ada_Language))); + To_Unbounded_String + (String (My_Project.Tree.Runtime (Ada_Language))); end if; if Load_Sources then @@ -1128,7 +1128,6 @@ package body Gnatcheck.Projects is "j! " & "o= " & "ox= " & - "-RTS= " & "l log " & "-include-file= " & "-show-rule " & @@ -1383,10 +1382,6 @@ package body Gnatcheck.Projects is then Ignore_Project_Switches := True; - elsif Full_Switch (Parser => Parser) = "-RTS" then - Free (RTS_Path); - RTS_Path := new String'(Parameter (Parser => Parser)); - elsif Full_Switch (Parser => Parser) = "-subdirs" then Set_Subdir_Name (Parameter (Parser => Parser)); diff --git a/lkql_checker/src/gnatcheck_main.adb b/lkql_checker/src/gnatcheck_main.adb index 238c0c547..0097f4c68 100644 --- a/lkql_checker/src/gnatcheck_main.adb +++ b/lkql_checker/src/gnatcheck_main.adb @@ -383,6 +383,9 @@ begin -- Store target from project file Gnatcheck.Options.Target := Arg.Target.Get; + -- Store target from project file + Gnatcheck.Options.RTS_Path := Arg.RTS.Get; + -- Register GNATcheck GPR attributes Register_Tool_Attributes (Gnatcheck_Prj); From a1d1410cba531822abf8e7fc15fda9551ca85438 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 14 Jun 2024 16:18:41 +0200 Subject: [PATCH 11/16] Opt_Parse: Transition -eL --- lkql_checker/src/gnatcheck-compiler.adb | 4 ++-- lkql_checker/src/gnatcheck-options.ads | 6 ++++++ lkql_checker/src/gnatcheck-output.adb | 6 ++++++ lkql_checker/src/gnatcheck-projects.adb | 14 +++----------- lkql_checker/src/gnatcheck-projects.ads | 6 ------ 5 files changed, 17 insertions(+), 19 deletions(-) diff --git a/lkql_checker/src/gnatcheck-compiler.adb b/lkql_checker/src/gnatcheck-compiler.adb index a8b42bb83..a8c4a812c 100644 --- a/lkql_checker/src/gnatcheck-compiler.adb +++ b/lkql_checker/src/gnatcheck-compiler.adb @@ -1643,7 +1643,7 @@ package body Gnatcheck.Compiler is Args (Num_Args) := new String'("-d"); end if; - if Follow_Symbolic_Links then + if Arg.Follow_Symbolic_Links.Get then Num_Args := @ + 1; Args (Num_Args) := new String'("-eL"); end if; @@ -1791,7 +1791,7 @@ package body Gnatcheck.Compiler is Args (Num_Args) := new String'("-P" & Prj); end if; - if Follow_Symbolic_Links then + if Arg.Follow_Symbolic_Links.Get then Num_Args := @ + 1; Args (Num_Args) := new String'("-eL"); end if; diff --git a/lkql_checker/src/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads index 0d7975faa..36325c8ff 100644 --- a/lkql_checker/src/gnatcheck-options.ads +++ b/lkql_checker/src/gnatcheck-options.ads @@ -383,6 +383,12 @@ package Gnatcheck.Options is Help => "private flag - used when processing a subproject of " & "a root aggregate project"); + package Follow_Symbolic_Links is new Parse_Flag + (Parser => Parser, + Short => "-eL", + Name => "Follow symbolic links", + Help => "follow all symbolic links when processing project files"); + function Aggregated_Project return Boolean is (Aggregate_Subproject.Get /= Null_Unbounded_String); diff --git a/lkql_checker/src/gnatcheck-output.adb b/lkql_checker/src/gnatcheck-output.adb index 48c78ff5a..0449add39 100644 --- a/lkql_checker/src/gnatcheck-output.adb +++ b/lkql_checker/src/gnatcheck-output.adb @@ -680,7 +680,10 @@ package body Gnatcheck.Output is Info (" -Xname=value - specify an external reference for argument project file"); Info (" --subdirs=dir - specify subdirectory to place the result files into"); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" -eL - follow all symbolic links when processing project files"); + Info (" -o filename - specify the name of the report file"); Info (""); @@ -738,7 +741,10 @@ package body Gnatcheck.Output is Info (" --subdirs=dir - specify subdirectory to place the result files into"); Info (" --no_objects_dir - place results into current dir instead of project dir"); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" -eL - follow all symbolic links when processing project files"); + Info (""); Info (" --ignore-project-switches - ignore switches specified in the project file"); diff --git a/lkql_checker/src/gnatcheck-projects.adb b/lkql_checker/src/gnatcheck-projects.adb index a956d180c..31bdb7fc6 100644 --- a/lkql_checker/src/gnatcheck-projects.adb +++ b/lkql_checker/src/gnatcheck-projects.adb @@ -1092,6 +1092,7 @@ package body Gnatcheck.Projects is Disallow (Arg.Project_File.This, In_Project_Msg); Disallow (Arg.Transitive_Closure.This, In_Project_Msg); Disallow (Arg.Scenario_Vars.This, In_Project_Msg); + Disallow (Arg.Follow_Symbolic_Links.This, In_Project_Msg); end; end if; @@ -1112,6 +1113,7 @@ package body Gnatcheck.Projects is Allow (Arg.Scenario_Vars.This); Allow (Arg.Aggregate_Subproject.This); Allow (Arg.Project_File.This); + Allow (Arg.Follow_Symbolic_Links.This); end if; loop @@ -1119,7 +1121,7 @@ package body Gnatcheck.Projects is GNAT.Command_Line.Getopt ("v q t h hx s " & "m? files= a " & - "vP! eL " & -- project-specific options + "vP!" & -- project-specific options "-brief " & "-check-redefinition " & "-no_objects_dir " & @@ -1174,16 +1176,6 @@ package body Gnatcheck.Projects is null; - when 'e' => - if Full_Switch (Parser => Parser) = "eL" then - if First_Pass then - Gnatcheck.Projects.Follow_Symbolic_Links := True; - elsif Args_From_Project then - Error ("-eL option cannot be set in a project file"); - raise Parameter_Error; - end if; - end if; - when 'f' => if Full_Switch (Parser => Parser) = "files" then File_List_Specified := True; diff --git a/lkql_checker/src/gnatcheck-projects.ads b/lkql_checker/src/gnatcheck-projects.ads index 4caddf703..fbe9b53bf 100644 --- a/lkql_checker/src/gnatcheck-projects.ads +++ b/lkql_checker/src/gnatcheck-projects.ads @@ -100,12 +100,6 @@ package Gnatcheck.Projects is -- Project-specific options -- ------------------------------ - --------------------------------------------------------------------- - -- -eL : Follow all symbolic links when processing project files. -- - --------------------------------------------------------------------- - - Follow_Symbolic_Links : Boolean := False; - ------------------------------------------------------ -- -vPn : verbosity level on project file analysis -- ------------------------------------------------------ From 49905326d92f9a8e33090099260748375fa049b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 14 Jun 2024 17:07:54 +0200 Subject: [PATCH 12/16] Opt_Parse: Transition Brief/Short/Quiet flags --- lkql_checker/src/gnatcheck-diagnoses.adb | 26 +++++++-------- lkql_checker/src/gnatcheck-options.ads | 36 +++++++++++++-------- lkql_checker/src/gnatcheck-output.adb | 10 ++++++ lkql_checker/src/gnatcheck-projects.adb | 24 +++----------- lkql_checker/src/gnatcheck-source_table.adb | 2 +- lkql_checker/src/gnatcheck_main.adb | 6 ++-- 6 files changed, 54 insertions(+), 50 deletions(-) diff --git a/lkql_checker/src/gnatcheck-diagnoses.adb b/lkql_checker/src/gnatcheck-diagnoses.adb index 1ce5ffdaa..1ec261815 100644 --- a/lkql_checker/src/gnatcheck-diagnoses.adb +++ b/lkql_checker/src/gnatcheck-diagnoses.adb @@ -874,7 +874,7 @@ package body Gnatcheck.Diagnoses is -- OVERVIEW - if not Short_Report then + if not Arg.Short_Report then Print_Report_Header; Print_Active_Rules_File; Print_File_List_File; @@ -912,12 +912,12 @@ package body Gnatcheck.Diagnoses is Report ("no exempted violations detected", 1); end if; - if not Short_Report and then XML_Report_ON then + if not Arg.Short_Report and then XML_Report_ON then XML_Report ("no exempted violations detected", 1); end if; end if; - if not Short_Report then + if not Arg.Short_Report then if Text_Report_ON then Report_EOL; Report ("3. Non-exempted Coding Standard Violations"); @@ -938,12 +938,12 @@ package body Gnatcheck.Diagnoses is Report ("no non-exempted violations detected", 1); end if; - if not Short_Report and then XML_Report_ON then + if not Arg.Short_Report and then XML_Report_ON then XML_Report ("no non-exempted violations detected", 1); end if; end if; - if not Short_Report then + if not Arg.Short_Report then if Text_Report_ON then Report_EOL; Report ("4. Rule exemption problems"); @@ -963,13 +963,13 @@ package body Gnatcheck.Diagnoses is Report ("no rule exemption problems detected", 1); end if; - if not Short_Report and then XML_Report_ON then + if not Arg.Short_Report and then XML_Report_ON then XML_Report ("no rule exemption problems detected", 1); end if; end if; - if not Short_Report then + if not Arg.Short_Report then if Text_Report_ON then Report_EOL; Report ("5. Language violations"); @@ -989,12 +989,12 @@ package body Gnatcheck.Diagnoses is Report ("no language violations detected", 1); end if; - if not Short_Report and then XML_Report_ON then + if not Arg.Short_Report and then XML_Report_ON then XML_Report ("no language violations detected", 1); end if; end if; - if not Short_Report then + if not Arg.Short_Report then if Text_Report_ON then Report_EOL; Report ("6. Gnatcheck internal errors"); @@ -1014,14 +1014,14 @@ package body Gnatcheck.Diagnoses is Report ("no internal error detected", 1); end if; - if not Short_Report and then XML_Report_ON then + if not Arg.Short_Report and then XML_Report_ON then XML_Report ("no internal error detected", 1); end if; end if; -- User-defined part - if not Short_Report then + if not Arg.Short_Report then if XML_Report_ON then XML_Report (""); end if; @@ -1058,7 +1058,7 @@ package body Gnatcheck.Diagnoses is -- Sending the diagnoses into Stderr - if Brief_Mode or not Quiet_Mode then + if Arg.Brief_Mode or not Arg.Quiet_Mode then Print_Out_Diagnoses; end if; end Generate_Qualification_Report; @@ -1594,7 +1594,7 @@ package body Gnatcheck.Diagnoses is end if; if XML_Report_ON then - XML_Report_Diagnosis (Diag, Short_Report); + XML_Report_Diagnosis (Diag, Arg.Short_Report); end if; end if; end Print_Specified_Diagnoses; diff --git a/lkql_checker/src/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads index 36325c8ff..dfeb0c42b 100644 --- a/lkql_checker/src/gnatcheck-options.ads +++ b/lkql_checker/src/gnatcheck-options.ads @@ -82,14 +82,6 @@ package Gnatcheck.Options is -- The verbose mode. -- '-v' - Quiet_Mode : Boolean := False; - -- Quiet mode, do not emit messages on stderr - -- '-q' - - Brief_Mode : Boolean := False; - -- Brief mode: like quiet mode except that messages are emitted on stderr - -- '--brief' - Generate_XML_Help : Boolean := False; -- If this file is ON, the tool generates the XML description of the tool -- parameters to be used for creating the GUI in GPS. @@ -223,11 +215,6 @@ package Gnatcheck.Options is -- Controlling the gnatcheck report -- -------------------------------------- - Short_Report : Boolean := False; - -- '-s' - -- Print the short version of the report file. - -- Only diagnoses are included in the report file. - Max_Diagnoses : Natural := 0; -- '-m' -- Maximum number of diagnoses to print out into Stdout. Zero means that @@ -392,6 +379,29 @@ package Gnatcheck.Options is function Aggregated_Project return Boolean is (Aggregate_Subproject.Get /= Null_Unbounded_String); + package Quiet is new Parse_Flag + (Parser => Parser, + Short => "-q", + Name => "Quiet mode", + Help => "quiet mode, do not emit messages on stderr"); + + package Brief is new Parse_Flag + (Parser => Parser, + Long => "--brief", + Help => "brief mode: like quiet mode except that messages are " + & "emitted on stderr"); + + package Short is new Parse_Flag + (Parser => Parser, + Short => "-s", + Name => "Short report", + Help => "print the short version of the report file"); + + function Quiet_Mode return Boolean is (Quiet.Get or else Brief.Get); + + function Short_Report return Boolean is (Brief.Get or else Short.Get); + + function Brief_Mode return Boolean is (Brief.Get); end Arg; end Gnatcheck.Options; diff --git a/lkql_checker/src/gnatcheck-output.adb b/lkql_checker/src/gnatcheck-output.adb index 0449add39..faa362a99 100644 --- a/lkql_checker/src/gnatcheck-output.adb +++ b/lkql_checker/src/gnatcheck-output.adb @@ -694,10 +694,15 @@ package body Gnatcheck.Output is Info (""); Info (" -h - print out the list of the available kp detectors"); Info (" -jn - n is the maximal number of processes"); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" -q - quiet mode (do not report detections in Stderr)"); + Info (" -v - verbose mode"); Info (" -l - full pathname for file locations"); Info (""); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" --brief - brief mode, only report detections in Stderr"); -- TODO: Remove when we switch to Opt_Parse's help message @@ -763,7 +768,10 @@ package body Gnatcheck.Output is Info (" -v - verbose mode"); Info (" -l - full pathname for file locations"); Info (" -log - duplicate all the messages sent to Stderr in gnatcheck.log"); + + -- TODO: Remove when we switch to Opt_Parse's help message Info (" -s - short form of the report file"); + Info (" -xml - generate report in XML format"); Info (" -nt - do not generate text report (enforces '-xml')"); Info (""); @@ -771,7 +779,9 @@ package body Gnatcheck.Output is Info (" --show-rule - append rule names to diagnoses generated"); Info (""); + -- TODO: Remove when we switch to Opt_Parse's help message Info (" --brief - brief mode, only report detections in Stderr"); + Info (" --check-redefinition - issue warning if a rule parameter is redefined"); -- TODO: Remove when we switch to Opt_Parse's help message diff --git a/lkql_checker/src/gnatcheck-projects.adb b/lkql_checker/src/gnatcheck-projects.adb index 31bdb7fc6..df424ec70 100644 --- a/lkql_checker/src/gnatcheck-projects.adb +++ b/lkql_checker/src/gnatcheck-projects.adb @@ -1119,10 +1119,9 @@ package body Gnatcheck.Projects is loop Initial_Char := GNAT.Command_Line.Getopt - ("v q t h hx s " & + ("v t h hx " & "m? files= a " & "vP!" & -- project-specific options - "-brief " & "-check-redefinition " & "-no_objects_dir " & "-subdirs= " & @@ -1269,16 +1268,6 @@ package body Gnatcheck.Projects is end if; end if; - when 'q' => - if not First_Pass then - Quiet_Mode := True; - end if; - - when 's' => - if not First_Pass then - Short_Report := True; - end if; - when 't' => if not First_Pass then Compute_Timing := True; @@ -1313,12 +1302,7 @@ package body Gnatcheck.Projects is when '-' => if not First_Pass then - if Full_Switch (Parser => Parser) = "-brief" then - Quiet_Mode := True; - Short_Report := True; - Brief_Mode := True; - - elsif Full_Switch (Parser => Parser) = "-check-redefinition" + if Full_Switch (Parser => Parser) = "-check-redefinition" then Check_Param_Redefinition := True; elsif Full_Switch (Parser => Parser) = "-ignore" then @@ -1529,14 +1513,14 @@ package body Gnatcheck.Projects is and then Target /= Null_Unbounded_String and then not Match (To_String (Target), Rule.Target.all) then - if not Quiet_Mode then + if not Arg.Quiet_Mode then Info ("info: " & Ada.Strings.Unbounded.To_String (Rule.Name) & " disabled, target does not match"); end if; else - if not Quiet_Mode then + if not Arg.Quiet_Mode then Info ("info: " & Ada.Strings.Unbounded.To_String (Rule.Name) & diff --git a/lkql_checker/src/gnatcheck-source_table.adb b/lkql_checker/src/gnatcheck-source_table.adb index cfea4fc44..a84842a3f 100644 --- a/lkql_checker/src/gnatcheck-source_table.adb +++ b/lkql_checker/src/gnatcheck-source_table.adb @@ -813,7 +813,7 @@ package body Gnatcheck.Source_Table is Info_No_EOL ("[" & N (2 .. N'Last) & "] "); Info (Short_Source_Name (SF)); - elsif not (Quiet_Mode or Arg.Progress_Indicator_Mode.Get) then + elsif not (Arg.Quiet_Mode or Arg.Progress_Indicator_Mode.Get) then Info_No_EOL ("Units remaining:"); Info_No_EOL (N); Info_No_EOL (" " & ASCII.CR); diff --git a/lkql_checker/src/gnatcheck_main.adb b/lkql_checker/src/gnatcheck_main.adb index 0097f4c68..3052270eb 100644 --- a/lkql_checker/src/gnatcheck_main.adb +++ b/lkql_checker/src/gnatcheck_main.adb @@ -195,7 +195,7 @@ procedure Gnatcheck_Main is Total_Jobs := Num_Jobs + (if Analyze_Compiler_Output then 1 else 0); - if not Quiet_Mode and not Arg.Progress_Indicator_Mode.Get then + if not Arg.Quiet_Mode and not Arg.Progress_Indicator_Mode.Get then Info_No_EOL ("Jobs remaining:"); Info_No_EOL (Integer'Image (Total_Jobs) & ASCII.CR); end if; @@ -246,7 +246,7 @@ procedure Gnatcheck_Main is & " out of" & Integer'Image (Total_Jobs) & " " & Percent & "%)..."); end; - elsif not Quiet_Mode then + elsif not Arg.Quiet_Mode then Info_No_EOL ("Jobs remaining:"); Info_No_EOL (Integer'Image (Total_Jobs - Current)); Info_No_EOL (" " & ASCII.CR); @@ -521,7 +521,7 @@ begin elsif (Detected_Non_Exempted_Violations > 0 or else Detected_Compiler_Error > 0) - and then not Brief_Mode + and then not Arg.Brief_Mode then E_Violation else E_Success); From fa2d40e0a2714c74fd87ee36385ef06b2d159339 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 14 Jun 2024 17:19:52 +0200 Subject: [PATCH 13/16] Opt_Parse: Transition --show-rule/-t --- lkql_checker/src/gnatcheck-compiler.adb | 10 +++++----- lkql_checker/src/gnatcheck-options.ads | 19 +++++++++++-------- lkql_checker/src/gnatcheck-output.adb | 1 + lkql_checker/src/gnatcheck-projects.adb | 19 ++----------------- lkql_checker/src/gnatcheck-rules.adb | 4 ++-- lkql_checker/src/gnatcheck_main.adb | 2 +- 6 files changed, 22 insertions(+), 33 deletions(-) diff --git a/lkql_checker/src/gnatcheck-compiler.adb b/lkql_checker/src/gnatcheck-compiler.adb index a8c4a812c..65a95cb95 100644 --- a/lkql_checker/src/gnatcheck-compiler.adb +++ b/lkql_checker/src/gnatcheck-compiler.adb @@ -188,7 +188,7 @@ package body Gnatcheck.Compiler is Last_Idx := Last_Idx - 5; end if; - if Mapping_Mode then + if Arg.Show_Rule.Get then if Message_Kind in Warning | Style then Diag_End := Index (Source => Result (Result'First .. Last_Idx), Pattern => (if Message_Kind = Warning @@ -1859,8 +1859,8 @@ package body Gnatcheck.Compiler is function Style_Rule_Parameter (Diag : String) return String is First_Idx : Natural; String_To_Search : constant String := - (if Gnatcheck.Options.Mapping_Mode then "[style_checks:" - else "[-gnaty"); + (if Arg.Show_Rule.Get then "[style_checks:" + else "[-gnaty"); begin -- This function returns non-empty result only if .d parameter is @@ -1884,8 +1884,8 @@ package body Gnatcheck.Compiler is function Warning_Rule_Parameter (Diag : String) return String is First_Idx, Last_Idx : Natural; String_To_Search : constant String := - (if Gnatcheck.Options.Mapping_Mode then "[warnings:" - else "[-gnatw"); + (if Arg.Show_Rule.Get then "[warnings:" + else "[-gnatw"); begin -- This function returns non-empty result only if .d parameter is diff --git a/lkql_checker/src/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads index dfeb0c42b..9763f605d 100644 --- a/lkql_checker/src/gnatcheck-options.ads +++ b/lkql_checker/src/gnatcheck-options.ads @@ -87,11 +87,6 @@ package Gnatcheck.Options is -- parameters to be used for creating the GUI in GPS. -- '-hx'. - Compute_Timing : Boolean := False; - -- If this flag is ON, the total execution time (wall clock) of the tool - -- is computed and printed out. - -- '-t' - Legacy : Boolean := False; -- If True, run in legacy mode, with no support for additional rule files. @@ -221,9 +216,6 @@ package Gnatcheck.Options is -- there is no limitation on the number of diagnoses to be printed out into -- Stderr. - Mapping_Mode : Boolean := False; - -- If this flag is ON, a rule name is added to the text of each diagnosis. - User_Info_File : GNAT.OS_Lib.String_Access; User_Info_File_Full_Path : GNAT.OS_Lib.String_Access; -- --include-file= @@ -397,6 +389,17 @@ package Gnatcheck.Options is Name => "Short report", Help => "print the short version of the report file"); + package Time is new Parse_Flag + (Parser => Parser, + Short => "-t", + Name => "Compute timing", + Help => "print the total execution time (wall clock) on stderr"); + + package Show_Rule is new Parse_Flag + (Parser => Parser, + Long => "--show-rule", + Help => "append rule names to diagnoses generated"); + function Quiet_Mode return Boolean is (Quiet.Get or else Brief.Get); function Short_Report return Boolean is (Brief.Get or else Short.Get); diff --git a/lkql_checker/src/gnatcheck-output.adb b/lkql_checker/src/gnatcheck-output.adb index faa362a99..a67deb929 100644 --- a/lkql_checker/src/gnatcheck-output.adb +++ b/lkql_checker/src/gnatcheck-output.adb @@ -776,6 +776,7 @@ package body Gnatcheck.Output is Info (" -nt - do not generate text report (enforces '-xml')"); Info (""); + -- TODO: Remove when we switch to Opt_Parse's help message Info (" --show-rule - append rule names to diagnoses generated"); Info (""); diff --git a/lkql_checker/src/gnatcheck-projects.adb b/lkql_checker/src/gnatcheck-projects.adb index df424ec70..e8be6ee3d 100644 --- a/lkql_checker/src/gnatcheck-projects.adb +++ b/lkql_checker/src/gnatcheck-projects.adb @@ -1119,9 +1119,9 @@ package body Gnatcheck.Projects is loop Initial_Char := GNAT.Command_Line.Getopt - ("v t h hx " & + ("v h hx " & "m? files= a " & - "vP!" & -- project-specific options + "vP! " & -- project-specific options "-check-redefinition " & "-no_objects_dir " & "-subdirs= " & @@ -1131,7 +1131,6 @@ package body Gnatcheck.Projects is "ox= " & "l log " & "-include-file= " & - "-show-rule " & "-subprocess " & "-version -help " & "-ignore= " & @@ -1268,11 +1267,6 @@ package body Gnatcheck.Projects is end if; end if; - when 't' => - if not First_Pass then - Compute_Timing := True; - end if; - when 'v' => if Full_Switch (Parser => Parser) = "v" then Verbose_Mode := True; @@ -1322,15 +1316,6 @@ package body Gnatcheck.Projects is elsif Full_Switch (Parser => Parser) = "-kp-version" then Free (KP_Version); KP_Version := new String'(Parameter (Parser => Parser)); - - elsif Full_Switch (Parser => Parser) = "-show-rule" then - Mapping_Mode := True; - - elsif Full_Switch (Parser => Parser) = "-RTS" then - -- We do not store --RTS option for gcc now - we have - -- to resolve its parameter to the full path, and we - -- can do this only when target is fully detected. - null; end if; else if Full_Switch (Parser => Parser) = "-help" then diff --git a/lkql_checker/src/gnatcheck-rules.adb b/lkql_checker/src/gnatcheck-rules.adb index 8685b9f90..a84eb67ef 100644 --- a/lkql_checker/src/gnatcheck-rules.adb +++ b/lkql_checker/src/gnatcheck-rules.adb @@ -1058,7 +1058,7 @@ package body Gnatcheck.Rules is First_Idx : Natural := Index (Diag, " ", Going => Backward) + 1; Last_Idx : Natural := Diag'Last; begin - if Mapping_Mode then + if Arg.Show_Rule.Get then -- The diagnosis has the following format: -- foo.adb:nn:mm: use of pragma Bar [Rule_Name] @@ -2870,7 +2870,7 @@ package body Gnatcheck.Rules is (Rule : Rule_Info; Alias_Name : String) return String is begin - if not Mapping_Mode then + if not Arg.Show_Rule.Get then return ""; else return diff --git a/lkql_checker/src/gnatcheck_main.adb b/lkql_checker/src/gnatcheck_main.adb index 3052270eb..5c6a68121 100644 --- a/lkql_checker/src/gnatcheck_main.adb +++ b/lkql_checker/src/gnatcheck_main.adb @@ -498,7 +498,7 @@ begin Gnatcheck.Projects.Clean_Up (Gnatcheck.Options.Gnatcheck_Prj); - if Compute_Timing then + if Arg.Time.Get then Info ("Execution time:" & Duration'Image (Ada.Calendar.Clock - Time_Start)); end if; From c6b373fa4c0aaa5eed03ca3c2a2a6423df953e3f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Mon, 17 Jun 2024 11:49:26 +0200 Subject: [PATCH 14/16] Opt_Parse: Transition many more options --check-redefinition, --no_objects_dir, --print-gpr-registry, --ignore-project-switches, --include-file, --subdirs, --ignore --- lkql_checker/src/gnatcheck-compiler.adb | 6 +- lkql_checker/src/gnatcheck-diagnoses.adb | 18 ++--- lkql_checker/src/gnatcheck-options.ads | 61 ++++++++++++---- lkql_checker/src/gnatcheck-output.adb | 59 +--------------- lkql_checker/src/gnatcheck-projects.adb | 89 ++++++------------------ lkql_checker/src/gnatcheck-projects.ads | 22 +----- lkql_checker/src/gnatcheck-rules.adb | 14 ++-- lkql_checker/src/gnatcheck-rules.ads | 2 +- lkql_checker/src/gnatcheck_main.adb | 29 +++++--- 9 files changed, 112 insertions(+), 188 deletions(-) diff --git a/lkql_checker/src/gnatcheck-compiler.adb b/lkql_checker/src/gnatcheck-compiler.adb index 65a95cb95..b8f6e8d4b 100644 --- a/lkql_checker/src/gnatcheck-compiler.adb +++ b/lkql_checker/src/gnatcheck-compiler.adb @@ -1134,7 +1134,7 @@ package body Gnatcheck.Compiler is (Trim (Param (Last_Idx .. Param'Last), Both)); if not Restriction_Setting (R_Id).Param.Is_Empty - and then Gnatcheck.Options.Check_Param_Redefinition + and then Arg.Check_Redefinition.Get then Restriction_Setting (R_Id).Param.Clear; Last_Idx := Index (Param, "=", Backward) - 1; @@ -1606,7 +1606,7 @@ package body Gnatcheck.Compiler is Num_Args := @ + 1; Args (Num_Args) := new String'("-P" & Prj); - if Ignore_Project_Switches then + if Arg.Ignore_Project_Switches then Num_Args := @ + 1; Args (Num_Args) := new String'("--ignore-project-switches"); end if; @@ -1769,7 +1769,7 @@ package body Gnatcheck.Compiler is Args (2) := new String'("-s"); Args (3) := new String'("-k"); Args (4) := new String'("-q"); - Args (5) := new String'("--subdirs=" & Subdir_Name.all); + Args (5) := new String'("--subdirs=" & Subdir_Name); Args (6) := new String'("--no-object-check"); Args (7) := new String'("--complete-output"); diff --git a/lkql_checker/src/gnatcheck-diagnoses.adb b/lkql_checker/src/gnatcheck-diagnoses.adb index 1ec261815..0a56a3dcf 100644 --- a/lkql_checker/src/gnatcheck-diagnoses.adb +++ b/lkql_checker/src/gnatcheck-diagnoses.adb @@ -2683,20 +2683,14 @@ package body Gnatcheck.Diagnoses is --------------------------- procedure Process_User_Filename (Fname : String) is - use all type GNAT.OS_Lib.String_Access; begin if GNAT.OS_Lib.Is_Regular_File (Fname) then - if User_Info_File /= null then - Error ("--include-file option can be given only once, " & - "all but first ignored"); - else - User_Info_File := new String'(Fname); - User_Info_File_Full_Path := new String' - (GNAT.OS_Lib.Normalize_Pathname - (Fname, - Resolve_Links => False, - Case_Sensitive => False)); - end if; + User_Info_File := new String'(Fname); + User_Info_File_Full_Path := new String' + (GNAT.OS_Lib.Normalize_Pathname + (Fname, + Resolve_Links => False, + Case_Sensitive => False)); else Error (Fname & " not found, --include-file option ignored"); end if; diff --git a/lkql_checker/src/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads index 9763f605d..5dbbdf57a 100644 --- a/lkql_checker/src/gnatcheck-options.ads +++ b/lkql_checker/src/gnatcheck-options.ads @@ -18,6 +18,8 @@ with Gnatcheck.Projects; with GNATCOLL.Opt_Parse; use GNATCOLL.Opt_Parse; +with GPR2.Options; + package Gnatcheck.Options is Gnatcheck_Version : constant String := "25.0w"; @@ -129,10 +131,6 @@ package Gnatcheck.Options is -- True if the -jN option was given. This is used to distinguish -j0 on a -- uniprocessor from no -j switch. - Ignore_Project_Switches : Boolean := False; - -- True if --ignore-project-switches was used. - -- Ignore gnatcheck switches from the project file if set. - ---------------------------------------- -- Flags computed from other settings -- ---------------------------------------- @@ -175,12 +173,6 @@ package Gnatcheck.Options is -- Generate the rules help information (note, that we can do it only after -- registering the rules) - Check_Param_Redefinition : Boolean := False; - -- '--check-redefinition' - -- Check if for parametrized rule the rule parameter is defined more than - -- once (may happen if gnatcheck has several rule files as parameters, or - -- when a rule is activated both in the command line and in the rule file. - Active_Rule_Present : Boolean := False; -- Flag indicating if the tool has an activated rule to check. It does not -- take into account compiler check, use @@ -256,7 +248,6 @@ package Gnatcheck.Options is procedure Warning (Self : in out Gnatcheck_Error_Handler; Msg : String); procedure Error (Self : in out Gnatcheck_Error_Handler; Msg : String); - procedure On_Fail (Self : in out Gnatcheck_Error_Handler); package Arg is Parser : Argument_Parser := Create_Argument_Parser @@ -264,7 +255,8 @@ package Gnatcheck.Options is Incremental => True, Generate_Help_Flag => False, Custom_Error_Handler => - Create (Gnatcheck_Error_Handler'(null record))); + Create (Gnatcheck_Error_Handler'(null record)), + Print_Help_On_Error => False); package Check_Semantic is new Parse_Flag (Parser => Parser, @@ -400,11 +392,56 @@ package Gnatcheck.Options is Long => "--show-rule", Help => "append rule names to diagnoses generated"); + package Check_Redefinition is new Parse_Flag + (Parser => Parser, + Long => "--check-redefinition", + Help => "issue warning if a rule parameter is redefined"); + + package No_Object_Dir is new Parse_Flag + (Parser => Parser, + Long => "--no_objects_dir", + Help => "issue warning if a rule parameter is redefined"); + + package Print_Gpr_Registry is new Parse_Flag + (Parser => Parser, + Long => GPR2.Options.Print_GPR_Registry_Option, + Help => "TODO"); + + package Ignore_Project_Switches_Opt is new Parse_Flag + (Parser => Parser, + Long => "--ignore-project-switches", + Help => "ignore switches specified in the project file"); + + package Include_File is new Parse_Option + (Parser => Parser, + Long => "--include-file", + Arg_Type => Unbounded_String, + Default_Val => Null_Unbounded_String, + Help => "add the content of filename into generated report"); + + package Subdirs is new Parse_Option + (Parser => Parser, + Long => "--subdirs", + Arg_Type => Unbounded_String, + Default_Val => Null_Unbounded_String, + Help => "specify subdirectory to place the result files into"); + + package Ignore_Files is new Parse_Option + (Parser => Parser, + Long => "--ignore", + Arg_Type => Unbounded_String, + Default_Val => Null_Unbounded_String, + Help => "do not process sources listed in filename"); + function Quiet_Mode return Boolean is (Quiet.Get or else Brief.Get); function Short_Report return Boolean is (Brief.Get or else Short.Get); function Brief_Mode return Boolean is (Brief.Get); + + function Ignore_Project_Switches return Boolean is + (Ignore_Project_Switches_Opt.Get or Gnatkp_Mode); + end Arg; end Gnatcheck.Options; diff --git a/lkql_checker/src/gnatcheck-output.adb b/lkql_checker/src/gnatcheck-output.adb index a67deb929..cd33ac40d 100644 --- a/lkql_checker/src/gnatcheck-output.adb +++ b/lkql_checker/src/gnatcheck-output.adb @@ -654,6 +654,7 @@ package body Gnatcheck.Output is -- Brief_Help -- ---------------- + -- TODO: Transition this help message to Opt_Parse's one procedure Brief_Help is begin pragma Style_Checks ("M200"); -- Allow long lines @@ -665,55 +666,29 @@ package body Gnatcheck.Output is Info (" --version - Display version and exit"); Info (" --help - Display usage and exit"); Info (""); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" -Pproject - Use project file project. Only one such switch can be used"); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" -U - check all sources of the argument project"); Info (" -U main - check the closure of units rooted at unit main"); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" --no-subprojects - process only sources of root project"); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" -Xname=value - specify an external reference for argument project file"); - Info (" --subdirs=dir - specify subdirectory to place the result files into"); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" -eL - follow all symbolic links when processing project files"); - Info (" -o filename - specify the name of the report file"); Info (""); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" --target=targetname - specify a target for cross platforms"); Info (" --RTS= - use runtime "); - Info (""); Info (" -h - print out the list of the available kp detectors"); Info (" -jn - n is the maximal number of processes"); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" -q - quiet mode (do not report detections in Stderr)"); - Info (" -v - verbose mode"); Info (" -l - full pathname for file locations"); Info (""); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" --brief - brief mode, only report detections in Stderr"); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" --check-semantic - check semantic validity of the source files"); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" --charset= - specify the charset of the source files"); - Info (" --kp-version= - enable all KP detectors matching GNAT "); Info (""); - Info (" -from=filename - read kp options from filename"); Info (" +R[:param] - turn ON a given detector [with given parameter]"); Info (" where - ID of one of the currently implemented"); @@ -730,34 +705,19 @@ package body Gnatcheck.Output is Info (" --version - Display version and exit"); Info (" --help - Display usage and exit"); Info (""); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" -Pproject - Use project file project. Only one such switch can be used"); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" -U - check all sources of the argument project"); Info (" -U main - check the closure of units rooted at unit main"); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" --no-subprojects - process only sources of root project"); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" -Xname=value - specify an external reference for argument project file"); - Info (" --subdirs=dir - specify subdirectory to place the result files into"); Info (" --no_objects_dir - place results into current dir instead of project dir"); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" -eL - follow all symbolic links when processing project files"); - Info (""); Info (" --ignore-project-switches - ignore switches specified in the project file"); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" --target=targetname - specify a target for cross platforms"); Info (" --RTS= - use runtime "); Info (" --config= - use configuration project "); - Info (""); Info (" -h - print out the list of the currently implemented rules"); Info (" -mn - n is the maximal number of diagnoses in Stderr"); @@ -768,50 +728,33 @@ package body Gnatcheck.Output is Info (" -v - verbose mode"); Info (" -l - full pathname for file locations"); Info (" -log - duplicate all the messages sent to Stderr in gnatcheck.log"); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" -s - short form of the report file"); - Info (" -xml - generate report in XML format"); Info (" -nt - do not generate text report (enforces '-xml')"); Info (""); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" --show-rule - append rule names to diagnoses generated"); Info (""); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" --brief - brief mode, only report detections in Stderr"); - Info (" --check-redefinition - issue warning if a rule parameter is redefined"); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" --check-semantic - check semantic validity of the source files"); - - -- TODO: Remove when we switch to Opt_Parse's help message Info (" --charset= - specify the charset of the source files"); if not Legacy then - -- TODO: Remove when we switch to Opt_Parse's help message Info (" --rules-dir= - specify an alternate directory containing rule files"); end if; Info (""); Info (" --include-file=filename - add the content of filename into generated report"); - Info (""); - Info (" -o filename - specify the name of the text report file"); Info (" -ox filename - specify the name of the XML report file (enforces '-xml')"); Info (""); - Info ("filename - the name of the Ada source file to be analyzed."); Info (" Wildcards are allowed"); Info ("-files=filename - the name of the text file containing a list of Ada"); Info (" source files to analyze"); Info ("--ignore=filename - do not process sources listed in filename"); Info (""); - Info ("rule_switches - a list of the following switches"); Info (" -from=filename - read rule options from filename"); Info (" -from-lkql=filename - read rule options from the given LKQL file"); diff --git a/lkql_checker/src/gnatcheck-projects.adb b/lkql_checker/src/gnatcheck-projects.adb index e8be6ee3d..8e3648d7e 100644 --- a/lkql_checker/src/gnatcheck-projects.adb +++ b/lkql_checker/src/gnatcheck-projects.adb @@ -454,8 +454,8 @@ package body Gnatcheck.Projects is (GPR2.Options.Config, My_Project.Source_CGPR.all); end if; - if Subdir_Name /= null then - Project_Options.Add_Switch (GPR2.Options.Subdirs, Subdir_Name.all); + if Subdir_Name /= "" then + Project_Options.Add_Switch (GPR2.Options.Subdirs, Subdir_Name); end if; if RTS_Path /= Null_Unbounded_String then @@ -466,7 +466,7 @@ package body Gnatcheck.Projects is Project_Options.Add_Switch (GPR2.Options.Target, To_String (Target)); end if; - if Follow_Symbolic_Links then + if Arg.Follow_Symbolic_Links.Get then Project_Options.Add_Switch (GPR2.Options.Resolve_Links); end if; @@ -706,17 +706,17 @@ package body Gnatcheck.Projects is (GPR2.Filename_Type (GNAT.Directory_Operations.Get_Current_Dir)); - Dir : constant String := - String - (if not No_Object_Dir and then Gnatcheck_Prj.Is_Specified - then (if My_Project.Tree.Root_Project.Kind not in - GPR2.With_Object_Dir_Kind - then - My_Project.Tree.Root_Project.Path_Name.Dir_Name - else - My_Project.Tree.Root_Project.Object_Directory.Dir_Name) - else - Cur_Dir.Dir_Name); + Dir : constant String := String + (if not Arg.No_Object_Dir.Get and then Gnatcheck_Prj.Is_Specified + then + (if My_Project.Tree.Root_Project.Kind not in + GPR2.With_Object_Dir_Kind + then + My_Project.Tree.Root_Project.Path_Name.Dir_Name + else + My_Project.Tree.Root_Project.Object_Directory.Dir_Name) + else + Cur_Dir.Dir_Name); begin GNAT.OS_Lib.Free (Global_Report_Dir); Global_Report_Dir := new String'(Dir); @@ -726,16 +726,17 @@ package body Gnatcheck.Projects is -- Set_Subdir_Name -- --------------------- - procedure Set_Subdir_Name (S : String) is + function Subdir_Name return String is + use Ada.Strings.Unbounded; begin - Free (Subdir_Name); - if S = "" then - Subdir_Name := new String'("gnatcheck"); + if Arg.Subdirs.Get = Null_Unbounded_String then + return "gnatcheck"; else - Subdir_Name := new String' - (S & GNAT.OS_Lib.Directory_Separator & "gnatcheck"); + return To_String (Arg.Subdirs.Get) + & GNAT.OS_Lib.Directory_Separator + & "gnatcheck"; end if; - end Set_Subdir_Name; + end Subdir_Name; ---------------- -- Source_Prj -- @@ -1061,11 +1062,6 @@ package body Gnatcheck.Projects is Initial_Char : Character; Success : Boolean; - Print_Registry_Option : constant String := - GPR2.Options.Print_GPR_Registry_Option - (GPR2.Options.Print_GPR_Registry_Option'First + 1 .. - GPR2.Options.Print_GPR_Registry_Option'Last); - -- Start of processing for Scan_Arguments begin @@ -1122,20 +1118,13 @@ package body Gnatcheck.Projects is ("v h hx " & "m? files= a " & "vP! " & -- project-specific options - "-check-redefinition " & - "-no_objects_dir " & - "-subdirs= " & "-kp-version= " & "j! " & "o= " & "ox= " & "l log " & - "-include-file= " & "-subprocess " & "-version -help " & - "-ignore= " & - "-ignore-project-switches " & - Print_Registry_Option & " " & "nt xml", Parser => Parser); @@ -1296,24 +1285,7 @@ package body Gnatcheck.Projects is when '-' => if not First_Pass then - if Full_Switch (Parser => Parser) = "-check-redefinition" - then - Check_Param_Redefinition := True; - elsif Full_Switch (Parser => Parser) = "-ignore" then - if Is_Regular_File (Parameter (Parser => Parser)) then - Exempted_Units := - new String'(Normalize_Pathname - (Parameter (Parser => Parser))); - else - Error (Parameter (Parser => Parser) & " not found"); - raise Parameter_Error; - end if; - - elsif Full_Switch (Parser => Parser) = "-include-file" then - Gnatcheck.Diagnoses.Process_User_Filename - (Parameter (Parser => Parser)); - - elsif Full_Switch (Parser => Parser) = "-kp-version" then + if Full_Switch (Parser => Parser) = "-kp-version" then Free (KP_Version); KP_Version := new String'(Parameter (Parser => Parser)); end if; @@ -1338,21 +1310,6 @@ package body Gnatcheck.Projects is Print_Version := True; - elsif Full_Switch (Parser => Parser) = - "-ignore-project-switches" - then - Ignore_Project_Switches := True; - - elsif Full_Switch (Parser => Parser) = "-subdirs" then - Set_Subdir_Name (Parameter (Parser => Parser)); - - elsif Full_Switch (Parser => Parser) = "-no_objects_dir" then - No_Object_Dir := True; - - elsif Full_Switch (Parser => Parser) = Print_Registry_Option - then - Print_Gpr_Registry := True; - end if; end if; diff --git a/lkql_checker/src/gnatcheck-projects.ads b/lkql_checker/src/gnatcheck-projects.ads index fbe9b53bf..e2e9ca799 100644 --- a/lkql_checker/src/gnatcheck-projects.ads +++ b/lkql_checker/src/gnatcheck-projects.ads @@ -148,26 +148,8 @@ package Gnatcheck.Projects is Last : in out Natural); -- Append a "-XVAR=value" string for each stored external variable - -------------------------------------------------------------------------- - -- --subdirs= : is subdirectories to place the tool output into -- - -------------------------------------------------------------------------- - - Subdir_Name : String_Access := new String'("gnatcheck"); - -- If Subdir_Name is null, no special subdirectory is used for tool - -- results. - - procedure Set_Subdir_Name (S : String); - -- Sets Subdir_Name to S (if Subdir_Name is not null, frees the old value). - -- We may have '--subdirs=' option both in command line and in the list - -- of values of Default_Switches and Switches attributes in the tool - -- package in the project file. - - ---------------------------------------------------------------- - -- --no_object_dir : do not place the results into object dir -- - ---------------------------------------------------------------- - - No_Object_Dir : Boolean := False; - -- If this flag is ON, the output files are placed in the current directory + function Subdir_Name return String; + -- Return the subdir name to use, if one was set explicitly. ---------------------------------------------------------------- -- --print-gpr-registry : print gnatcheck attributes and exit -- diff --git a/lkql_checker/src/gnatcheck-rules.adb b/lkql_checker/src/gnatcheck-rules.adb index a84eb67ef..6bc451f92 100644 --- a/lkql_checker/src/gnatcheck-rules.adb +++ b/lkql_checker/src/gnatcheck-rules.adb @@ -1372,7 +1372,7 @@ package body Gnatcheck.Rules is -- Else, the param has a value else if Enable then - if Check_Param_Redefinition and then + if Arg.Check_Redefinition.Get and then Tagged_Instance.Param /= Integer'First then Emit_Redefining (Instance, "", Defined_At); @@ -1436,7 +1436,7 @@ package body Gnatcheck.Rules is -- Else, if the command line is enabling the rule, the parameter is not -- empty and is valid. Just set the instance parameter value. elsif Enable then - if Check_Param_Redefinition and then Tagged_Instance.Param /= Unset + if Arg.Check_Redefinition.Get and then Tagged_Instance.Param /= Unset then Emit_Redefining (Instance, Param, Defined_At); end if; @@ -1479,7 +1479,7 @@ package body Gnatcheck.Rules is -- Else, the parameter is not empty, if the instance is enabled check -- the parameter value and enable the instance. elsif Enable then - if Check_Param_Redefinition and then + if Arg.Check_Redefinition.Get and then not Ada.Strings.Wide_Wide_Unbounded."=" (Tagged_Instance.Param, Null_Unbounded_Wide_Wide_String) then @@ -1535,7 +1535,7 @@ package body Gnatcheck.Rules is -- Else, the param is not empty, if the command line is enabling the -- instance process the parameter. elsif Enable then - if Check_Param_Redefinition and then + if Arg.Check_Redefinition.Get and then not Ada.Strings.Wide_Wide_Unbounded."=" (Tagged_Instance.Param, Null_Unbounded_Wide_Wide_String) then @@ -1628,7 +1628,7 @@ package body Gnatcheck.Rules is begin Int_Param_Value := Integer'Value (Param); - if Check_Param_Redefinition + if Arg.Check_Redefinition.Get and then Tagged_Instance.Integer_Param /= Integer'First then Emit_Redefining (Instance, "N", Defined_At); @@ -1654,7 +1654,7 @@ package body Gnatcheck.Rules is loop if Param_Name (All_Rules (Rule), J) = To_Lower (Param) then - if Check_Param_Redefinition + if Arg.Check_Redefinition.Get and then Tagged_Instance.Boolean_Params (J) = On then Emit_Redefining (Instance, Param, Defined_At); @@ -1978,7 +1978,7 @@ package body Gnatcheck.Rules is Val : String; Label : String) is begin - if Check_Param_Redefinition and then Length (S) /= 0 then + if Arg.Check_Redefinition.Get and then Length (S) /= 0 then Emit_Redefining (Instance, Label, Defined_At); end if; diff --git a/lkql_checker/src/gnatcheck-rules.ads b/lkql_checker/src/gnatcheck-rules.ads index 844f9111d..96f2f97ae 100644 --- a/lkql_checker/src/gnatcheck-rules.ads +++ b/lkql_checker/src/gnatcheck-rules.ads @@ -172,7 +172,7 @@ package Gnatcheck.Rules is -- Access to the function required to process a given parameter. This -- function updates the global instances map according to the -- provided `Param` and `Enable` values. This function also check for - -- parameter redefinition if the flobal flag `Check_Param_Redefinition` + -- parameter redefinition if the flobal flag `Check_Redefinition` -- is on. -- -- The `Instance_Name` is the name of the instance to create or update. diff --git a/lkql_checker/src/gnatcheck_main.adb b/lkql_checker/src/gnatcheck_main.adb index 5c6a68121..56894b2c7 100644 --- a/lkql_checker/src/gnatcheck_main.adb +++ b/lkql_checker/src/gnatcheck_main.adb @@ -387,12 +387,11 @@ begin Gnatcheck.Options.RTS_Path := Arg.RTS.Get; -- Register GNATcheck GPR attributes - Register_Tool_Attributes (Gnatcheck_Prj); -- Print GPR registered and exit if requested - if Print_Gpr_Registry then + if Arg.Print_Gpr_Registry.Get then -- Print GPR registry GPR2.Project.Registry.Exchange.Export (Output => Put'Access); @@ -425,17 +424,11 @@ begin Ctx := Gnatcheck.Source_Table.Create_Context; - -- Ignore project switches when running as gnatkp - - if Gnatkp_Mode then - Ignore_Project_Switches := True; - end if; - -- Analyze relevant project properties if needed if Gnatcheck_Prj.Is_Specified and then not In_Aggregate_Project - and then not Ignore_Project_Switches + and then not Arg.Ignore_Project_Switches then Extract_Tool_Options (Gnatcheck_Prj); end if; @@ -444,6 +437,24 @@ begin Gnatcheck_Prj.Scan_Arguments; + -- Process the include file + if Arg.Include_File.Get /= Null_Unbounded_String then + Gnatcheck.Diagnoses.Process_User_Filename + (To_String (Arg.Include_File.Get)); + end if; + + -- Set up ignore list + if Arg.Ignore_Files.Get /= Null_Unbounded_String then + if Is_Regular_File (To_String (Arg.Ignore_Files.Get)) then + Exempted_Units := + new String'(Normalize_Pathname + (To_String (Arg.Ignore_Files.Get))); + else + Error (To_String (Arg.Ignore_Files.Get) & " not found"); + raise Parameter_Error; + end if; + end if; + -- Setup LKQL_RULES_PATH to point on built-in rules Setup_Search_Paths; From 6d11f5911545c977ed58c4c04524c6dc406fc096 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Mon, 17 Jun 2024 12:07:36 +0200 Subject: [PATCH 15/16] Reorder with clauses --- lkql_checker/src/gnatcheck-options.ads | 7 +++---- lkql_checker/src/gnatcheck-projects.adb | 3 +-- lkql_checker/src/rules_factory.adb | 2 +- 3 files changed, 5 insertions(+), 7 deletions(-) diff --git a/lkql_checker/src/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads index 5dbbdf57a..bdc62e472 100644 --- a/lkql_checker/src/gnatcheck-options.ads +++ b/lkql_checker/src/gnatcheck-options.ads @@ -6,11 +6,10 @@ -- This package defines options that are supposed to be of a common interest -- for all the tools. -with Ada.Command_Line; use Ada.Command_Line; -with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; - -with Ada.Directories; use Ada.Directories; +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Directories; use Ada.Directories; with Ada.Environment_Variables; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with GNAT.OS_Lib; diff --git a/lkql_checker/src/gnatcheck-projects.adb b/lkql_checker/src/gnatcheck-projects.adb index 8e3648d7e..0d2539eee 100644 --- a/lkql_checker/src/gnatcheck-projects.adb +++ b/lkql_checker/src/gnatcheck-projects.adb @@ -30,8 +30,6 @@ with Gnatcheck.Rules.Rule_Table; use Gnatcheck.Rules.Rule_Table; with Gnatcheck.Source_Table; use Gnatcheck.Source_Table; with Gnatcheck.String_Utilities; use Gnatcheck.String_Utilities; -with GNATCOLL.Traces; - with GPR2; with GPR2.Build.Compilation_Unit; pragma Warnings (Off, ".* is not referenced"); @@ -56,6 +54,7 @@ with GPR2.Project.View; with GNATCOLL.Opt_Parse; use GNATCOLL.Opt_Parse; with GNATCOLL.Strings; use GNATCOLL.Strings; +with GNATCOLL.Traces; with Rule_Commands; use Rule_Commands; diff --git a/lkql_checker/src/rules_factory.adb b/lkql_checker/src/rules_factory.adb index fb1d5b886..926a3d838 100644 --- a/lkql_checker/src/rules_factory.adb +++ b/lkql_checker/src/rules_factory.adb @@ -7,9 +7,9 @@ with Ada.Environment_Variables; with GNAT.OS_Lib; -with GNATCOLL.Utils; with GNATCOLL.Opt_Parse; use GNATCOLL.Opt_Parse; with GNATCOLL.Strings; use GNATCOLL.Strings; +with GNATCOLL.Utils; with GNATCOLL.VFS; use GNATCOLL.VFS; package body Rules_Factory is From 2fa744d6d1bd4e5dd0137b5b841f3caabe1c6041 Mon Sep 17 00:00:00 2001 From: Hugo Guerrier Date: Tue, 18 Jun 2024 12:02:33 +0200 Subject: [PATCH 16/16] Opt_Parse: Transition -j --- lkql_checker/src/gnatcheck-compiler.adb | 4 ++-- lkql_checker/src/gnatcheck-options.adb | 16 ++++++++++++++++ lkql_checker/src/gnatcheck-options.ads | 19 +++++++++++-------- lkql_checker/src/gnatcheck-projects.adb | 24 ------------------------ lkql_checker/src/gnatcheck_main.adb | 1 + 5 files changed, 30 insertions(+), 34 deletions(-) diff --git a/lkql_checker/src/gnatcheck-compiler.adb b/lkql_checker/src/gnatcheck-compiler.adb index b8f6e8d4b..8c2ffc598 100644 --- a/lkql_checker/src/gnatcheck-compiler.adb +++ b/lkql_checker/src/gnatcheck-compiler.adb @@ -1781,9 +1781,9 @@ package body Gnatcheck.Compiler is Args (Num_Args) := new String'("--target=codepeer"); end if; - if Process_Num > 1 then + if Arg.Jobs.Get > 1 then Num_Args := @ + 1; - Args (Num_Args) := new String'("-j" & Image (Process_Num)); + Args (Num_Args) := new String'("-j" & Image (Arg.Jobs.Get)); end if; if Prj /= "" then diff --git a/lkql_checker/src/gnatcheck-options.adb b/lkql_checker/src/gnatcheck-options.adb index 8988f6e1d..7b3fc9eab 100644 --- a/lkql_checker/src/gnatcheck-options.adb +++ b/lkql_checker/src/gnatcheck-options.adb @@ -1,5 +1,7 @@ with Gnatcheck.Output; use Gnatcheck.Output; +with System.Multiprocessors; + package body Gnatcheck.Options is procedure Warning (Self : in out Gnatcheck_Error_Handler; Msg : String) is begin @@ -11,4 +13,18 @@ package body Gnatcheck.Options is Error (Msg); end Error; + ------------------ + -- Jobs_Convert -- + ------------------ + + function Jobs_Convert (Arg : String) return Natural is + Value : constant Natural := Natural'Value (Arg); + begin + if Value = 0 then + return Natural (System.Multiprocessors.Number_Of_CPUs); + else + return Value; + end if; + end Jobs_Convert; + end Gnatcheck.Options; diff --git a/lkql_checker/src/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads index bdc62e472..56e3e3a38 100644 --- a/lkql_checker/src/gnatcheck-options.ads +++ b/lkql_checker/src/gnatcheck-options.ads @@ -122,14 +122,6 @@ package Gnatcheck.Options is Files_Switch_Used : Boolean := False; -- True if the files= switch was used - Process_Num : Natural := 1; - -- The maximal number of cores used - -- -jN - - J_Specified : Boolean := False; - -- True if the -jN option was given. This is used to distinguish -j0 on a - -- uniprocessor from no -j switch. - ---------------------------------------- -- Flags computed from other settings -- ---------------------------------------- @@ -248,6 +240,8 @@ package Gnatcheck.Options is procedure Warning (Self : in out Gnatcheck_Error_Handler; Msg : String); procedure Error (Self : in out Gnatcheck_Error_Handler; Msg : String); + function Jobs_Convert (Arg : String) return Natural; + package Arg is Parser : Argument_Parser := Create_Argument_Parser (Help => "GNATcheck help", @@ -432,6 +426,15 @@ package Gnatcheck.Options is Default_Val => Null_Unbounded_String, Help => "do not process sources listed in filename"); + package Jobs is new Parse_Option + (Parser => Parser, + Short => "-j", + Name => "Jobs", + Arg_Type => Natural, + Default_Val => 1, + Convert => Jobs_Convert, + Help => "the maximal number of processes"); + function Quiet_Mode return Boolean is (Quiet.Get or else Brief.Get); function Short_Report return Boolean is (Brief.Get or else Short.Get); diff --git a/lkql_checker/src/gnatcheck-projects.adb b/lkql_checker/src/gnatcheck-projects.adb index 0d2539eee..ea30096e3 100644 --- a/lkql_checker/src/gnatcheck-projects.adb +++ b/lkql_checker/src/gnatcheck-projects.adb @@ -58,8 +58,6 @@ with GNATCOLL.Traces; with Rule_Commands; use Rule_Commands; -with System.Multiprocessors; - package body Gnatcheck.Projects is subtype Unbounded_String is Ada.Strings.Unbounded.Unbounded_String; @@ -1118,7 +1116,6 @@ package body Gnatcheck.Projects is "m? files= a " & "vP! " & -- project-specific options "-kp-version= " & - "j! " & "o= " & "ox= " & "l log " & @@ -1184,27 +1181,6 @@ package body Gnatcheck.Projects is end if; end if; - when 'j' => - if Full_Switch (Parser => Parser) = "j" - and then not First_Pass - then - begin - J_Specified := True; - Process_Num := - Natural'Value (Parameter (Parser => Parser)); - - if Process_Num = 0 then - Process_Num := - Positive (System.Multiprocessors.Number_Of_CPUs); - end if; - exception - when Constraint_Error => - Error ("Wrong Parameter of '-j' option: " & - Parameter (Parser => Parser)); - raise Parameter_Error; - end; - end if; - when 'l' => if not First_Pass then if Full_Switch (Parser => Parser) = "l" then diff --git a/lkql_checker/src/gnatcheck_main.adb b/lkql_checker/src/gnatcheck_main.adb index 56894b2c7..e5e1e608d 100644 --- a/lkql_checker/src/gnatcheck_main.adb +++ b/lkql_checker/src/gnatcheck_main.adb @@ -158,6 +158,7 @@ procedure Gnatcheck_Main is File : Ada.Text_IO.File_Type; Status : Boolean; Total_Jobs : Natural; + Process_Num : Natural := Arg.Jobs.Get; begin -- Compute number of files