Merge branch 'eyraud/188' into 'master'

Fix API for diagnostics / unsupported types

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

src/test-generation.adb

@@ -40,6 +40,7 @@ with Libadalang.Common; use Libadalang.Common;
 with Langkit_Support.Text;
 
 with TGen.Libgen; use TGen.Libgen;
+with TGen.Strings;
 
 package body Test.Generation is
 
@@ -55,7 +56,8 @@ package body Test.Generation is
    ---------------------
 
    function Traverse_Helper (Node : Ada_Node'Class) return Visit_Status is
-      Diags : Unbounded_String;
+      use TGen.Strings;
+      Diags : String_Vector;
    begin
       --  Do not traverse package bodies
 
@@ -107,7 +109,7 @@ package body Test.Generation is
 
             Report_Err
               ("Error while processing " & Node.Image & ":" & ASCII.LF
-               & To_String (Diags));
+               & Join (Diags) & ASCII.LF);
          end if;
          return Over;
       end if;

src/test-instrument.adb

@@ -114,7 +114,7 @@ package body Test.Instrument is
    ------------------
 
    function Inspect_Spec (Node : Ada_Node'Class) return Visit_Status is
-      Errors : Ada.Strings.Unbounded.Unbounded_String;
+      Diags : String_Vector;
    begin
       if Kind (Node) = Ada_Package_Decl then
          return Into;
@@ -139,11 +139,9 @@ package body Test.Instrument is
          end if;
 
          if not TGen.Libgen.Include_Subp
-           (TGen_Libgen_Ctx,
-            Node.As_Basic_Decl,
-            Errors)
+           (TGen_Libgen_Ctx, Node.As_Basic_Decl, Diags)
          then
-            Report_Std (Ada.Strings.Unbounded.To_String (Errors));
+            Report_Std (Join (Diags) & ASCII.LF);
             return Over;
          end if;
 

src/test-skeleton.adb

@@ -6806,7 +6806,7 @@ package body Test.Skeleton is
       Param_Values  : JSON_Array;
       Global_Values : JSON_Array;
 
-      Diags : Unbounded_String;
+      Diags : String_Vector;
       --  Diagnostics for TGen.Libgen.Include_Subp
 
       Output_Dir : constant String :=
@@ -6875,12 +6875,12 @@ package body Test.Skeleton is
 
          if not Test.Common.Unparse_Test_Vectors then
             if not TGen.Libgen.Include_Subp
-                     (Test.Common.TGen_Libgen_Ctx,
-                      Subp.Subp_Declaration.As_Basic_Decl,
-                      Diags)
+              (Test.Common.TGen_Libgen_Ctx,
+               Subp.Subp_Declaration.As_Basic_Decl,
+               Diags)
             then
                Report_Std
-                 ("Error while loading JSON tests:" & To_String (Diags)
+                 ("Error while loading JSON tests:" & Join (Diags)
                   & ASCII.LF & "Tests will not be loaded for " &
                   Subp.Subp_Name_Image.all);
                goto Continue;

src/tgen/tgen-libgen.adb

@@ -21,7 +21,6 @@
 -- <http://www.gnu.org/licenses/>.                                          --
 ------------------------------------------------------------------------------
 
-with Ada.Characters.Latin_1;
 with Ada.Command_Line;
 with Ada.Containers;
 with Ada.Directories;
@@ -644,29 +643,21 @@ package body TGen.Libgen is
 
    function Supported_Subprogram (Subp : LAL.Basic_Decl'Class) return SP.Ref
    is
-      Reason    : Unbounded_String;
+      Diags     : String_Vectors.Vector;
       Trans_Res : constant Translation_Result :=
         Translate (Subp.As_Basic_Decl);
    begin
       if Trans_Res.Success then
-         declare
-            Unsupported_Diags : constant String_Vector :=
-              Trans_Res.Res.Get.Get_Diagnostics;
-         begin
-            if String_Vectors.Is_Empty (Unsupported_Diags) then
-               return Trans_Res.Res;
-            else
-               for D of Unsupported_Diags loop
-                  Reason := Reason & D & Ada.Characters.Latin_1.LF;
-               end loop;
-            end if;
-         end;
+         Diags := Trans_Res.Res.Get.Get_Diagnostics;
+         if Diags.Is_Empty then
+            return Trans_Res.Res;
+         end if;
       else
-         Reason := Trans_Res.Diagnostics;
+         Diags := String_Vectors.To_Vector (Trans_Res.Diagnostics, 1);
       end if;
       declare
-         Typ_Res : constant Unsupported_Typ :=
-           Unsupported_Typ'(Reason => Reason, others => <>);
+         Typ_Res : constant Unsupported_Types :=
+           Unsupported_Types'(Diags => Diags, others => <>);
          Res     : SP.Ref;
       begin
          Res.Set (Typ_Res);
@@ -679,9 +670,9 @@ package body TGen.Libgen is
    ------------------
 
    function Include_Subp
-     (Ctx  : in out Libgen_Context;
-      Subp : Basic_Decl'Class;
-      Diag : out Unbounded_String) return Boolean
+     (Ctx   : in out Libgen_Context;
+      Subp  : Basic_Decl'Class;
+      Diags : out String_Vectors.Vector) return Boolean
    is
       use Ada_Qualified_Name_Sets_Maps;
 
@@ -706,7 +697,7 @@ package body TGen.Libgen is
       Trans_Res : constant SP.Ref := Supported_Subprogram (Subp);
    begin
       if Trans_Res.Get.Kind = Unsupported then
-         Diag := Unsupported_Typ (Trans_Res.Unchecked_Get.all).Reason;
+         Diags := Trans_Res.Get.Get_Diagnostics;
          return False;
       end if;
 
@@ -983,13 +974,13 @@ package body TGen.Libgen is
    --------------
 
    function Generate
-     (Ctx  : in out Libgen_Context;
-      Subp : LAL.Basic_Decl'Class;
-      Diag : out Unbounded_String;
-      Part : Any_Library_Part := All_Parts) return Boolean
+     (Ctx   : in out Libgen_Context;
+      Subp  : LAL.Basic_Decl'Class;
+      Diags : out String_Vectors.Vector;
+      Part  : Any_Library_Part := All_Parts) return Boolean
    is
    begin
-      if Include_Subp (Ctx, Subp, Diag) then
+      if Include_Subp (Ctx, Subp, Diags) then
          Generate (Ctx, Part);
       else
          return False;

src/tgen/tgen-libgen.ads

@@ -78,31 +78,31 @@ package TGen.Libgen is
    --  supported inlined in the Unsupported_Typ.Reason field.
 
    function Include_Subp
-     (Ctx  : in out Libgen_Context;
-      Subp : LAL.Basic_Decl'Class;
-      Diag : out Unbounded_String) return Boolean;
+     (Ctx   : in out Libgen_Context;
+      Subp  : LAL.Basic_Decl'Class;
+      Diags : out TGen.Strings.String_Vectors.Vector) return Boolean;
    --  Register all the types in the parameters of Subp in the set of types for
    --  which the marshalling library will be generated. This procedures does
    --  not actually generate any sources, call Generate to create the support
    --  library for all the registered types.
    --
    --  Returns False if there is an error translating some of the parameter
    --  types, or if some of the types are unsupported for marshalling,
-   --  reporting a diagnostic string in Diag. In that case, the context
-   --  is not modified. Otherwise, Diag should be ignored.
+   --  and report diagnostics in Diags. In that case, the context is not
+   --  modified. Otherwise, Diags should be ignored.
 
    procedure Generate
      (Ctx : in out Libgen_Context; Part : Any_Library_Part := All_Parts);
    --  Output all of the support library files
 
    function Generate
-     (Ctx  : in out Libgen_Context;
-      Subp : LAL.Basic_Decl'Class;
-      Diag : out Unbounded_String;
-      Part : Any_Library_Part := All_Parts) return Boolean;
+     (Ctx   : in out Libgen_Context;
+      Subp  : LAL.Basic_Decl'Class;
+      Diags : out TGen.Strings.String_Vectors.Vector;
+      Part  : Any_Library_Part := All_Parts) return Boolean;
    --  Shortcut for
    --
-   --     if Include_Subp (Ctx, Subp, Diags) then
+   --     if Include_Subp (Ctx, Subp, Diag) then
    --       Generate (Ctx);
    --     else
    --        return False;

src/tgen/tgen_rts/tgen-strings.adb

@@ -22,10 +22,28 @@
 ------------------------------------------------------------------------------
 
 with Ada.Characters.Handling;
-with Ada.Characters.Latin_1;
 
 package body TGen.Strings is
 
+   ----------
+   -- Join --
+   ----------
+
+   function Join
+     (V   : String_Vector;
+      Sep : Character := Ada.Characters.Latin_1.LF) return String
+   is
+      Result : Unbounded_String;
+   begin
+      for I in V.First_Index .. V.Last_Index loop
+         Append (Result, V (I));
+         if I /= V.Last_Index then
+            Append (Result, Sep);
+         end if;
+      end loop;
+      return +Result;
+   end Join;
+
    --------------
    -- New_Line --
    --------------

src/tgen/tgen_rts/tgen-strings.ads

@@ -23,6 +23,7 @@
 --
 --  String manipulation utilities
 
+with Ada.Characters.Latin_1;
 with Ada.Containers;
 with Ada.Containers.Indefinite_Ordered_Sets;
 with Ada.Containers.Ordered_Maps;
@@ -58,6 +59,10 @@ package TGen.Strings is
       Element_Type => Ada.Strings.Unbounded.Unbounded_String);
    subtype String_Vector is String_Vectors.Vector;
 
+   function Join
+     (V   : String_Vector;
+      Sep : Character := Ada.Characters.Latin_1.LF) return String;
+
    package String_Ordered_Sets is new
      Ada.Containers.Indefinite_Ordered_Sets
        (Element_Type        => String,

src/tgen/tgen_rts/tgen-types.ads

@@ -238,6 +238,7 @@ package TGen.Types is
    type Unsupported_Typ is new Typ with record
       Reason : Unbounded_String;
       --  Why this type is not supported.
+
    end record;
 
    function Get_Diagnostics
@@ -255,4 +256,17 @@ package TGen.Types is
 
    type Formal_Typ is new Unsupported_Typ with null record;
 
+   type Unsupported_Types is new Typ with record
+      Diags : String_Vectors.Vector;
+      --  Why this type is not supported.
+
+   end record;
+
+   function Get_Diagnostics
+     (Self   : Unsupported_Types;
+      Prefix : String := "") return String_Vector
+   is (Self.Diags);
+
+   function Kind (Self : Unsupported_Types) return Typ_Kind is (Unsupported);
+
 end TGen.Types;

testsuite/ada_drivers/gen_marshalling_lib/src/tgen_marshalling.adb

@@ -32,6 +32,7 @@ with Libadalang.Helpers;
 
 with TGen.LAL_Utils; use TGen.LAL_Utils;
 with TGen.Libgen;    use TGen.Libgen;
+with TGen.Strings;   use TGen.Strings;
 
 procedure TGen_Marshalling is
    package LAL renames Libadalang.Analysis;
@@ -134,7 +135,7 @@ procedure TGen_Marshalling is
       function Traverse_Helper
         (Node : LAL.Ada_Node'Class) return LALCO.Visit_Status
       is
-         Diags : Unbounded_String;
+         Diags : String_Vector;
       begin
          --  Collect all types used as parameters in subprogram declarations.
          --  Skip generic subprogram declarations as we only care about the
@@ -153,7 +154,7 @@ procedure TGen_Marshalling is
                Put_Line
                  ("Error during parameter translation of subprogram "
                   & (+Node.As_Basic_Decl.P_Fully_Qualified_Name) & ":");
-               Put_Line (To_String (Diags));
+               Put_Line (Join (Diags) & ASCII.LF);
                if not Skip_Unsupported.Get then
                   Libadalang.Helpers.Abort_App;
                end if;