From 936b2e0327df7f45930cd54325dd342f5d243ea3 Mon Sep 17 00:00:00 2001 From: Emmanuel Briot Date: Thu, 15 Apr 2021 08:51:33 +0200 Subject: [PATCH] remove use of some anonymous access types Newer GNAT compilers complain about accessibility check failures. Use GNATCOLL.Refcount.Shared_Pointers instead of Smart_Pointers, as the latter has been Obsolescent for years now. --- src/bdd/bdd-asserts.adb | 4 ++-- src/bdd/bdd-asserts_generic.adb | 16 +++++++++------- src/bdd/bdd-asserts_generic.ads | 16 ++++++++-------- src/bdd/bdd-features.adb | 18 +++++++++--------- src/bdd/bdd-features.ads | 16 ++++++++-------- src/bdd/bdd-formatters.adb | 2 +- src/bdd/bdd-formatters.ads | 3 ++- src/bdd/bdd-main.adb | 2 +- src/bdd/bdd-media.adb | 8 +++++--- src/bdd/bdd-runner.adb | 2 +- src/bdd/bdd-runner.ads | 2 +- src/bdd/bdd-tables.adb | 10 +++++----- src/bdd/bdd-tables.ads | 4 ++-- 13 files changed, 54 insertions(+), 49 deletions(-) diff --git a/src/bdd/bdd-asserts.adb b/src/bdd/bdd-asserts.adb index 4b5b395..769efac 100644 --- a/src/bdd/bdd-asserts.adb +++ b/src/bdd/bdd-asserts.adb @@ -38,7 +38,7 @@ package body BDD.Asserts is type Error_With_Table_Access is access all Error_With_Table'Class; overriding procedure Display - (Self : not null access Error_With_Table; + (Self : Error_With_Table; Output : not null access Media_Writer'Class; Status : Scenario_Status; Prefix : String := ""); @@ -201,7 +201,7 @@ package body BDD.Asserts is ------------- overriding procedure Display - (Self : not null access Error_With_Table; + (Self : Error_With_Table; Output : not null access Media_Writer'Class; Status : Scenario_Status; Prefix : String := "") diff --git a/src/bdd/bdd-asserts_generic.adb b/src/bdd/bdd-asserts_generic.adb index 0684415..9d9f6c9 100644 --- a/src/bdd/bdd-asserts_generic.adb +++ b/src/bdd/bdd-asserts_generic.adb @@ -47,9 +47,10 @@ package body BDD.Asserts_Generic is -- Details -- ------------- - function Details (Self : Assert_Error) return Error_Details_Access is + function Details (Self : Assert_Error) return Error_Details'Class is + R : Errors.Reference_Type := Self.Get; begin - return Error_Details_Access (Self.Get); + return R.Element.all; -- a copy end Details; ----------------- @@ -57,7 +58,7 @@ package body BDD.Asserts_Generic is ----------------- procedure Set_Details - (Self : not null access Error_Details; + (Self : in out Error_Details'Class; Details : String := ""; Msg : String := ""; Location : String := GNAT.Source_Info.Source_Location; @@ -73,7 +74,7 @@ package body BDD.Asserts_Generic is -- Raise_Exception -- --------------------- - procedure Raise_Exception (Self : not null access Error_Details'Class) is + procedure Raise_Exception (Self : Error_Details'Class) is begin Current_Exception.Set (Self); @@ -92,8 +93,9 @@ package body BDD.Asserts_Generic is Status : Scenario_Status; Prefix : String := "") is + R : Errors.Reference_Type := Self.Get; begin - Display (Self.Details, Output, Status, Prefix); + Display (R, Output, Status, Prefix); end Display; ------------- @@ -101,7 +103,7 @@ package body BDD.Asserts_Generic is ------------- procedure Display - (Self : not null access Error_Details; + (Self : Error_Details; Output : not null access BDD.Media.Media_Writer'Class; Status : Scenario_Status; Prefix : String := "") @@ -133,7 +135,7 @@ package body BDD.Asserts_Generic is -------------------- function From_Exception (E : Exception_Occurrence) return Assert_Error is - Error : constant Error_Details_Access := new Error_Details; + Error : Error_Details; Result : Assert_Error; begin Error.Set_Details (Details => Exception_Information (E)); diff --git a/src/bdd/bdd-asserts_generic.ads b/src/bdd/bdd-asserts_generic.ads index 56fc43e..e375e04 100644 --- a/src/bdd/bdd-asserts_generic.ads +++ b/src/bdd/bdd-asserts_generic.ads @@ -69,13 +69,11 @@ package BDD.Asserts_Generic is -- Free the memory used by Self. -- This should not be called directly. - function Details (Self : Assert_Error) return Error_Details_Access; + function Details (Self : Assert_Error) return Error_Details'Class; -- Returns the actual details of the exception. - -- Do not store the result access, which might be freed when Self is no - -- longer referenced by your application. procedure Set_Details - (Self : not null access Error_Details; + (Self : in out Error_Details'Class; Details : String := ""; Msg : String := ""; Location : String := GNAT.Source_Info.Source_Location; @@ -92,7 +90,7 @@ package BDD.Asserts_Generic is -- Location and Entity are used to point to the code location where the -- error is raised. - procedure Raise_Exception (Self : not null access Error_Details'Class); + procedure Raise_Exception (Self : Error_Details'Class); pragma No_Return (Raise_Exception); -- Wraps Self in an Assert_Error, and raise the Unexpected_Result -- exception. @@ -105,11 +103,12 @@ package BDD.Asserts_Generic is Status : Scenario_Status; Prefix : String := ""); procedure Display - (Self : not null access Error_Details; + (Self : Error_Details; Output : not null access BDD.Media.Media_Writer'Class; Status : Scenario_Status; Prefix : String := ""); -- Display the details on File, using Term to set appropriate colors. + -- Override the second to show more details in your own error types. function From_Exception (E : Exception_Occurrence) return Assert_Error; -- Create from the information contained in the exception @@ -192,13 +191,14 @@ package BDD.Asserts_Generic is private - type Error_Details is new Refcounted with record + type Error_Details is tagged record Details : Unbounded_String; Msg : Unbounded_String; Location : Unbounded_String; end record; - package Errors is new GNATCOLL.Refcount.Smart_Pointers (Error_Details); + package Errors is new GNATCOLL.Refcount.Shared_Pointers + (Error_Details'Class); type Assert_Error is new Errors.Ref with null record; No_Error : constant Assert_Error := (Errors.Null_Ref with null record); diff --git a/src/bdd/bdd-features.adb b/src/bdd/bdd-features.adb index 1a6e660..661aa0d 100644 --- a/src/bdd/bdd-features.adb +++ b/src/bdd/bdd-features.adb @@ -71,14 +71,14 @@ package body BDD.Features is Name : String) return Feature is - R : constant not null access Feature_Record := new Feature_Record; + R : Feature_Record; Self : Feature; begin - Self.Set (R); R.Name := new String'(Trim (Name, Both)); R.File := File; Feature_Ids.Get_Next (R.Id); Trace (Me, "Create feature " & R.Id'Img); + Self.Set (R); return Self; end Create; @@ -212,7 +212,7 @@ package body BDD.Features is procedure Add (Self : Scenario; S : not null access Step_Record'Class) is begin - Self.Get.Steps.Append (S); + Self.Get.Steps.Append (Step (S)); end Add; ------------------ @@ -225,7 +225,7 @@ package body BDD.Features is (Scenario : BDD.Features.Scenario; Step : not null access Step_Record'Class)) is - SR : constant access Scenario_Record := Self.Get; + SR : Scenario_Pointers.Reference_Type := Self.Get; begin for S of SR.Steps loop Callback (Self, S); @@ -237,7 +237,7 @@ package body BDD.Features is ------------------- function Longuest_Step (Self : Scenario) return Natural is - R : constant not null access Scenario_Record'Class := Self.Get; + R : Scenario_Pointers.Reference_Type := Self.Get; begin if R.Longuest_Step = -1 then R.Longuest_Step := Length (R.Name) + Cst_Scenario'Length + 1; @@ -260,14 +260,14 @@ package body BDD.Features is Index : Positive) return Scenario is Self : Scenario; - R : constant not null access Scenario_Record := new Scenario_Record; + R : Scenario_Record; begin - Self.Set (R); R.Name := To_Unbounded_String (Trim (Name, Both)); R.Line := Line; R.Index := Index; R.Kind := Kind; R.Feature := BDD.Features.Feature (Feature); + Self.Set (R); Trace (Me, "Create scenario index=" & Index'Img); return Self; end Create; @@ -454,7 +454,7 @@ package body BDD.Features is --------------------- procedure Add_Example_Row (Self : Scenario; Row : String) is - SR : constant access Scenario_Record := Self.Get; + SR : Scenario_Pointers.Reference_Type := Self.Get; begin if SR.Examples = No_Table then SR.Examples := Create; @@ -577,7 +577,7 @@ package body BDD.Features is (Self : Scenario; Callback : not null access procedure (Scenario : BDD.Features.Scenario)) is - SR : constant access Scenario_Record := Self.Get; + SR : Scenario_Pointers.Reference_Type := Self.Get; Tmp : Scenario; Tmp_Step : Step; diff --git a/src/bdd/bdd-features.ads b/src/bdd/bdd-features.ads index bd8ce20..0d24502 100644 --- a/src/bdd/bdd-features.ads +++ b/src/bdd/bdd-features.ads @@ -227,15 +227,15 @@ private procedure Free (Self : in out Step); -- Free the memory associated with Self - type Feature_Record is new GNATCOLL.Refcount.Refcounted with record + type Feature_Record is tagged record File : GNATCOLL.VFS.Virtual_File; Name : GNAT.Strings.String_Access; Id : Integer; Description : Ada.Strings.Unbounded.Unbounded_String; end record; - overriding procedure Free (Self : in out Feature_Record); - package Feature_Pointers is new GNATCOLL.Refcount.Smart_Pointers - (Feature_Record); + procedure Free (Self : in out Feature_Record); + package Feature_Pointers is new GNATCOLL.Refcount.Shared_Pointers + (Feature_Record, Free); type Feature is new Feature_Pointers.Ref with null record; No_Feature : constant Feature := @@ -244,7 +244,7 @@ private type Scenario_Array; -- Can't instantiate doubly_linked_Lists type Scenario_Array_Access is access all Scenario_Array; - type Scenario_Record is new Refcounted with record + type Scenario_Record is tagged record Name : Ada.Strings.Unbounded.Unbounded_String; Line : Positive := 1; Index : Positive := 1; @@ -259,10 +259,10 @@ private -- For outlines, the list of all examples to be run, and the scenarios -- we are generating for them. end record; - overriding procedure Free (Self : in out Scenario_Record); + procedure Free (Self : in out Scenario_Record); - package Scenario_Pointers is new GNATCOLL.Refcount.Smart_Pointers - (Scenario_Record); + package Scenario_Pointers is new GNATCOLL.Refcount.Shared_Pointers + (Scenario_Record, Free); type Scenario is new Scenario_Pointers.Ref with null record; No_Scenario : constant Scenario := diff --git a/src/bdd/bdd-formatters.adb b/src/bdd/bdd-formatters.adb index 22984df..ca4f46a 100644 --- a/src/bdd/bdd-formatters.adb +++ b/src/bdd/bdd-formatters.adb @@ -58,7 +58,7 @@ package body BDD.Formatters is Output : not null access Media_Writer'Class) is begin - Self.Output := Output; + Self.Output := Media_Writer_Access (Output); end Init; ------------------- diff --git a/src/bdd/bdd-formatters.ads b/src/bdd/bdd-formatters.ads index a6700e7..4c156ad 100644 --- a/src/bdd/bdd-formatters.ads +++ b/src/bdd/bdd-formatters.ads @@ -32,6 +32,7 @@ with BDD.Media; use BDD.Media; package BDD.Formatters is type Formatter is abstract tagged private; + type Formatter_Access is access all Formatter'Class; procedure Init (Self : in out Formatter; @@ -153,7 +154,7 @@ private type Formatter is abstract tagged record Last_Displayed_Feature_Id : Integer := -1; - Output : access Media_Writer'Class; + Output : Media_Writer_Access; end record; type Formatter_Full is new Formatter with null record; diff --git a/src/bdd/bdd-main.adb b/src/bdd/bdd-main.adb index e5c3b6a..b649f77 100644 --- a/src/bdd/bdd-main.adb +++ b/src/bdd/bdd-main.adb @@ -37,7 +37,7 @@ package body BDD.Main is procedure Main (Self : in out BDD.Runner.Feature_Runner'Class) is Parser : BDD.Parser.Feature_Parser; - Format : access BDD.Formatters.Formatter'Class; + Format : BDD.Formatters.Formatter_Access; Media : Media_Writer_Access; begin GNATCOLL.Traces.Parse_Config_File; diff --git a/src/bdd/bdd-media.adb b/src/bdd/bdd-media.adb index 86b53af..1c279f6 100644 --- a/src/bdd/bdd-media.adb +++ b/src/bdd/bdd-media.adb @@ -32,6 +32,7 @@ package body BDD.Media is Term : GNATCOLL.Terminal.Terminal_Info_Access; File : File_Type_Access; end record; + type File_Writer_Access is access File_Writer; overriding procedure Write (Self : not null access File_Writer; Text : String); @@ -50,6 +51,7 @@ package body BDD.Media is Base : not null access Media_Writer'Class; Current_Color : ANSI_Color := Black; end record; + type HTML_Writer_Access is access HTML_Writer; overriding procedure Write (Self : not null access HTML_Writer; Text : String); @@ -109,7 +111,7 @@ package body BDD.Media is ----------------- function Open_Stdout return Media_Writer_Access is - Result : constant not null access File_Writer := new File_Writer; + Result : constant not null File_Writer_Access := new File_Writer; begin Result.Term := new Terminal_Info; Result.Term.Init_For_Stdout (Colors => BDD.Colors); @@ -127,7 +129,7 @@ package body BDD.Media is function Open_File (File : GNATCOLL.VFS.Virtual_File) return Media_Writer_Access is - Result : constant not null access File_Writer := new File_Writer; + Result : constant not null File_Writer_Access := new File_Writer; begin Result.File := new File_Type; Create (Result.File.all, Out_File, File.Display_Full_Name); @@ -149,7 +151,7 @@ package body BDD.Media is (Base : not null access Media_Writer'Class) return Media_Writer_Access is - Result : constant not null access HTML_Writer := + Result : constant not null HTML_Writer_Access := new HTML_Writer'(Stdout_Term => Base.Stdout_Term, Progress_Displayed => False, Base => Base, diff --git a/src/bdd/bdd-runner.adb b/src/bdd/bdd-runner.adb index 48c6ca3..7dd0e2a 100644 --- a/src/bdd/bdd-runner.adb +++ b/src/bdd/bdd-runner.adb @@ -79,7 +79,7 @@ package body BDD.Runner is begin if Self.Files /= null then Feature_Runner'Class (Self).Run_Start; - Self.Format := Format; + Self.Format := BDD.Formatters.Formatter_Access (Format); Sort (Self.Files.all); for F in Self.Files'Range loop Parser.Parse (Self.Files (F), Self); diff --git a/src/bdd/bdd-runner.ads b/src/bdd/bdd-runner.ads index cccf217..a61f5ce 100644 --- a/src/bdd/bdd-runner.ads +++ b/src/bdd/bdd-runner.ads @@ -84,7 +84,7 @@ package BDD.Runner is private type Feature_Runner is new BDD.Parser.Abstract_Feature_Runner with record Files : GNATCOLL.VFS.File_Array_Access; - Format : access BDD.Formatters.Formatter'Class; + Format : BDD.Formatters.Formatter_Access; Steps_Stats : Count_Array := (others => 0); Scenario_Stats : Count_Array := (others => 0); diff --git a/src/bdd/bdd-tables.adb b/src/bdd/bdd-tables.adb index 0278934..6c4bd99 100644 --- a/src/bdd/bdd-tables.adb +++ b/src/bdd/bdd-tables.adb @@ -33,7 +33,7 @@ package body BDD.Tables is function Create return Table is Self : Table; - R : constant access Table_Record := new Table_Record; + R : Table_Record; begin Self.Set (R); return Self; @@ -76,7 +76,7 @@ package body BDD.Tables is Column : Positive; Name : String) is - R : constant not null access Table_Record := Self.Get; + R : Table_Pointers.Reference_Type := Self.Get; begin R.Names.Reserve_Capacity (Ada.Containers.Count_Type (Integer'Max (Column, Self.Width))); @@ -96,7 +96,7 @@ package body BDD.Tables is (Self : Table; Column : Positive) return String is - R : constant not null access Table_Record := Self.Get; + R : Table_Pointers.Reference_Type := Self.Get; begin if R.Names.Is_Empty or else Integer (R.Names.Length) < Column @@ -123,7 +123,7 @@ package body BDD.Tables is R.Insert (Column, Value); end Do_Update; - SR : constant not null access Table_Record := Self.Get; + SR : Table_Pointers.Reference_Type := Self.Get; begin if Row > Integer (SR.Rows.Length) then declare @@ -215,7 +215,7 @@ package body BDD.Tables is Output : not null access BDD.Media.Media_Writer'Class; Prefix : String := "") is - R : constant access Table_Record := Self.Get; + R : Table_Pointers.Reference_Type := Self.Get; W : constant Integer := Self.Width; Widths : array (1 .. W) of Natural := (others => 0); diff --git a/src/bdd/bdd-tables.ads b/src/bdd/bdd-tables.ads index 27aa37b..7413a85 100644 --- a/src/bdd/bdd-tables.ads +++ b/src/bdd/bdd-tables.ads @@ -98,13 +98,13 @@ private package Row_Vectors is new Ada.Containers.Vectors (Positive, String_Vectors.Vector, String_Vectors."="); - type Table_Record is new GNATCOLL.Refcount.Refcounted with record + type Table_Record is tagged record Names : String_Vectors.Vector; Width : Natural := 0; Rows : Row_Vectors.Vector; -- does not include column titles end record; - package Table_Pointers is new GNATCOLL.Refcount.Smart_Pointers + package Table_Pointers is new GNATCOLL.Refcount.Shared_Pointers (Table_Record); type Table is new Table_Pointers.Ref with null record;