Skip to content

Commit

Permalink
Merge branch 'topic/opt_parse' into 'master'
Browse files Browse the repository at this point in the history 
Introduce usage of GNATcoll.Opt_Parse

See merge request eng/libadalang/langkit-query-language!248
  • Loading branch information
@raph-amiard
raph-amiard committed Jul 29, 2024
2 parents 6024b06 + 2fa744d commit 12668fe
Show file tree
Hide file tree
Showing 15 changed files with 561 additions and 573 deletions.
58 changes: 31 additions & 27 deletions lkql_checker/src/gnatcheck-compiler.adb
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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;
Expand Down Expand Up @@ -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;
Expand Down Expand Up @@ -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
Expand All @@ -1604,28 +1606,28 @@ 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;
end if;

if Aggregated_Project then
if Arg.Aggregated_Project then
Num_Args := @ + 1;
Args (Num_Args) := new String'("-A");
Num_Args := @ + 1;
Args (Num_Args) := new String'(Get_Aggregated_Project);
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.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");
Expand All @@ -1636,19 +1638,21 @@ 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;

if Follow_Symbolic_Links then
if Arg.Follow_Symbolic_Links.Get then
Num_Args := @ + 1;
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;
Expand All @@ -1659,7 +1663,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));
Expand Down Expand Up @@ -1723,7 +1727,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);
Expand Down Expand Up @@ -1765,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");
Expand All @@ -1777,24 +1781,24 @@ 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
Num_Args := @ + 1;
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;

-- 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;
Expand All @@ -1805,7 +1809,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;
Expand All @@ -1820,7 +1824,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
Expand Down Expand Up @@ -1855,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
Expand All @@ -1880,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
Expand Down
56 changes: 25 additions & 31 deletions lkql_checker/src/gnatcheck-diagnoses.adb
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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) & """>");
Expand All @@ -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;
Expand Down Expand Up @@ -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");
Expand All @@ -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");
Expand All @@ -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");
Expand All @@ -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");
Expand All @@ -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 ("</violations>");
end if;
Expand Down Expand Up @@ -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;
Expand Down Expand Up @@ -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;
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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;
Expand Down
Loading

0 comments on commit 12668fe

Please sign in to comment.