Merge branch 'mr/273-add-mechanism-to-expose-the-hash-function-used-to-index-serialized-json-tests' into 'master'

Add the --dump-subp-hash switch

See merge request eng/ide/libadalang-tools!321

Author: EdgarDelaporte761

src/test-actions.adb

@@ -70,6 +70,8 @@ with Ada.Strings.Fixed;
 
 with TGen.Libgen;
 
+with Libadalang.Common;
+
 package body Test.Actions is
 
    SPT : GNATCOLL.Projects.Project_Tree
@@ -237,6 +239,7 @@ package body Test.Actions is
          return Result;
       end Process_Comma_Separated_String;
 
+      use Ada.Strings.Fixed;
    begin
       GNATCOLL.Traces.Parse_Config_File;
       Test.Common.Verbose := Arg (Cmd, Verbose);
@@ -250,6 +253,34 @@ package body Test.Actions is
          return;
       end if;
 
+      declare
+         Subp_Hash       : constant String_Access := Arg (Cmd, Dump_Subp_Hash);
+         Separator_Index : constant Natural :=
+           (if Subp_Hash /= null then Index (Subp_Hash.all, ":", 1) else 0);
+      begin
+         if Subp_Hash /= null then
+            if Separator_Index = 0 then
+               Cmd_Error_No_Help
+                 ("Unexpected format for --dump-subp-hash, expected <filename>"
+                  & ":<line>");
+            end if;
+            Test.Common.Subp_File_Name :=
+              new String'(Subp_Hash.all (1 .. Separator_Index - 1));
+            begin
+               Test.Common.Subp_Line_Nbr :=
+                 Natural'Value
+                   ((Subp_Hash.all (Separator_Index + 1 .. Subp_Hash'Length)));
+            exception
+               when others =>
+                  Cmd_Error_No_Help ("<line> must be a Natural.");
+            end;
+            Utils.Command_Lines.Append_File_Name
+              (Cmd, Test.Common.Subp_File_Name.all);
+            Test.Common.Quiet := True;
+            return;
+         end if;
+      end;
+
       Test.Common.Instrument := Arg (Cmd, Dump_Test_Inputs);
 
       Test.Common.Lang_Version :=
@@ -1135,10 +1166,18 @@ package body Test.Actions is
    -----------
 
    procedure Final (Tool : in out Test_Tool; Cmd : Command_Line) is
+      use Ada.Strings.Unbounded;
       Src_Prj : constant String :=
         Tool.Project_Tree.Root_Project.Project_Path.Display_Full_Name;
    begin
 
+      --  Abort here if we the switch --dump-subp-hash is on. This return
+      --  should not be moved further down.
+
+      if Test.Common.Subp_File_Name /= null then
+         return;
+      end if;
+
       --  If the tool project is an aggregate one, exit early and do nothing.
       --  The aggregated projects will be processed in sequence in subprocess
       --  calls made by the driver.
@@ -1238,6 +1277,8 @@ package body Test.Actions is
       BOM_Seen  : Boolean;
       Unit      : Analysis_Unit)
    is
+      use Libadalang.Common;
+      use Ada.Strings.Unbounded;
       pragma Unreferenced (Tool, Input, BOM_Seen); -- ????
    begin
       if Debug_Flag_V then
@@ -1246,6 +1287,40 @@ package body Test.Actions is
          PP_Trivia (Unit);
       end if;
 
+      if Test.Common.Subp_File_Name /= null
+        and then Test.Common.Subp_File_Name.all = File_Name
+      then
+         declare
+            Found_Hash : Boolean := False;
+
+            function Visit (Node : Ada_Node'Class) return Visit_Status;
+
+            function Visit (Node : Ada_Node'Class) return Visit_Status is
+            begin
+               if Kind (Node) in Ada_Basic_Subp_Decl
+                 and then Natural (Node.Sloc_Range.Start_Line)
+                          = Test.Common.Subp_Line_Nbr
+               then
+                  Ada.Text_IO.Put (Test.Common.Mangle_Hash_16 (Node));
+                  Found_Hash := True;
+                  return Stop;
+               end if;
+               return Into;
+            end Visit;
+         begin
+            Traverse (Root (Unit), Visit'Access);
+            if not Found_Hash then
+               Ada.Text_IO.Put
+                 ("Subprogram in "
+                  & Test.Common.Subp_File_Name.all
+                  & " at line "
+                  & Natural'Image (Test.Common.Subp_Line_Nbr)
+                  & " could not be found.");
+            end if;
+            return;
+         end;
+      end if;
+
       if Test.Common.Harness_Only then
          Test.Harness.Process_Source (Unit);
       else
@@ -1374,6 +1449,8 @@ package body Test.Actions is
         (" --gen-test-num=n                   - Specify the number of test inputs to be generated (experimental, defaults to 5)\n");
       Put
         (" --gen-test-subprograms=file:line   - Specify a comma separated list of subprograms declared at file:line to generate test cases for\n");
+      Put
+        (" --dump-subp-hash=file:line         - Print the hash of the subprogram at file:line in the standard output and bypass all other swicthes.\n");
       Put
         (" --serialized-test-dir=dir          - Specify in which directory test inputs should be generated (experimental)\n");
       Put

src/test-command_lines.ads

@@ -95,7 +95,8 @@ package Test.Command_Lines is
       Gen_Test_Subprograms,
       Serialized_Test_Dir,
       Cov_Level,
-      Minimization_Filter);
+      Minimization_Filter,
+      Dump_Subp_Hash);
 
    package Test_String_Switches is new
      String_Switches (Descriptor, Test_Strings);
@@ -117,7 +118,8 @@ package Test.Command_Lines is
          Gen_Test_Subprograms => '=',
          Serialized_Test_Dir  => '=',
          Cov_Level            => '=',
-         Minimization_Filter  => '=']);
+         Minimization_Filter  => '=',
+         Dump_Subp_Hash       => '=']);
 
    type Test_String_Seqs is (Exclude_From_Stubbing);
 

