Merge branch 'leo/tgen-incomplete_types' into 'master'

TGen: Fix translation of subtypes of incomplete types

Closes #3

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

src/tgen/tgen-types-translation.adb

@@ -148,7 +148,7 @@ package body TGen.Types.Translation is
      (Decl      : Base_Type_Decl;
       Type_Name : Defining_Name;
       Cmp_Idx   : Positive) return Translation_Result with
-      Pre => Decl.P_Is_Array_Type;
+      Pre => Decl.P_Root_Type.P_Full_View.P_Is_Array_Type;
 
    function Translate_Component_Decl_List
      (Decl_List : Ada_Node_List;
@@ -185,7 +185,7 @@ package body TGen.Types.Translation is
      (Decl      : Base_Type_Decl;
       Type_Name : Defining_Name;
       Cmp_Idx   : Positive) return Translation_Result with
-      Pre => Decl.P_Is_Record_Type;
+      Pre => Decl.P_Root_Type.P_Full_View.P_Is_Record_Type;
 
    procedure Apply_Record_Subtype_Decl
      (Decl : Subtype_Indication;
@@ -837,7 +837,8 @@ package body TGen.Types.Translation is
          --  There can be no delta constraints on a decimal fixed point type
          --  as per RM J.3 (5) so lets work on the type definition directly.
 
-         Root_Typ : constant Type_Decl := Decl.P_Root_Type.As_Type_Decl;
+         Root_Typ : constant Type_Decl :=
+           Decl.P_Root_Type.P_Full_View.As_Type_Decl;
          Eval_Res : constant Eval_Result :=
            Expr_Eval (Root_Typ.F_Type_Def.As_Decimal_Fixed_Point_Def.F_Delta);
       begin
@@ -892,7 +893,8 @@ package body TGen.Types.Translation is
      (Decl     :     Base_Type_Decl; Has_Range : out Boolean;
       Min, Max : out Big_Reals.Big_Real)
    is
-      Root           : constant Type_Decl := Decl.P_Root_Type.As_Type_Decl;
+      Root           : constant Type_Decl :=
+        Decl.P_Root_Type.P_Full_View.As_Type_Decl;
       Parent_Type    : Subtype_Indication := No_Subtype_Indication;
       Range_Spec_Val : Range_Spec         := No_Range_Spec;
    begin
@@ -1176,8 +1178,8 @@ package body TGen.Types.Translation is
         (Decl : Base_Type_Decl) return Translation_Result
       is
          Cmp_Typ_Def : constant Component_Def :=
-            Decl.P_Root_Type.As_Type_Decl.F_Type_Def.As_Array_Type_Def
-            .F_Component_Type;
+            Decl.P_Root_Type.P_Full_View.As_Type_Decl.F_Type_Def
+            .As_Array_Type_Def.F_Component_Type;
          Num_Indices : Natural := 0;
       begin
          --  Compute the number of indices
@@ -2235,12 +2237,13 @@ package body TGen.Types.Translation is
 
       --  First the simple case of an undiscriminated record
 
-      if Kind (Decl.P_Root_Type) in Ada_Type_Decl
-        and then Kind (Decl.P_Root_Type.As_Type_Decl.F_Type_Def)
+      if Kind (Decl.P_Root_Type.P_Full_View) in Ada_Type_Decl
+        and then Kind (Decl.P_Root_Type.P_Full_View.As_Type_Decl.F_Type_Def)
                    in Ada_Record_Type_Def_Range
-        and then Is_Null (Decl.P_Root_Type.As_Type_Decl.F_Discriminants)
+        and then Is_Null
+                   (Decl.P_Root_Type.P_Full_View.As_Type_Decl.F_Discriminants)
       then
-         Actual_Decl := Decl.P_Root_Type.As_Type_Decl;
+         Actual_Decl := Decl.P_Root_Type.P_Full_View.As_Type_Decl;
 
          declare
             Trans_Res : Nondiscriminated_Record_Typ;
@@ -2275,7 +2278,7 @@ package body TGen.Types.Translation is
       else
          --  Now the rest
 
-         Actual_Decl := Decl.P_Root_Type.As_Type_Decl;
+         Actual_Decl := Decl.P_Root_Type.P_Full_View.As_Type_Decl;
 
          declare
             Trans_Res : Discriminated_Record_Typ
@@ -2875,7 +2878,7 @@ package body TGen.Types.Translation is
       Verbose           : Boolean := False;
       Assume_Non_Static : Boolean := False) return Translation_Result
    is
-      Root_Type : constant Base_Type_Decl := N.P_Root_Type;
+      Root_Type : constant Base_Type_Decl := N.P_Root_Type.P_Full_View;
       Is_Static : Boolean := not Assume_Non_Static;
       --  Relevant only for Scalar types / array bounds
       --  / discriminant constraints.
@@ -2925,15 +2928,15 @@ package body TGen.Types.Translation is
                    (Type_Name.P_Fully_Qualified_Name_Array),
                Last_Comp_Unit_Idx => Comp_Unit_Idx));
          end return;
