Merge branch 'leo/135_name_conflict' into 'master'

TGen: Fix wrong code generation for wrappers in case of name conflict

Closes #135

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

src/tgen/tgen-libgen.adb

@@ -517,7 +517,10 @@ package body TGen.Libgen is
         Ada.Directories.Compose
           (Containing_Directory => To_String (Ctx.Output_Dir),
            Name                 => To_Filename (Pack_Name));
+      Origin_Package   : Ada_Qualified_Name := Pack_Name;
    begin
+      Origin_Package.Delete_Last;
+
       Create (F_Spec, Out_File, File_Name & ".ads");
       Create (F_Body, Out_File, File_Name & ".adb");
 
@@ -528,6 +531,14 @@ package body TGen.Libgen is
       Put_Line (F_Body, "package body " & Ada_Pack_Name & " is");
       New_Line (F_Body);
 
+      --  Put a renaming for the origin package. This is used to make
+      --  references to its entities when a parameter name or subprogram name
+      --  shadows the package.
+
+      Put_Line (F_Body, "package " & Source_Package_Renaming & " renames "
+                        & To_Ada (Origin_Package) & ";");
+      New_Line (F_Body);
+
       for Subp of Ctx.Included_Subps.Element (Pack_Name) loop
          declare
             LAL_Context : constant Libadalang.Analysis.Analysis_Context :=

src/tgen/tgen-wrappers.adb

@@ -268,7 +268,21 @@ package body TGen.Wrappers is
       Call_To_User_Subp : Unbounded_String;
       --  Call to the original user subprogram
 
+      Local_Package_Name : Ada_Qualified_Name;
+      --  Name of the subprogram in its compilation unit. This is its fully
+      --  qualified name, from which the compilation unit's fully qualified
+      --  name has been removed.
+
    begin
+      --  Compute local name. Do not take into account the last element as this
+      --  is its hash.
+
+      for I in
+         Subprogram.Last_Comp_Unit_Idx + 1 .. Subprogram.Name.Last_Index - 1
+      loop
+         Local_Package_Name.Append (Subprogram.Name.Element (I));
+      end loop;
+
       --  Compute the call to the original function
 
       case Subp_Kind (Subprogram) is
@@ -278,7 +292,9 @@ package body TGen.Wrappers is
             null;
       end case;
 
-      Append (Call_To_User_Subp, Subprogram.FQN);
+      Append
+        (Call_To_User_Subp,
+         Source_Package_Renaming & "." & To_Ada (Local_Package_Name));
 
       if Subprogram.Param_Order.Length > 0 then
          Append (Call_To_User_Subp, " (");

src/tgen/tgen-wrappers.ads

@@ -91,4 +91,41 @@ package TGen.Wrappers is
    --  Note: this would also require drastic changes in the value generation as
    --  (as we would need to generate values for them).
 
+   Source_Package_Renaming : constant String := "TGen_Original_Package";
+   --  Package name to be used to rename the original package when generating
+   --  wrappers to avoid shadowing. This happens when a subprogram has
+   --  parameters with the same name as the package in which it is declared.
+   --
+   --  For instance, given the following package declaration:
+   --
+   --  package Foo is
+   --     procedure Bar (Foo : Integer) with
+   --       Pre => True;
+   --  end Foo;
+   --
+   --  The generated wrapper for Bar will look like:
+   --
+   --  procedure Bar (Foo : standard.Integer) is
+   --  begin
+   --     if not True then
+   --        raise TGen.Precondition_Error;
+   --     end if;
+   --     Foo.Bar (Foo);
+   --  end Bar;
+   --
+   --  In the body above, Foo designates the parameter, so Foo.Bar is undefined
+   --  and the wrapper does not compile.
+   --
+   --  By introducing a package renaming, the wrapper package now looks like
+   --
+   --  package TGen_Original_Package renames Foo;
+   --
+   --  procedure Bar (Foo : standard.Integer) is
+   --  begin
+   --     --  ...
+   --     TGen_Original_Package.Bar (Foo);
+   --  end Bar;
+   --
+   --  This solves the masking issue.
+
 end TGen.Wrappers;

testsuite/tests/test/135_tgen_wrapper_conflict/main.adb

@@ -0,0 +1,21 @@
+with Ada.Text_IO; use Ada.Text_IO;
+
+with TGen;
+with Simple.TGen_Wrappers;
+
+procedure Main is
+begin
+   begin
+      Simple.TGen_Wrappers.test (4);
+   exception
+      when TGen.Precondition_Error =>
+         Put_Line ("Unexpected exception from tgen wrapper");
+   end;
+   begin
+      Simple.TGen_Wrappers.test(1);
+      Put_Line ("Missing exception from tgen wrapper");
+   exception
+      when TGen.Precondition_Error =>
+         null;
+   end;
+end Main;

testsuite/tests/test/135_tgen_wrapper_conflict/test.sh

@@ -0,0 +1,7 @@
+#!/bin/bash
+
+LALTOOLS_ROOT=$(dirname $(which gnattest))/..
+TEMPLATES_PATH=$LALTOOLS_ROOT/share/tgen/templates
+mkdir -p test/obj obj
+tgen_marshalling -P test/test.gpr --templates-dir=$TEMPLATES_PATH -o test/tgen_support test/simple.ads
+gprbuild -q -P test_wrapper.gpr -cargs -gnata

testsuite/tests/test/135_tgen_wrapper_conflict/test.yaml

@@ -0,0 +1,7 @@
+description: Test that TGen generates precondition wrappers that can be
+  compiled when a parameter of the tested subprogram has the same name as
+  the package in which it is defined.
+
+driver: shell_script
+control:
+    - [XFAIL, 'x86', 'Marshalling not working for 32bits (UB03-008)']

testsuite/tests/test/135_tgen_wrapper_conflict/test/simple.adb

@@ -0,0 +1,5 @@
+package body Simple is
+
+   procedure Test (Simple : Integer) is null;
+
+end Simple;

testsuite/tests/test/135_tgen_wrapper_conflict/test/simple.ads

@@ -0,0 +1,6 @@
+package Simple is
+
+   procedure Test (Simple : Integer) with
+     Pre => Simple >= 1 and then Simple >= 2;
+
+end Simple;

testsuite/tests/test/135_tgen_wrapper_conflict/test/test.gpr

@@ -0,0 +1,6 @@
+project Test is
+
+   for Object_Dir use "obj";
+   for Source_Dirs use (".");
+
+end Test;

testsuite/tests/test/135_tgen_wrapper_conflict/test_wrapper.gpr

@@ -0,0 +1,10 @@
+with "test/tgen_support/tgen_support.gpr";
+with "tgen_rts.gpr";
+
+project Test_Wrapper is
+
+    for Object_Dir use "obj";
+    for Source_Dirs use (".");
+    for Main use ("main.adb");
+
+end Test_Wrapper;