ada-libraries
/
gnatbdd
mirror of https://github.com/briot/gnatbdd
1
0
Fork 0
Code Issues Releases Wiki Activity

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.
This commit is contained in:
Emmanuel Briot 2021-04-15 08:51:33 +02:00
parent 0c65f972b9
commit 936b2e0327
13 changed files with 54 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/bdd/bdd-asserts.adb
View File

@ -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 := "")

16
src/bdd/bdd-asserts_generic.adb
View File

@ -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));

16
src/bdd/bdd-asserts_generic.ads
View File

@ -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);

18
src/bdd/bdd-features.adb
View File

@ -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;

16
src/bdd/bdd-features.ads
View File

@ -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 :=

2
src/bdd/bdd-formatters.adb
View File

@ -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;
-------------------

3
src/bdd/bdd-formatters.ads
View File

@ -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;

2
src/bdd/bdd-main.adb
View File

@ -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;

8
src/bdd/bdd-media.adb
View File

@ -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,

2
src/bdd/bdd-runner.adb
View File

@ -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);

2
src/bdd/bdd-runner.ads
View File

@ -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);

10
src/bdd/bdd-tables.adb
View File

@ -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);

4
src/bdd/bdd-tables.ads
View File

@ -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;