-      elsif N.P_Is_Formal then
+      elsif Root_Type.P_Is_Formal then
          return Res : Translation_Result (Success => True) do
             Res.Res.Set (Formal_Typ'
               (Name               =>
                  Convert_Qualified_Name
                    (Type_Name.P_Fully_Qualified_Name_Array),
                Last_Comp_Unit_Idx => Comp_Unit_Idx));
          end return;
-      elsif N.P_Is_Int_Type then
+      elsif Root_Type.P_Is_Int_Type then
          if Is_Static then
             return Translate_Int_Decl (N, Type_Name, Comp_Unit_Idx);
          else
@@ -2958,7 +2961,7 @@ package body TGen.Types.Translation is
                  (Type_Name.P_Fully_Qualified_Name_Array),
                Last_Comp_Unit_Idx => Comp_Unit_Idx));
          end return;
-      elsif N.P_Is_Enum_Type then
+      elsif Root_Type.P_Is_Enum_Type then
 
          if not Is_Static then
             return Res : Translation_Result (Success => True) do
@@ -2985,7 +2988,7 @@ package body TGen.Types.Translation is
             end if;
          end;
 
-      elsif N.P_Is_Float_Type then
+      elsif Root_Type.P_Is_Float_Type then
          if Is_Static then
             return Translate_Float_Decl (N, Type_Name, Comp_Unit_Idx);
          else
@@ -3001,7 +3004,7 @@ package body TGen.Types.Translation is
             end return;
          end if;
 
-      elsif N.P_Is_Fixed_Point then
+      elsif Root_Type.P_Is_Fixed_Point then
          if Kind (Root_Type.As_Type_Decl.F_Type_Def) in
              Ada_Ordinary_Fixed_Point_Def_Range
          then
@@ -3037,11 +3040,11 @@ package body TGen.Types.Translation is
             end if;
          end if;
 
-      elsif N.P_Is_Array_Type then
+      elsif Root_Type.P_Is_Array_Type then
          return Translate_Array_Decl (N, Type_Name, Comp_Unit_Idx);
 
