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;