src/test-common.ads

@@ -298,6 +298,14 @@ package Test.Common is
    --  The root directory to place the test file hierarchy in case of
    --  --separate-root option.
 
+   Subp_File_Name : String_Access;
+   --  Name of the file from which we want to extract the hash in case of the
+   --  --dump-subp-hash option
+
+   Subp_Line_Nbr : Natural;
+   --  Line in Subp_File_Name from which we want to extract the hash in case of
+   --  the --dump-subp-hash option
+
    Test_Dir_Name : GNAT.OS_Lib.String_Access :=
      new String'("gnattest" & GNAT.OS_Lib.Directory_Separator & "tests");
    --  Name of default directory to place test files

testsuite/tests/test/273-dump_subp_hash/test.out

@@ -0,0 +1 @@
+success

testsuite/tests/test/273-dump_subp_hash/test.sh

@@ -0,0 +1,16 @@
+#!/bin/bash
+
+cd test/
+gnattest -Psimple --dump-subp-hash=src/simple.ads:5 > my_hash 2> /dev/null
+gnattest -Psimple src/simple.ads --gen-test-vectors
+grep -o -E "^..([a-z]|[0-9]){16}" obj/gnattest/tests/JSON_Tests/simple.json | cut -c 3- > hash_ref
+
+if cmp -s my_hash hash_ref; then
+    printf 'success\n'
+else
+    printf 'error: The two hashes do not match. expected:\n'
+    cat hash_ref
+    printf 'but got:\n'
+    cat my_hash
+    printf '\n'
+fi;

testsuite/tests/test/273-dump_subp_hash/test.yaml

@@ -0,0 +1,4 @@
+description: Test that asserts that --dump-subp-hash=<filename>:<line>
+    indeed prints the correct hash.
+
+driver: shell_script

testsuite/tests/test/273-dump_subp_hash/test/simple.gpr

@@ -0,0 +1,5 @@
+project Simple is
+    for Source_Dirs use ("src");
+    for Object_Dir use "obj";
+    for Main use ("main.adb");
+end Simple;

testsuite/tests/test/273-dump_subp_hash/test/src/main.adb

@@ -0,0 +1,10 @@
+with Simple; use Simple;
+
+procedure Main is
+   X : constant T := 8;
+   Y : constant T := 7;
+   Z : T;
+begin
+   Z := Foo (X, Y);
+   null;
+end Main;

testsuite/tests/test/273-dump_subp_hash/test/src/simple.adb

@@ -0,0 +1,8 @@
+package body Simple is
+
+   function Foo (X, Y : T) return T is
+   begin
+      return X + Y;
+   end Foo;
+
+end Simple;

testsuite/tests/test/273-dump_subp_hash/test/src/simple.ads

@@ -0,0 +1,8 @@
+package Simple is
+
+   type T is range 0 .. 10;
+
+   function Foo (X, Y : T) return T
+     with Post => Foo'Result < 15;
+
+end Simple;