-      elsif N.P_Is_Record_Type then
-         if N.P_Is_Tagged_Type then
+      elsif Root_Type.P_Is_Record_Type then
+         if Root_Type.P_Is_Tagged_Type then
             return Res : Translation_Result (Success => True) do
                Res.Res.Set
                  (Unsupported_Typ'
@@ -3054,7 +3057,7 @@ package body TGen.Types.Translation is
             return Translate_Record_Decl (N, Type_Name, Comp_Unit_Idx);
          end if;
 
-      elsif N.P_Is_Access_Type then
+      elsif Root_Type.P_Is_Access_Type then
          return Res : Translation_Result (Success => True) do
             Res.Res.Set
               (Access_Typ'

testsuite/tests/test/marshalling_private/example_gen.adb

@@ -0,0 +1,39 @@
+with Ada.Streams;
+with Ada.Streams.Stream_IO;       use Ada.Streams.Stream_IO;
+with Ada.Text_IO;                 use Ada.Text_IO;
+with Interfaces;                  use Interfaces;
+with Foo;                         use Foo;
+with Foo.TGen_Support;            use Foo.TGen_Support;
+
+procedure Example_Gen is
+
+   F         : Ada.Streams.Stream_IO.File_Type;
+   S         : Stream_Access;
+   File_Name : constant String := "scratch_pad.bin";
+   Bar_1, Bar_2 : Bar;
+   Baz_1, Baz_2 : Baz;
+
+
+begin
+   Create (F, Out_File, File_Name);
+   S := Stream (F);
+
+   TGen_Marshalling_foo_bar_output (S, Bar_1);
+   TGen_Marshalling_foo_baz_output (S, Baz_2);
+
+   Close (F);
+
+   Open (F, In_File, File_Name);
+
+   Bar_2 := TGen_Marshalling_foo_bar_input(S);
+   Baz_2 := TGen_Marshalling_foo_baz_input(S);
+
+   Close (F);
+
+   if Bar_1 /= Bar_2 then
+      Put_Line ("Error comparing Bar");
+   elsif Baz_1 /= Baz_2 then
+      Put_Line ("Error comparing Baz");
+   end if;
+
+end Example_Gen;

testsuite/tests/test/marshalling_private/test.sh

@@ -0,0 +1,14 @@
+#!/bin/bash
+
+LALTOOLS_ROOT=$(dirname $(which gnattest))/..
+TEMPLATES_PATH=$LALTOOLS_ROOT/share/tgen/templates
+RTS_PATH=$LALTOOLS_ROOT/share/tgen/tgen_rts
+if [ "$OS" == "Windows_NT" ]; then
+    export GPR_PROJECT_PATH=$RTS_PATH";"$GPR_PROJECT_PATH
+else
+    export GPR_PROJECT_PATH=$RTS_PATH:$GPR_PROJECT_PATH
+fi
+mkdir -p test/obj obj
+tgen_marshalling -P test/test.gpr --templates-dir=$TEMPLATES_PATH -o test/tgen_support test/foo.ads
+gprbuild -q -P test_gen.gpr
+./obj/example_gen

testsuite/tests/test/marshalling_private/test.yaml

@@ -0,0 +1,6 @@
+description:
+    test support for subtypes of incomplete types for the marshalling lib
+
+driver: shell_script
+control:
+    - [XFAIL, 'x86', 'Marshalling not working for 32bits (UB03-008)']

testsuite/tests/test/marshalling_private/test/foo.adb

@@ -0,0 +1,6 @@
+package body Foo is
+   procedure Qux (F : Bar; B : Baz) is
+   begin
+      null;
+   end Qux;
+end Foo;

testsuite/tests/test/marshalling_private/test/foo.ads

@@ -0,0 +1,7 @@
+package Foo is
+   type Bar is private;
+   subtype Baz is Bar;
+   procedure Qux (F : Bar; B : Baz);
+private
+   type Bar is null record;
+end Foo;

testsuite/tests/test/marshalling_private/test/test.gpr

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

testsuite/tests/test/marshalling_private/test_gen.gpr

@@ -0,0 +1,19 @@
+with "test/test.gpr";
+with "test/tgen_support/tgen_support.gpr";
+
+project Test_Gen is
+
+   for Main use ("example_gen.adb");
+
+   for Object_Dir use "obj";
+
+   package Builder is
+      for Switches ("ada") use ("-g", "-gnat2022");
+   end Builder;
+
+   package Linker is
+      for Switches ("ada") use ("-g");
+   end Linker;
+
+end Test_Gen;
+