From 7803c0d1baf2136198b3c47ef41e8dfda0130ab9 Mon Sep 17 00:00:00 2001 From: Matthieu Eyraud Date: Thu, 22 Aug 2024 15:49:01 +0200 Subject: [PATCH] Fix API for diagnostics / unsupported types The API is friendlier if the diagnostics are returned as a list of strings, rather than a big concatenated string, as it allows the endpoint user to configure the displaying the way he wants. This commit does not change the behavior of the tool, so it does not require additional testing. --- src/test-generation.adb | 6 ++- src/test-instrument.adb | 8 ++-- src/test-skeleton.adb | 10 ++--- src/tgen/tgen-libgen.adb | 43 ++++++++----------- src/tgen/tgen-libgen.ads | 20 ++++----- src/tgen/tgen_rts/tgen-strings.adb | 20 ++++++++- src/tgen/tgen_rts/tgen-strings.ads | 5 +++ src/tgen/tgen_rts/tgen-types.ads | 14 ++++++ .../src/tgen_marshalling.adb | 5 ++- 9 files changed, 80 insertions(+), 51 deletions(-) diff --git a/src/test-generation.adb b/src/test-generation.adb index c77a0747..e63b5a68 100644 --- a/src/test-generation.adb +++ b/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; diff --git a/src/test-instrument.adb b/src/test-instrument.adb index 75401ec6..24a00082 100755 --- a/src/test-instrument.adb +++ b/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; diff --git a/src/test-skeleton.adb b/src/test-skeleton.adb index 80f6687f..d2e257cc 100755 --- a/src/test-skeleton.adb +++ b/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; diff --git a/src/tgen/tgen-libgen.adb b/src/tgen/tgen-libgen.adb index ba3867d5..a6dc02c1 100644 --- a/src/tgen/tgen-libgen.adb +++ b/src/tgen/tgen-libgen.adb @@ -21,7 +21,6 @@ -- . -- ------------------------------------------------------------------------------ -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; diff --git a/src/tgen/tgen-libgen.ads b/src/tgen/tgen-libgen.ads index cc8a285d..f8eb51db 100644 --- a/src/tgen/tgen-libgen.ads +++ b/src/tgen/tgen-libgen.ads @@ -78,9 +78,9 @@ 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 @@ -88,21 +88,21 @@ package TGen.Libgen is -- -- 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; diff --git a/src/tgen/tgen_rts/tgen-strings.adb b/src/tgen/tgen_rts/tgen-strings.adb index 07269a71..3ca64e37 100644 --- a/src/tgen/tgen_rts/tgen-strings.adb +++ b/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 -- -------------- diff --git a/src/tgen/tgen_rts/tgen-strings.ads b/src/tgen/tgen_rts/tgen-strings.ads index 87488133..3735dddb 100644 --- a/src/tgen/tgen_rts/tgen-strings.ads +++ b/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, diff --git a/src/tgen/tgen_rts/tgen-types.ads b/src/tgen/tgen_rts/tgen-types.ads index 05f61221..98be1066 100644 --- a/src/tgen/tgen_rts/tgen-types.ads +++ b/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; diff --git a/testsuite/ada_drivers/gen_marshalling_lib/src/tgen_marshalling.adb b/testsuite/ada_drivers/gen_marshalling_lib/src/tgen_marshalling.adb index 71326798..b25ab429 100644 --- a/testsuite/ada_drivers/gen_marshalling_lib/src/tgen_marshalling.adb +++ b/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;