------------------------------------------------------------------------------
-- --
-- Libadalang Tools --
-- --
-- Copyright (C) 2011-2021, AdaCore --
-- --
-- Libadalang Tools is free software; you can redistribute it and/or modi- --
-- fy it under terms of the GNU General Public License as published by --
-- the Free Software Foundation; either version 3, or (at your option) any --
-- later version. This software is distributed in the hope that it will be --
-- useful but WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are --
-- granted additional permissions described in the GCC Runtime Library --
-- Exception, version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and a --
-- copy of the GCC Runtime Library Exception along with this program; see --
-- the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
------------------------------------------------------------------------------
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Containers.Indefinite_Doubly_Linked_Lists;
with Ada.Containers.Indefinite_Ordered_Maps;
with Ada.Containers.Indefinite_Vectors;
with Ada.Containers.Indefinite_Ordered_Sets;
with Ada.Containers.Vectors;
with Ada.Containers.Indefinite_Hashed_Sets;
with Ada.Containers.Indefinite_Hashed_Maps;
with Libadalang.Common; use Libadalang.Common;
with Langkit_Support.Errors;
with Langkit_Support.Text; use Langkit_Support.Text;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Exceptions;
with Ada.Strings; use Ada.Strings;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with GNATCOLL.Traces; use GNATCOLL.Traces;
with GNATCOLL.VFS; use GNATCOLL.VFS;
with Langkit_Support.Slocs; use Langkit_Support.Slocs;
with GNAT.OS_Lib;
with GNAT.SHA1;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Traceback.Symbolic;
with Test.Common; use Test.Common;
with Test.Harness;
with Test.Skeleton.Source_Table; use Test.Skeleton.Source_Table;
with Test.Mapping; use Test.Mapping;
with Test.Stub;
with Utils.Command_Lines; use Utils.Command_Lines;
package body Test.Skeleton is
Me : constant Trace_Handle :=
Create ("Skeletons", Default => Off);
Me_Direct_Callees : constant Trace_Handle :=
Create ("Skeletons.Direct_Callees", Default => Off);
-------------------
-- Minded Data --
-------------------
New_Tests_Counter : Natural := 0;
All_Tests_Counter : Natural := 0;
package Tests_Per_Unit is new
Ada.Containers.Indefinite_Ordered_Maps (String, Natural);
use Tests_Per_Unit;
Test_Info : Tests_Per_Unit.Map;
type Data_Kind_Type is
(Declaration_Data,
Instantiation);
type Base_Type_Info is tagged record
Main_Type_Elem : Ada_Node := No_Ada_Node;
Main_Type_Abstract : Boolean;
Main_Type_Text_Name : String_Access;
Has_Argument_Father : Boolean;
Argument_Father_Unit_Name : String_Access;
Argument_Father_Type_Name : String_Access;
Argument_Father_Nesting : String_Access;
Nesting : String_Access;
Type_Number : Positive;
No_Default_Discriminant : Boolean;
end record;
package Type_Info_Vect is new
Ada.Containers.Indefinite_Vectors (Positive, Base_Type_Info);
use Type_Info_Vect;
use String_Set;
type Test_Case_Mode is (Normal, Robustness);
type Test_Case_Info is record
Pre : Expr;
Post : Expr;
Elem : Ada_Node;
Name : String_Access;
Mode : Test_Case_Mode;
Req : Expr;
Ens : Expr;
Req_Image : String_Access;
Ens_Image : String_Access;
Params_To_Temp : String_Set.Set;
Req_Line : String_Access;
Ens_Line : String_Access;
TC_Hash : String_Access;
end record;
type Subp_Info is record
Subp_Declaration : Ada_Node;
Subp_Text_Name : String_Access;
Subp_Name_Image : String_Access;
Subp_Mangle_Name : String_Access;
Subp_Full_Hash : String_Access;
-- Those versions of hash are stored for compatibility reasons.
-- Transitions from older versions of hash should be performed
-- automatically.
Subp_Hash_V1 : String_Access;
-- Case-sensitive hash.
Subp_Hash_V2_1 : String_Access;
-- Non-controlling parameters with same root type as controlling ones
-- are replaced with root type before hashing.
Corresp_Type : Natural;
Nesting : String_Access;
Has_TC_Info : Boolean := False;
TC_Info : Test_Case_Info;
Is_Overloaded : Boolean;
end record;
package Subp_Data_List is new
Ada.Containers.Indefinite_Doubly_Linked_Lists (Subp_Info);
use Subp_Data_List;
type Package_Info is record
Name : String_Access;
Is_Generic : Boolean;
Data_Kind : Data_Kind_Type;
Element : Ada_Node;
-- only used for instantiations
Generic_Containing_Package : String_Access;
end record;
package Package_Info_List is new
Ada.Containers.Doubly_Linked_Lists (Package_Info);
use Package_Info_List;
-- Info on overloading subprograms
package Name_Frequency is new
Ada.Containers.Indefinite_Ordered_Maps (String, Natural);
use Name_Frequency;
type Data_Holder (Data_Kind : Data_Kind_Type := Declaration_Data) is record
Unit : Compilation_Unit;
-- CU itself.
Unit_Full_Name : String_Access;
-- Fully expanded Ada name of the CU
Unit_File_Name : String_Access;
-- Full name of the file, containing the CU
case Data_Kind is
-- Indicates which data storing structures are used, determines the
-- way of suite generation.
when Declaration_Data =>
Is_Generic : Boolean;
-- Indicates if given argument package declaration is generic.
Has_Simple_Case : Boolean := False;
-- Indicates if we have routines that are not primitives of any
-- tagged type.
Needs_Set_Up : Boolean := False;
-- Indicates if we need the Set_Up routine for at least one test
-- type;
Needs_Assertions : Boolean := False;
-- Indicates if we need to include AUnit.Assertions into the body
-- of the test package.
Subp_List : Subp_Data_List.List;
-- List of subprograms declared in the argument package
-- declaration.
Type_Data_List : Type_Info_Vect.Vector;
-- Stores info on tagged records in the argument package
-- declaration.
Package_Data_List : Package_Info_List.List;
-- Stores info of nested packages
Units_To_Stub : Ada_Nodes_List.List;
-- List of direct dependancies of current unit
Subp_Name_Frequency : Name_Frequency.Map;
when Instantiation =>
Gen_Unit_Full_Name : String_Access;
-- Fully expanded Ada name of the generic CU
Gen_Unit_File_Name : String_Access;
-- Name of file containing the generic CU
end case;
end record;
----------------
-- Suite Data --
----------------
type Test_Type_Info_Wrapper is record
TT_Info : Test.Harness.Test_Type_Info;
Test_Package : String_Access;
Original_Type : Ada_Node := No_Ada_Node;
end record;
package TT_Info is new
Ada.Containers.Indefinite_Vectors (Positive, Test_Type_Info_Wrapper);
use TT_Info;
type Test_Routine_Info_Wrapper is record
TR_Info : Test.Harness.Test_Routine_Info;
Test_Package : String_Access;
Original_Type : Ada_Node := No_Ada_Node;
Original_Subp : Ada_Node := No_Ada_Node;
From_Generic : Boolean := False;
end record;
package TR_Info is new
Ada.Containers.Indefinite_Vectors (Positive, Test_Routine_Info_Wrapper);
use TR_Info;
type Test_Routine_Info_Enhanced_Wrapper is record
TR_Info : Test.Harness.Test_Routine_Info_Enhanced;
Test_Package : String_Access;
Original_Type : Ada_Node := No_Ada_Node;
end record;
package TR_Info_Enhanced is new
Ada.Containers.Indefinite_Vectors (Positive,
Test_Routine_Info_Enhanced_Wrapper);
use TR_Info_Enhanced;
type Suites_Data_Type is record
Test_Types : TT_Info.Vector;
TR_List : TR_Info.Vector;
ITR_List : TR_Info_Enhanced.Vector;
LTR_List : TR_Info_Enhanced.Vector;
end record;
------------------
-- Test Mapping --
------------------
use TC_Mapping_List;
use TR_Mapping_List;
use DT_Mapping_List;
use TP_Mapping_List;
procedure Add_TR
(TP_List : in out TP_Mapping_List.List;
TPtarg : String;
Test_F : String;
Test_T : String;
Subp : Subp_Info;
TR_Line : Natural := 1);
procedure Add_DT
(TP_List : in out TP_Mapping_List.List;
TPtarg : String;
Test_F : String;
Line : Natural;
Column : Natural);
--------------
-- Generics --
--------------
type Generic_Tests is record
Gen_Unit_Full_Name : String_Access;
Tested_Type_Names : List_Of_Strings.List;
Has_Simple_Case : Boolean := False;
end record;
-- Stores info necessary to calculate names of test packages that
-- correspond to the generic UUT: names of tagged types and
-- absence/presense of simple case.
package Generic_Tests_Storage is new
Ada.Containers.Indefinite_Doubly_Linked_Lists (Generic_Tests);
Gen_Tests_Storage : Generic_Tests_Storage.List;
-- List of data on all the generic tests created during the processing of
-- generic UUTs.
type Generic_Package is record
Name : String_Access;
Sloc : String_Access := null;
Has_Instantiation : Boolean := False;
end record;
package Generic_Package_Storage is new
Ada.Containers.Indefinite_Doubly_Linked_Lists (Generic_Package);
Gen_Package_Storage : Generic_Package_Storage.List;
-- Used to detect processed generic packages that do not have
-- instantiations in the scope of argument sources and, therefore, won't be
-- included into final harness.
procedure Update_Generic_Packages (Instantiation : String);
-- Updates Gen_Package_Storage with a name of processed instantiation
procedure Update_Generic_Packages (Gen_Pack : Generic_Package);
-- Updates Gen_Package_Storage with a new generic package info
-----------------------
-- Marker Processing --
-----------------------
package String_Vectors is new
Ada.Containers.Indefinite_Vectors (Natural, String);
type Markered_Data is record
Commented_Out : Boolean := False;
Short_Name_Used : Boolean := False;
Short_Name : String_Access := new String'("");
TR_Text : String_Vectors.Vector;
Issue_Warning : Boolean := False;
end record;
type Unique_Hash is record
Version : String_Access;
Hash : String_Access;
TC_Hash : String_Access;
end record;
function "<" (L, R : Unique_Hash) return Boolean;
package Markered_Data_Maps is new
Ada.Containers.Indefinite_Ordered_Maps (Unique_Hash, Markered_Data);
use Markered_Data_Maps;
Markered_Data_Map : Markered_Data_Maps.Map;
procedure Gather_Data
(The_Unit : Compilation_Unit;
Data : out Data_Holder;
Suite_Data_List : out Suites_Data_Type;
Apropriate_Source : out Boolean);
-- Iterates through the given unit and gathers all the data needed for
-- generation of test package. All the iterations are done here.
-- Checks if given unit is of the right kind and if it is appropriate.
-- Marks unappropriate sources in the source table.
procedure Gather_Test_Cases
(Subp : Subp_Info;
TR_Info : Test_Routine_Info_Wrapper;
Data : in out Data_Holder;
Suite_Data_List : in out Suites_Data_Type;
TC_Found : out Boolean;
Instance_Sloc : String := "");
-- Adds one subprogram-to-test per each test case.
-- Sets TC_Found if at least one Test_Case aspect or pragma has been found
-- for given subprogram.
procedure Generate_Nested_Hierarchy (Data : Data_Holder);
-- Creates dummy child packages copying nested packages from tested package
procedure Generate_Test_Package (Data : Data_Holder);
-- Generates test package spec and body
procedure Generate_Procedure_Wrapper (Current_Subp : Subp_Info);
-- Prints a test-case specific wrapper for tested procedure
procedure Generate_Function_Wrapper (Current_Subp : Subp_Info);
-- Prints a test-case specific wrapper for tested function
procedure Print_Comment_Declaration (Subp : Subp_Info; Span : Natural := 0);
-- Prints the file containing the tested subprogram as well as the line
-- coloumn numbers of the tested subprogram declaration.
procedure Get_Subprograms_From_Package (File : String);
procedure Get_Subprogram_From_Separate
(File : String;
UH : Unique_Hash;
Subp : Subp_Info);
procedure Put_Opening_Comment_Section
(Subp : Subp_Info;
Overloading_N : Natural;
Commented_Out : Boolean := False;
Use_Short_Name : Boolean := True;
Type_Name : String := "");
procedure Put_Closing_Comment_Section
(Subp : Subp_Info;
Overloading_N : Natural;
Commented_Out : Boolean := False;
Use_Short_Name : Boolean := True);
function Sanitize_TC_Name (TC_Name : String) return String;
-- Processes the name of the test case in such a way that it could be used
-- as a part of test routine name. the name is trimmed, then all sequences
-- of whitespace characters are replaced with an underscore, all other
-- illegal characters are omitted.
procedure Put_Wrapper_Rename (Span : Natural; Current_Subp : Subp_Info);
-- Puts subprogram renaming declaration, which renames generated wrapper
-- into original tested subprogram's name.
function Find_Same_Short_Name
(MD_Map : Markered_Data_Maps.Map;
Subp : Subp_Info) return Markered_Data_Maps.Cursor;
-- Searches for the test with given short name
function Uncomment_Line (S : String) return String;
-- Removes two dashes and two spaces from the beginning of the line.
-- Returns argument string if commenting prefix not found.
function Format_Time (Time : GNAT.OS_Lib.OS_Time) return String;
-- Returns image of given time in 1901-01-01 00:00:00 format.
procedure Get_Units_To_Stub
(The_Unit : Compilation_Unit;
Data : in out Data_Holder);
-- Populates the list of units that should be stubbed.
procedure Process_Stubs (List : Ada_Nodes_List.List);
function Is_Declared_In_Regular_Package
(Elem : Ada_Node'Class) return Boolean;
-- Checks that all enclosing elements for the given element are regular
-- package declarations.
function Get_Direct_Callees_Setters
(Subp : Basic_Decl) return String_Set.Set;
-- Returns the list of possible setters for all subprograms called from
-- the body of given subprogram.
---------
-- "<" --
---------
function "<" (L, R : Unique_Hash) return Boolean is
begin
if L.Version.all = R.Version.all then
if L.Hash.all = R.Hash.all then
return L.TC_Hash.all < R.TC_Hash.all;
else
return L.Hash.all < R.Hash.all;
end if;
else
return L.Version.all < R.Version.all;
end if;
end "<";
--------------------
-- Process_Source --
--------------------
procedure Process_Source (The_Unit : Analysis_Unit) is
Data : Data_Holder;
Suite_Data_List : Suites_Data_Type;
Suite_Data : Test.Harness.Data_Holder;
Apropriate_Source : Boolean;
CU : Compilation_Unit;
Test_Packages : String_Set.Set;
Cur : String_Set.Cursor;
procedure Get_Test_Packages_List (S_Data : Suites_Data_Type);
-- Fills suite data sorting out routines from generic packages
function Get_Suite_Components
(S_Data : Suites_Data_Type;
Package_Name : String)
return Test.Harness.Data_Holder;
procedure Cleanup;
-- Frees Data components
procedure Report (Ex : Ada.Exceptions.Exception_Occurrence);
-- Reports problematic source with exception information
procedure Cleanup is
begin
if Data.Data_Kind = Declaration_Data then
Clear (Data.Type_Data_List);
Clear (Data.Subp_List);
Clear (Data.Package_Data_List);
Clear (Data.Subp_Name_Frequency);
end if;
Suite_Data.Test_Types.Clear;
Suite_Data.TR_List.Clear;
Suite_Data.ITR_List.Clear;
Suite_Data.LTR_List.Clear;
end Cleanup;
----------------------------
-- Get_Test_Packages_List --
----------------------------
procedure Get_Test_Packages_List (S_Data : Suites_Data_Type) is
begin
for K in S_Data.TR_List.First_Index .. S_Data.TR_List.Last_Index loop
if not S_Data.TR_List.Element (K).From_Generic then
Test_Packages.Include
(S_Data.TR_List.Element (K).Test_Package.all);
end if;
end loop;
for
K in S_Data.ITR_List.First_Index .. S_Data.ITR_List.Last_Index
loop
Test_Packages.Include
(S_Data.ITR_List.Element (K).Test_Package.all);
end loop;
end Get_Test_Packages_List;
function Get_Suite_Components
(S_Data : Suites_Data_Type;
Package_Name : String)
return Test.Harness.Data_Holder
is
Suite_Data : Test.Harness.Data_Holder;
Test_Routine : Test.Harness.Test_Routine_Info;
TT : Test.Harness.Test_Type_Info;
TR_E : Test.Harness.Test_Routine_Info_Enhanced;
package Test_Type_Origins is new
Ada.Containers.Vectors (Positive, Ada_Node);
use Test_Type_Origins;
TT_Origins : Test_Type_Origins.Vector;
-- Used to set test type numbers.
Original_Type : Ada_Node;
Type_Found : Boolean;
begin
Suite_Data.Test_Unit_Full_Name := new String'(Package_Name);
for
K in S_Data.Test_Types.First_Index .. S_Data.Test_Types.Last_Index
loop
if
S_Data.Test_Types.Element (K).Test_Package.all = Package_Name
then
TT := S_Data.Test_Types.Element (K).TT_Info;
TT.Tested_Type := S_Data.Test_Types.Element (K).Original_Type;
Suite_Data.Test_Types.Append (TT);
TT_Origins.Append (S_Data.Test_Types.Element (K).Original_Type);
end if;
end loop;
for K in S_Data.TR_List.First_Index .. S_Data.TR_List.Last_Index loop
if S_Data.TR_List.Element (K).Test_Package.all = Package_Name then
Test_Routine := S_Data.TR_List.Element (K).TR_Info;
-- Setting test type number;
Original_Type := S_Data.TR_List.Element (K).Original_Type;
Type_Found := False;
for L in TT_Origins.First_Index .. TT_Origins.Last_Index loop
if TT_Origins.Element (L) = Original_Type then
Test_Routine.Test_Type_Numb := L;
Type_Found := True;
exit;
end if;
end loop;
if Type_Found then
Suite_Data.TR_List.Append (Test_Routine);
Suite_Data.Good_For_Suite := True;
end if;
end if;
end loop;
for
K in S_Data.ITR_List.First_Index .. S_Data.ITR_List.Last_Index
loop
if S_Data.ITR_List.Element (K).Test_Package.all = Package_Name then
TR_E := S_Data.ITR_List.Element (K).TR_Info;
-- Setting up test type number
Original_Type := S_Data.ITR_List.Element (K).Original_Type;
Type_Found := False;
for L in TT_Origins.First_Index .. TT_Origins.Last_Index loop
if TT_Origins.Element (L) = Original_Type then
TR_E.Test_Type_Numb := L;
Type_Found := True;
exit;
end if;
end loop;
if Type_Found then
Suite_Data.ITR_List.Append (TR_E);
Suite_Data.Good_For_Suite := True;
end if;
end if;
end loop;
for
K in S_Data.LTR_List.First_Index .. S_Data.LTR_List.Last_Index
loop
if S_Data.LTR_List.Element (K).Test_Package.all = Package_Name then
TR_E := S_Data.LTR_List.Element (K).TR_Info;
-- Setting up test type number
Original_Type := S_Data.LTR_List.Element (K).Original_Type;
Type_Found := False;
for L in TT_Origins.First_Index .. TT_Origins.Last_Index loop
if TT_Origins.Element (L) = Original_Type then
TR_E.Test_Type_Numb := L;
Type_Found := True;
exit;
end if;
end loop;
if Type_Found then
TR_E.Tested_Type := Original_Type;
Suite_Data.LTR_List.Append (TR_E);
Suite_Data.Good_For_Substitution := True;
end if;
end if;
end loop;
TT_Origins.Clear;
return Suite_Data;
end Get_Suite_Components;
------------
-- Report --
------------
procedure Report (Ex : Ada.Exceptions.Exception_Occurrence) is
begin
if Strict_Execution then
Report_Err
(Ada.Exceptions.Exception_Name (Ex)
& " : "
& Ada.Exceptions.Exception_Message (Ex)
& ASCII.LF
& GNAT.Traceback.Symbolic.Symbolic_Traceback (Ex));
end if;
end Report;
begin
if The_Unit.Root.Kind /= Ada_Compilation_Unit then
-- For example, it can be a Pragma_Node_List for a body source
-- containing pragma No_Body.
return;
end if;
CU := Root (The_Unit).As_Compilation_Unit;
if P_Unit_Kind (CU) = Unit_Body then
-- Only interested in specs
return;
end if;
Gather_Data
(CU, Data, Suite_Data_List, Apropriate_Source);
if Apropriate_Source then
-- First, create stubs if needed. This will allow to import stub_data
-- packages into test packages only for actually stubbed
-- dependencies.
if Stub_Mode_ON then
Process_Stubs (Data.Units_To_Stub);
end if;
declare
F : File_Array_Access;
begin
Append
(F,
GNATCOLL.VFS.Create
(+(Get_Source_Output_Dir (CU.Unit.Get_Filename))));
Create_Dirs (F);
end;
if Data.Data_Kind = Declaration_Data then
Generate_Nested_Hierarchy (Data);
Generate_Test_Package (Data);
Get_Test_Packages_List (Suite_Data_List);
Cur := Test_Packages.First;
loop
exit when Cur = String_Set.No_Element;
Suite_Data := Get_Suite_Components
(Suite_Data_List,
String_Set.Element (Cur));
if Suite_Data.Good_For_Suite then
if not Stub_Mode_ON and then not Separate_Drivers then
Test.Harness.Generate_Suite (Suite_Data);
if Substitution_Suite
and then Suite_Data.Good_For_Substitution
then
Test.Harness.Generate_Substitution_Suite_From_Tested
(Suite_Data);
end if;
end if;
end if;
String_Set.Next (Cur);
end loop;
if Stub_Mode_ON or else Separate_Drivers then
Cur := Test_Packages.First;
while Cur /= String_Set.No_Element loop
Suite_Data := Get_Suite_Components
(Suite_Data_List,
String_Set.Element (Cur));
if Suite_Data.Good_For_Suite then
Test.Harness.Generate_Test_Drivers
(Suite_Data,
Data.Unit_File_Name.all,
Data.Units_To_Stub);
end if;
if Suite_Data.Good_For_Substitution
and then not Driver_Per_Unit
then
Test.Harness.Generate_Substitution_Test_Drivers
(Suite_Data);
end if;
String_Set.Next (Cur);
end loop;
end if;
end if;
end if;
Cleanup;
exception
when Ex : Langkit_Support.Errors.Property_Error =>
Source_Processing_Failed := True;
Report_Err ("lal error while creating test package for "
& Base_Name (The_Unit.Get_Filename));
Report_Err ("source file may be incomplete/invalid");
Report (Ex);
Cleanup;
when Ex : others =>
Source_Processing_Failed := True;
Report_Err ("unexpected error while creating test package for "
& Base_Name (The_Unit.Get_Filename));
Report (Ex);
Cleanup;
end Process_Source;
-----------------
-- Gather_Data --
-----------------
procedure Gather_Data
(The_Unit : Compilation_Unit;
Data : out Data_Holder;
Suite_Data_List : out Suites_Data_Type;
Apropriate_Source : out Boolean)
is
Bod : constant Library_Item := The_Unit.F_Body.As_Library_Item;
Unit : Ada_Node;
Type_Counter : Positive := 1;
Dummy_Type_Counter : Natural := 0;
function Get_Nested_Packages (Node : Ada_Node'Class) return Visit_Status;
function Get_Records (Node : Ada_Node'Class) return Visit_Status;
function Get_Subprograms (Node : Ada_Node'Class) return Visit_Status;
Inside_Inst : Boolean := False;
-- Indicates that we are parsing the generic package in place of its
-- instantiation to populate Data for suite creation. In that mode
-- the nestings gathered by Get_Records and Get_Subprograms must be
-- replaced with the real nesting of instantiation.
Instance_Nesting : String_Access;
-- Stores the nesting of instantiation and its name
Instance_Sloc : String_Access;
-- Stores sloc of instance that is used for test routine output
procedure Gather_Inherited_Subprograms
(Dummy_Types : Natural;
Suite_Data_List : in out Suites_Data_Type);
-- Populates the list of inherited subprograms. Dummy_Types indicates
-- the number of Test types created for non-primitives.
procedure Gather_Substitution_Data
(Suite_Data_List : in out Suites_Data_Type);
-- Populates the list of overridden subprograms
function Is_Callable_Subprogram (Subp : Basic_Decl) return Boolean is
(Subp.Kind not in Ada_Abstract_Subp_Decl | Ada_Null_Subp_Decl);
-- Checks that given subprogram is neither an abstract subprogram
-- nor a null procedure. This ensures that corresponding test routine
-- is created for such subprogram.
function Is_Fully_Private
(Arg : Base_Type_Decl) return Boolean;
-- Detects if Arg and its incomplete declaration (if present)
-- are both in private part.
function Is_Ghost_Code (Decl : Basic_Decl) return Boolean is
(Decl.P_Has_Aspect (To_Unbounded_Text (To_Text ("ghost"))));
-- Detects if given declaration has aspect Ghost
procedure Check_Type_For_Elaboration (Type_Dec : Base_Type_Decl);
-- Checking if is any of parent types have pragma
-- Preelaborable_Initialization. This might cause
-- elaboration conflicts in the harness, so a warning
-- should be isued.
function Check_Type_For_Unset_Discriminants
(Type_Dec : Base_Type_Decl) return Boolean;
-- Returns True if given type or any of its ancestors have
-- a discriminant without a default value.
function Test_Types_Linked
(Inheritance_Root_Type : Base_Type_Decl;
Inheritance_Final_Type : Base_Type_Decl)
return Boolean;
-- Checks that there is no fully private types between the root type
-- and the final descendant, so that corresponding test types are
-- members of same hierarchy.
function No_Inheritance_Through_Generics
(Inheritance_Root_Type : Base_Type_Decl;
Inheritance_Final_Type : Base_Type_Decl)
return Boolean;
-- Checks that all types between the root type and the final descendant
-- are declared in regular packages.
function Is_Node_From_Generic (Node : Ada_Node'Class) return Boolean;
-- Checks that there are no enclosing generic package declarations for
-- Node, but takes into account the value of Inside_Inst, so that nodes
-- from instantiations could be distinguished from same nodes from
-- corresponding generics.
-------------------------
-- Get_Nested_Packages --
--------------------------
function Get_Nested_Packages (Node : Ada_Node'Class) return Visit_Status
is
Package_Data : Package_Info;
begin
if Node.Kind in Ada_Basic_Decl
and then Is_Ghost_Code (Node.As_Basic_Decl)
then
return Over;
end if;
if Is_Private (Node) then
return Over;
end if;
if Node.Kind = Ada_Generic_Formal_Part then
return Over;
end if;
case Kind (Node) is
when Ada_Package_Decl =>
if Get_Nesting (Node) = "" then
Package_Data.Name := new String'
(Node_Image (Node.As_Basic_Decl.P_Defining_Name));
else
Package_Data.Name := new String'
(Get_Nesting (Node) & "."
& Node_Image (Node.As_Basic_Decl.P_Defining_Name));
end if;
Package_Data.Is_Generic := False;
Package_Data.Data_Kind := Declaration_Data;
Package_Data.Element := Node.As_Ada_Node;
Data.Package_Data_List.Append (Package_Data);
when Ada_Generic_Package_Decl =>
if Stub_Mode_ON then
return Over;
end if;
-- Only library level generics are processed
if Node.Parent.Kind = Ada_Library_Item then
if Get_Nesting (Node) = "" then
Package_Data.Name := new String'
(Node_Image (Node.As_Basic_Decl.P_Defining_Name));
else
Package_Data.Name := new String'
(Get_Nesting (Node) & "."
& Node_Image (Node.As_Basic_Decl.P_Defining_Name));
end if;
Package_Data.Is_Generic := True;
Package_Data.Data_Kind := Declaration_Data;
Package_Data.Element := Node.As_Ada_Node;
Data.Package_Data_List.Append (Package_Data);
end if;
when Ada_Generic_Package_Instantiation =>
if Stub_Mode_ON or else Is_Node_From_Generic (Node) then
return Over;
end if;
declare
Gen_Name : constant Libadalang.Analysis.Name :=
Node.As_Generic_Package_Instantiation.F_Generic_Pkg_Name;
Gen_Decl : Basic_Decl :=
Gen_Name.P_Relative_Name.As_Name.P_Referenced_Decl;
begin
if Gen_Decl.Is_Null then
return Over;
end if;
Gen_Decl := Gen_Decl.P_Get_Uninstantiated_Node.As_Basic_Decl;
-- No processing for instantiations of nested generics,
-- also if corresponding generic is not processed (or going
-- to be) there is no corresponding generic test package.
if not Source_Present (Gen_Decl.Unit.Get_Filename)
or else Gen_Decl.Parent.Kind /= Ada_Library_Item
then
return Over;
end if;
Package_Data.Name := new String'
(Get_Nesting (Node)
& "."
& Node_Image (Node.As_Basic_Decl.P_Defining_Name));
Package_Data.Data_Kind := Instantiation;
Package_Data.Is_Generic := False;
Package_Data.Generic_Containing_Package := new String'
(Node_Image (Gen_Decl.P_Defining_Name));
Package_Data.Element := Node.As_Ada_Node;
Data.Package_Data_List.Append (Package_Data);
return Over;
end;
when others =>
null;
end case;
return Into;
end Get_Nested_Packages;
-----------------
-- Get_Records --
-----------------
function Get_Records (Node : Ada_Node'Class) return Visit_Status is
Cur_Node : Ada_Node;
Type_Data : Base_Type_Info;
Test_Type : Test.Harness.Test_Type_Info;
Test_Package : String_Access;
procedure Get_Type_Parent_Data (Type_Data : in out Base_Type_Info);
-- Gathers data on parent type
--------------------------
-- Get_Type_Parent_Data --
--------------------------
procedure Get_Type_Parent_Data (Type_Data : in out Base_Type_Info) is
Parent_Type : Base_Type_Decl;
procedure Set_No_Parent (Type_Data : in out Base_Type_Info);
-- Sets all data relevant to parent type to null/false
-------------------
-- Set_No_Parent --
-------------------
procedure Set_No_Parent (Type_Data : in out Base_Type_Info) is
begin
Type_Data.Argument_Father_Type_Name := null;
Type_Data.Argument_Father_Nesting := null;
Type_Data.Argument_Father_Unit_Name := null;
Type_Data.Has_Argument_Father := False;
end Set_No_Parent;
begin
if Stub_Mode_ON then
Set_No_Parent (Type_Data);
return;
end if;
if Data.Is_Generic or else Inside_Inst then
Set_No_Parent (Type_Data);
return;
end if;
Parent_Type :=
Parent_Type_Declaration (Cur_Node.As_Base_Type_Decl);
if Parent_Type.Is_Null then
Set_No_Parent (Type_Data);
return;
end if;
if
not Is_Declared_In_Regular_Package (Parent_Type.As_Ada_Node)
or else Parent_Type.As_Type_Decl.P_Is_Interface_Type
or else Is_Fully_Private (Parent_Type)
then
Set_No_Parent (Type_Data);
return;
end if;
if not Source_Present (Parent_Type.Unit.Get_Filename) then
Set_No_Parent (Type_Data);
return;
end if;
Type_Data.Argument_Father_Type_Name := new
String'(Node_Image (Parent_Type.P_Defining_Name));
Type_Data.Argument_Father_Nesting := new
String'(Get_Nesting (Parent_Type));
Type_Data.Argument_Father_Unit_Name := new String'
(Enclosing_Unit_Name (Parent_Type));
Type_Data.Has_Argument_Father := True;
end Get_Type_Parent_Data;
begin
if Node.Kind = Ada_Generic_Package_Decl
and then (Node.Parent.Kind /= Ada_Library_Item
or else Stub_Mode_ON)
then
-- Nested generics are not supported
return Over;
end if;
if Node.Kind in Ada_Basic_Decl
and then Is_Ghost_Code (Node.As_Basic_Decl)
then
return Over;
end if;
if Node.Kind = Ada_Private_Part then
return Over;
end if;
if Node.Kind = Ada_Generic_Formal_Part then
return Over;
end if;
if Node.Kind = Ada_Package_Decl and then Inside_Inst then
-- No processing for packages nested inside generic ones
return Over;
end if;
if Node.Kind = Ada_Generic_Package_Instantiation
and then not Inside_Inst and then not Data.Is_Generic
then
if Stub_Mode_ON then
return Over;
end if;
declare
Gen_Name : constant Libadalang.Analysis.Name :=
Node.As_Generic_Package_Instantiation.F_Generic_Pkg_Name;
Gen_Decl : Basic_Decl :=
Gen_Name.P_Relative_Name.As_Name.P_Referenced_Decl;
begin
if Gen_Decl.Is_Null then
return Over;
end if;
Gen_Decl := Gen_Decl.P_Get_Uninstantiated_Node.As_Basic_Decl;
-- No processing for instantiations of nested generics,
-- also if corresponding generic is not processed (or going
-- to be) there is no corresponding generic test package.
if not Source_Present (Gen_Decl.Unit.Get_Filename)
or else Gen_Decl.Parent.Kind /= Ada_Library_Item
then
return Over;
end if;
Inside_Inst := True;
Instance_Nesting := new String'
(Encode
(Node.As_Basic_Decl.P_Fully_Qualified_Name,
Node.Unit.Get_Charset));
Instance_Sloc := new String'
(Base_Name (Data.Unit_File_Name.all)
& ":"
& Trim (First_Line_Number (Node)'Img, Both)
& ":"
& Trim (First_Column_Number (Node)'Img, Both)
& ":");
Increase_Indent
(Me,
"traversing instantiation " & Node.Image);
Traverse (Gen_Decl, Get_Records'Access);
Decrease_Indent (Me);
Inside_Inst := False;
Free (Instance_Nesting);
Free (Instance_Sloc);
return Over;
end;
end if;
if Kind (Node) /= Ada_Type_Decl then
return Into;
end if;
if not Node.As_Type_Decl.P_Is_Tagged_Type then
return Over;
end if;
if Node.As_Type_Decl.P_Is_Interface_Type then
return Over;
end if;
if Node.As_Base_Type_Decl.P_Is_Private then
Cur_Node :=
Node.As_Base_Type_Decl.P_Private_Completion.As_Ada_Node;
else
Cur_Node := Node.As_Ada_Node;
end if;
-- Gathering basic data about type
Type_Data.Main_Type_Elem := Cur_Node;
Type_Data.Main_Type_Text_Name := new
String'(Node_Image (Cur_Node.As_Basic_Decl.P_Defining_Name));
if Inside_Inst then
Type_Data.Nesting := new String'(Instance_Nesting.all);
else
Type_Data.Nesting := new String'(Get_Nesting (Cur_Node));
end if;
-- Checking for duplicating types
declare
Stored_Type : Base_Type_Info;
begin
for I in Data.Type_Data_List.First_Index ..
Data.Type_Data_List.Last_Index
loop
Stored_Type := Data.Type_Data_List.Element (I);
if Stored_Type.Main_Type_Elem = Cur_Node
and then Stored_Type.Nesting.all = Type_Data.Nesting.all
then
Free (Type_Data.Main_Type_Text_Name);
Free (Type_Data.Nesting);
return Over;
end if;
end loop;
end;
Check_Type_For_Elaboration (Cur_Node.As_Base_Type_Decl);
-- Checking if any of ancestor types had a discriminant part
Type_Data.No_Default_Discriminant :=
Check_Type_For_Unset_Discriminants (Cur_Node.As_Base_Type_Decl);
Get_Type_Parent_Data (Type_Data);
Type_Data.Main_Type_Abstract :=
Abstract_Type (Cur_Node.As_Base_Type_Decl);
Type_Data.Type_Number := Type_Counter;
Type_Counter := Type_Counter + 1;
Data.Type_Data_List.Append (Type_Data);
if
Type_Data.Nesting.all = Data.Unit_Full_Name.all
then
Test_Package := new String'
(Data.Unit_Full_Name.all
& "."
& Type_Data.Main_Type_Text_Name.all
& Test_Data_Unit_Name_Suff
& "."
& Type_Data.Main_Type_Text_Name.all
& Test_Unit_Name_Suff);
else
Test_Package := new String'
(Data.Unit_Full_Name.all
& "." & Test_Data_Unit_Name & "."
& Test_Unit_Name & "."
& Nesting_Difference
(Type_Data.Nesting.all,
Data.Unit_Full_Name.all)
& "."
& Type_Data.Main_Type_Text_Name.all
& Test_Data_Unit_Name_Suff
& "."
& Type_Data.Main_Type_Text_Name.all
& Test_Unit_Name_Suff);
end if;
Test_Type.Test_Type := No_Ada_Node;
Test_Type.Test_Type_Name := new String'
("Test_" &
Type_Data.Main_Type_Text_Name.all);
Test_Type.Nesting := new String'
(Test_Package.all);
if not Type_Data.Main_Type_Abstract then
Suite_Data_List.Test_Types.Append
(Test_Type_Info_Wrapper'
(TT_Info => Test_Type,
Test_Package => Test_Package,
Original_Type => Type_Data.Main_Type_Elem));
end if;
return Over;
end Get_Records;
---------------------
-- Get_Subprograms --
---------------------
function Get_Subprograms (Node : Ada_Node'Class) return Visit_Status is
Subp : Subp_Info;
Owner_Decl : Base_Type_Decl;
Type_Found : Boolean := False;
Test_Routine : Test.Harness.Test_Routine_Info;
Test_Routine_Wrapper : Test_Routine_Info_Wrapper;
Test_Package_Name : String_Access;
Original_Type : Base_Type_Decl;
Has_TC : Boolean;
procedure Update_Name_Frequency (Subp_Name : String);
---------------------------
-- Update_Name_Frequency --
---------------------------
procedure Update_Name_Frequency (Subp_Name : String) is
Cur : Name_Frequency.Cursor;
begin
Cur := Data.Subp_Name_Frequency.Find (To_Lower (Subp_Name));
if Cur = Name_Frequency.No_Element then
Data.Subp_Name_Frequency.Include (To_Lower (Subp_Name), 1);
else
Data.Subp_Name_Frequency.Replace_Element
(Cur, (Name_Frequency.Element (Cur)) + 1);
end if;
end Update_Name_Frequency;
begin
if Node.Kind in Ada_Basic_Decl
and then Is_Ghost_Code (Node.As_Basic_Decl)
then
return Over;
end if;
if Node.Kind = Ada_Generic_Package_Decl
and then (Node.Parent.Kind /= Ada_Library_Item
or else Stub_Mode_ON)
then
-- Nested generics are not supported
return Over;
end if;
if Node.Kind = Ada_Package_Decl and then Inside_Inst then
-- No processing for packages nested inside generic ones
return Over;
end if;
if
Node.Kind in Ada_Protected_Type_Decl | Ada_Single_Protected_Decl
then
return Over;
end if;
if Node.Kind = Ada_Private_Part then
return Over;
end if;
if Node.Kind = Ada_Generic_Formal_Part then
return Over;
end if;
if Node.Kind = Ada_Generic_Package_Instantiation
and then not Inside_Inst and then not Data.Is_Generic
then
if Stub_Mode_ON then
return Over;
end if;
declare
Gen_Name : constant Libadalang.Analysis.Name :=
Node.As_Generic_Package_Instantiation.F_Generic_Pkg_Name;
Gen_Decl : Basic_Decl :=
Gen_Name.P_Relative_Name.As_Name.P_Referenced_Decl;
begin
if Gen_Decl.Is_Null then
return Over;
end if;
Gen_Decl := Gen_Decl.P_Get_Uninstantiated_Node.As_Basic_Decl;
-- No processing for instantiations of nested generics,
-- also if corresponding generic is not processed (or going
-- to be) there is no corresponding generic test package
if not Source_Present (Gen_Decl.Unit.Get_Filename)
or else Gen_Decl.Parent.Kind /= Ada_Library_Item
then
return Over;
end if;
Inside_Inst := True;
Instance_Nesting := new String'
(Encode
(Node.As_Basic_Decl.P_Fully_Qualified_Name,
Node.Unit.Get_Charset));
Instance_Sloc := new String'
(Base_Name (Data.Unit_File_Name.all)
& ":"
& Trim (First_Line_Number (Node)'Img, Both)
& ":"
& Trim (First_Column_Number (Node)'Img, Both)
& ":");
Increase_Indent
(Me, "traversing instantiation " & Node.Image);
Traverse (Gen_Decl, Get_Subprograms'Access);
Decrease_Indent (Me);
Inside_Inst := False;
Free (Instance_Nesting);
Free (Instance_Sloc);
return Over;
end;
end if;
if
Node.Kind = Ada_Expr_Function
and then not Node.As_Base_Subp_Body.P_Previous_Part_For_Decl.Is_Null
then
-- It will be treated at spec.
return Over;
end if;
if
Node.Kind not in Ada_Subp_Decl
| Ada_Subp_Renaming_Decl | Ada_Expr_Function
then
return Into;
end if;
if Node.Kind = Ada_Subp_Renaming_Decl
and then not Node.As_Basic_Decl.P_Previous_Part_For_Decl.Is_Null
then
-- A subprogram renaming in this case is a renaming-as-body
-- corresponding declaration has already been processed.
return Over;
end if;
Subp.Subp_Declaration := Node.As_Ada_Node;
Subp.Subp_Text_Name := new String'(Get_Subp_Name (Node));
Subp.Subp_Name_Image := new String'
(Node_Image (Node.As_Basic_Decl.P_Defining_Name));
if Inside_Inst then
Subp.Nesting := new String'(Instance_Nesting.all);
else
Subp.Nesting := new String'(Get_Nesting (Node));
end if;
-- Setting tested subprogram sloc for suite info
declare
Subp_Span : constant Source_Location_Range :=
Subp.Subp_Declaration.Sloc_Range;
begin
if Inside_Inst then
Test_Routine.Tested_Sloc := new String'
(Base_Name (Subp.Subp_Declaration.Unit.Get_Filename)
& ":"
& Trim (Subp_Span.Start_Line'Img, Both)
& ":"
& Trim (Subp_Span.Start_Column'Img, Both)
& " instance at "
& Instance_Sloc.all);
else
Test_Routine.Tested_Sloc := new String'
(Base_Name (Data.Unit_File_Name.all)
& ":"
& Trim (Subp_Span.Start_Line'Img, Both)
& ":"
& Trim (Subp_Span.Start_Column'Img, Both)
& ":");
end if;
end;
if Node.Kind = Ada_Expr_Function then
Owner_Decl := P_Primitive_Subp_Tagged_Type
(Node.As_Base_Subp_Body.F_Subp_Spec.As_Base_Subp_Spec);
elsif Node.Kind = Ada_Subp_Renaming_Decl then
Owner_Decl := P_Primitive_Subp_Tagged_Type
(Node.As_Subp_Renaming_Decl.F_Subp_Spec.As_Base_Subp_Spec);
else
Owner_Decl := P_Primitive_Subp_Tagged_Type
(Node.As_Basic_Subp_Decl.P_Subp_Decl_Spec);
end if;
if Owner_Decl /= No_Base_Type_Decl
-- If owner is incomplete private declaration (without "tagged"
-- keyword) subp should be treated as non-dispatching.
then
if Owner_Decl.As_Base_Type_Decl.P_Is_Private then
Owner_Decl :=
Owner_Decl.As_Base_Type_Decl.P_Private_Completion;
end if;
Type_Found := False;
for
I in Data.Type_Data_List.First_Index ..
Data.Type_Data_List.Last_Index
loop
if
Data.Type_Data_List.Element (I).Main_Type_Elem = Owner_Decl
then
Subp.Corresp_Type :=
Data.Type_Data_List.Element (I).Type_Number;
Subp.Subp_Mangle_Name := new
String'(Mangle_Hash (Node));
Subp.Subp_Full_Hash := new
String'(Mangle_Hash_Full (Node));
Subp.Subp_Hash_V1 := new
String'(Mangle_Hash_Full (Node, True, True));
Subp.Subp_Hash_V2_1 := new
String'(Mangle_Hash_Full
(Node,
N_Controlling => True));
Type_Found := True;
exit;
end if;
end loop;
end if;
-- Setting suite info
if Type_Found then
Test_Routine.TR_Declaration := No_Ada_Node;
Test_Routine.TR_Text_Name := new String'
(Subp.Subp_Mangle_Name.all);
-- Not setting test type number since it will be reset
-- during suite_data generation.
Original_Type := Owner_Decl;
if
Nesting_Difference
(Data.Unit_Full_Name.all, Subp.Nesting.all) = ""
then
Test_Package_Name := new String'
(Data.Unit_Full_Name.all
& "."
& Node_Image
(Original_Type.As_Basic_Decl.P_Defining_Name)
& Test_Data_Unit_Name_Suff & "."
& Node_Image
(Original_Type.As_Basic_Decl.P_Defining_Name)
& Test_Unit_Name_Suff);
else
Test_Package_Name := new String'
(Data.Unit_Full_Name.all & "."
& Test_Data_Unit_Name & "."
& Test_Unit_Name
& "."
& Nesting_Difference
(Data.Unit_Full_Name.all,
Subp.Nesting.all)
& "."
& Node_Image
(Original_Type.As_Basic_Decl.P_Defining_Name)
& Test_Data_Unit_Name_Suff & "."
& Node_Image
(Original_Type.As_Basic_Decl.P_Defining_Name)
& Test_Unit_Name_Suff);
end if;
Test_Routine.Nesting := new String'(Test_Package_Name.all);
else
-- In case when owner tagged type is declared in the private part
-- the check for Elaboration control is not performed
-- for the type in Get_Records so we need to launch it here.
if Node.Kind = Ada_Expr_Function then
Owner_Decl := P_Primitive_Subp_Tagged_Type
(Node.As_Base_Subp_Body.F_Subp_Spec.As_Base_Subp_Spec);
elsif Node.Kind = Ada_Subp_Renaming_Decl then
Owner_Decl := P_Primitive_Subp_Tagged_Type
(Node.As_Subp_Renaming_Decl.F_Subp_Spec.As_Base_Subp_Spec);
else
Owner_Decl := P_Primitive_Subp_Tagged_Type
(Node.As_Basic_Subp_Decl.P_Subp_Decl_Spec);
end if;
if Owner_Decl /= No_Base_Type_Decl then
Check_Type_For_Elaboration (Owner_Decl);
end if;
-- In simple case the type is always found, because in fact
-- we do not depend on it.
Type_Found := True;
Subp.Corresp_Type := 0;
Subp.Subp_Mangle_Name := new
String'(Mangle_Hash (Node));
Subp.Subp_Full_Hash := new
String'(Mangle_Hash_Full (Node));
Subp.Subp_Hash_V1 := new
String'(Mangle_Hash_Full (Node, True, True));
Subp.Subp_Hash_V2_1 := new
String'(Mangle_Hash_Full
(Node,
N_Controlling => True));
Data.Has_Simple_Case := True;
Data.Needs_Set_Up := True;
Data.Needs_Assertions := True;
-- Adding corresponding test routines for non-primitives to
-- the first element of suite data list.
Test_Routine.TR_Declaration := No_Ada_Node;
Test_Routine.TR_Text_Name := new String'
(Subp.Subp_Mangle_Name.all);
Test_Routine.Test_Type_Numb := 1;
if
Nesting_Difference
(Data.Unit_Full_Name.all, Subp.Nesting.all) = ""
then
Test_Routine.Nesting := new String'
(Subp.Nesting.all & "." &
Test_Data_Unit_Name & "." &
Test_Unit_Name);
else
Test_Routine.Nesting := new String'
(Nesting_Common_Prefix
(Data.Unit_Full_Name.all, Subp.Nesting.all) &
"." & Test_Data_Unit_Name &
"." & Test_Unit_Name & "." &
Nesting_Difference
(Data.Unit_Full_Name.all, Subp.Nesting.all) &
"." & Test_Data_Unit_Name & "." & Test_Unit_Name);
end if;
Test_Package_Name := new String'
(Test_Routine.Nesting.all);
Original_Type := No_Base_Type_Decl;
end if;
if Type_Found then
Test_Routine_Wrapper :=
(TR_Info => Test_Routine,
Test_Package => Test_Package_Name,
Original_Type => Original_Type.As_Ada_Node,
Original_Subp => Node.As_Ada_Node,
From_Generic => Is_Node_From_Generic (Node));
Gather_Test_Cases
(Subp,
Test_Routine_Wrapper,
Data,
Suite_Data_List,
Has_TC,
(if Instance_Sloc = null then "" else Instance_Sloc.all));
if Has_TC or else not Test_Case_Only then
Update_Name_Frequency (Subp.Subp_Text_Name.all);
end if;
end if;
return Over;
end Get_Subprograms;
----------------------------------
-- Gather_Inherited_Subprograms --
----------------------------------
procedure Gather_Inherited_Subprograms
(Dummy_Types : Natural;
Suite_Data_List : in out Suites_Data_Type)
is
Type_Dec : Type_Decl;
function Is_Overridden
(Subp : Basic_Decl; Decls : Basic_Decl_Array) return Boolean;
-- Checks whether given inherited subprogram is hidden by an
-- overriding one.
-------------------
-- Is_Overridden --
-------------------
function Is_Overridden
(Subp : Basic_Decl; Decls : Basic_Decl_Array) return Boolean is
begin
for Dec of Decls loop
if Subp = Dec then
return False;
end if;
end loop;
return True;
end Is_Overridden;
Test_Routine : Test.Harness.Test_Routine_Info_Enhanced;
Test_Routine_Wrapper : Test_Routine_Info_Enhanced_Wrapper;
Tmp_Data : Data_Holder;
Tmp_Suites_Data : Suites_Data_Type;
Tmp_Subp : Subp_Info;
Dummy_TR_Info : Test_Routine_Info_Wrapper;
Tmp_TR : Test.Harness.Test_Routine_Info;
Tmp_Has_TC : Boolean;
begin
-- Creating a stub for Subp_Info object
Tmp_Subp.Nesting := new String'("");
Tmp_Subp.Subp_Text_Name := new String'("");
Tmp_Subp.Subp_Full_Hash := new String'("");
Tmp_Subp.Subp_Hash_V1 := new String'("");
Tmp_Subp.Subp_Hash_V2_1 := new String'("");
for
K in Suite_Data_List.Test_Types.First_Index + Dummy_Type_Counter ..
Suite_Data_List.Test_Types.Last_Index
loop
if Suite_Data_List.Test_Types.Element (K).Original_Type.Kind in
Ada_Task_Type_Decl | Ada_Protected_Type_Decl
then
goto Skip_Inheritance;
end if;
Type_Dec := As_Type_Decl
(Suite_Data_List.Test_Types.Element (K).Original_Type);
declare
ISubs : constant Basic_Decl_Array :=
Type_Dec.P_Get_Primitives (Only_Inherited => True);
ISubs2 : constant Basic_Decl_Array :=
Type_Dec.P_Get_Primitives (Only_Inherited => False);
Ancestor_Type : Base_Type_Decl;
begin
for ISub of ISubs loop
if
Source_Present (ISub.Unit.Get_Filename)
and then Is_Callable_Subprogram (ISub)
and then not Is_Private (ISub)
and then not Is_Overridden (ISub, ISubs2)
then
if ISub.Kind = Ada_Expr_Function then
Ancestor_Type :=
P_Primitive_Subp_Tagged_Type
(ISub.As_Base_Subp_Body.F_Subp_Spec.
As_Base_Subp_Spec);
elsif ISub.Kind = Ada_Subp_Renaming_Decl then
Ancestor_Type :=
P_Primitive_Subp_Tagged_Type
(ISub.As_Subp_Renaming_Decl.F_Subp_Spec.
As_Base_Subp_Spec);
else
Ancestor_Type :=
P_Primitive_Subp_Tagged_Type
(ISub.As_Basic_Subp_Decl.P_Subp_Decl_Spec);
end if;
while not Ancestor_Type.P_Next_Part.Is_Null loop
Ancestor_Type := Ancestor_Type.P_Next_Part;
end loop;
if Test_Types_Linked
(Ancestor_Type, Type_Dec.As_Base_Type_Decl)
and then No_Inheritance_Through_Generics
(Ancestor_Type, Type_Dec.As_Base_Type_Decl)
then
-- Check if the inherited subprogram had
-- Test_Cases. In such case one test per Test_Case
-- should be inherited.
Tmp_Data.Unit_File_Name := new
String'(Base_Name (ISub.Unit.Get_Filename));
Tmp_Subp.Subp_Declaration := ISub.As_Ada_Node;
Tmp_Subp.Subp_Text_Name :=
new String'(Get_Subp_Name (ISub));
Tmp_Subp.Subp_Mangle_Name :=
new String'(Mangle_Hash (ISub));
Tmp_Subp.Subp_Name_Image := new String'
(Node_Image (ISub.As_Basic_Decl.P_Defining_Name));
Gather_Test_Cases
(Tmp_Subp,
Dummy_TR_Info,
Tmp_Data,
Tmp_Suites_Data,
Tmp_Has_TC);
if
Get_Nesting (ISub) = Enclosing_Unit_Name (ISub)
then
Test_Routine.TR_Rarent_Unit_Name := new String'
(Enclosing_Unit_Name (ISub)
& "."
& Node_Image
(P_Defining_Name
(Ancestor_Type.As_Basic_Decl))
& Test_Data_Unit_Name_Suff
& "."
& Node_Image
(P_Defining_Name
(Ancestor_Type.As_Basic_Decl))
& Test_Unit_Name_Suff);
else
Test_Routine.TR_Rarent_Unit_Name := new String'
(Enclosing_Unit_Name (ISub)
& "."
& Test_Data_Unit_Name
& "."
& Test_Unit_Name
& "."
& Nesting_Difference
(Get_Nesting (ISub),
Enclosing_Unit_Name (ISub))
& Node_Image
(P_Defining_Name
(Ancestor_Type.As_Basic_Decl))
& Test_Data_Unit_Name_Suff
& "."
& Node_Image
(P_Defining_Name
(Ancestor_Type.As_Basic_Decl))
& Test_Unit_Name_Suff);
end if;
Test_Routine.Nesting := new String'
(Test_Routine.TR_Rarent_Unit_Name.all);
if
Get_Nesting (Type_Dec) = Data.Unit_Full_Name.all
then
Test_Routine_Wrapper.Test_Package := new String'
(Data.Unit_Full_Name.all
& "."
& Node_Image
(P_Defining_Name
(Type_Dec.As_Basic_Decl))
& Test_Data_Unit_Name_Suff
& "."
& Node_Image
(P_Defining_Name
(Type_Dec.As_Basic_Decl))
& Test_Unit_Name_Suff);
else
Test_Routine_Wrapper.Test_Package := new String'
(Data.Unit_Full_Name.all
& "."
& Test_Data_Unit_Name
& "."
& Test_Unit_Name
& "."
& Nesting_Difference
(Get_Nesting (Type_Dec),
Data.Unit_Full_Name.all)
& "."
& Node_Image
(P_Defining_Name
(Type_Dec.As_Basic_Decl))
& Test_Data_Unit_Name_Suff
& "."
& Node_Image
(P_Defining_Name
(Type_Dec.As_Basic_Decl))
& Test_Unit_Name_Suff);
end if;
-- Type is always the same, test_cases or not
Test_Routine_Wrapper.Original_Type :=
Type_Dec.As_Ada_Node;
if Tmp_Has_TC then
-- There were Test_Cases
for I in Tmp_Suites_Data.TR_List.First_Index ..
Tmp_Suites_Data.TR_List.Last_Index
loop
Tmp_TR :=
Tmp_Suites_Data.TR_List.Element (I).TR_Info;
Test_Routine.TR_Text_Name :=
new String'(Tmp_TR.TR_Text_Name.all);
-- adding sloc info
Test_Routine.Tested_Sloc := new String'
(Tmp_TR.Tested_Sloc.all
& " inherited at "
& Base_Name
(Type_Dec.Unit.Get_Filename)
& ":"
& Trim
(First_Line_Number (Type_Dec)'Img, Both)
& ":"
& Trim
(First_Column_Number (Type_Dec)'Img,
Both)
& ":");
Test_Routine_Wrapper.TR_Info := Test_Routine;
Suite_Data_List.ITR_List.Append
(Test_Routine_Wrapper);
end loop;
elsif not Test_Case_Only then
-- There were no test_Cases, we just need
-- to add the single inherited test.
Test_Routine.TR_Text_Name := new String'
(Mangle_Hash (ISub));
-- Adding sloc info
Test_Routine.Tested_Sloc := new String'
(Base_Name (ISub.Unit.Get_Filename)
& ":"
& Trim
(First_Line_Number (ISub)'Img, Both)
& ":"
& Trim
(First_Column_Number (ISub)'Img, Both)
& ": inherited at "
& Base_Name (Type_Dec.Unit.Get_Filename)
& ":"
& Trim
(First_Line_Number (Type_Dec)'Img, Both)
& ":"
& Trim
(First_Column_Number (Type_Dec)'Img, Both)
& ":");
Test_Routine_Wrapper.TR_Info := Test_Routine;
Suite_Data_List.ITR_List.Append
(Test_Routine_Wrapper);
end if;
end if;
end if;
Tmp_Data.Subp_List.Clear;
Tmp_Suites_Data.TR_List.Clear;
end loop;
end;
<>
end loop;
end Gather_Inherited_Subprograms;
------------------------------
-- Gather_Substitution_Data --
------------------------------
procedure Gather_Substitution_Data
(Suite_Data_List : in out Suites_Data_Type)
is
OSub : Basic_Decl := No_Basic_Decl;
Ancestor_Type : Base_Type_Decl;
TR : Test.Harness.Test_Routine_Info;
LTR : Test.Harness.Test_Routine_Info_Enhanced;
LTR_W : Test_Routine_Info_Enhanced_Wrapper;
Depth : Natural;
Test_Type_Wrapper : Test_Type_Info_Wrapper;
begin
for TR_W of Suite_Data_List.TR_List loop
if not TR_W.Original_Type.Is_Null then
declare
OSubs : constant Basic_Decl_Array :=
P_Base_Subp_Declarations
(TR_W.Original_Subp.As_Basic_Decl);
begin
if OSubs'Length > 1 then
OSub := No_Basic_Decl;
for O in reverse OSubs'First .. OSubs'Last - 1 loop
if OSubs (O).Kind /= Ada_Abstract_Subp_Decl then
OSub := OSubs (O);
end if;
end loop;
end if;
end;
end if;
if not OSub.Is_Null then
if OSub.Kind = Ada_Expr_Function then
Ancestor_Type :=
P_Primitive_Subp_Tagged_Type
(OSub.As_Base_Subp_Body.F_Subp_Spec.
As_Base_Subp_Spec);
else
Ancestor_Type :=
P_Primitive_Subp_Tagged_Type
(OSub.As_Basic_Subp_Decl.P_Subp_Decl_Spec);
end if;
while not Ancestor_Type.P_Next_Part.Is_Null loop
Ancestor_Type := Ancestor_Type.P_Next_Part;
end loop;
if Source_Present (Ancestor_Type.Unit.Get_Filename)
and then Is_Callable_Subprogram (OSub)
and then Test_Types_Linked
(Ancestor_Type, TR_W.Original_Type.As_Base_Type_Decl)
and then No_Inheritance_Through_Generics
(Ancestor_Type, TR_W.Original_Type.As_Base_Type_Decl)
then
Depth := Inheritance_Depth
(Ancestor_Type.As_Base_Type_Decl,
TR_W.Original_Type.As_Base_Type_Decl);
-- Inheritance depth of corresponding test type needs to be
-- updated
for
L in Suite_Data_List.Test_Types.First_Index ..
Suite_Data_List.Test_Types.Last_Index
loop
Test_Type_Wrapper :=
Suite_Data_List.Test_Types.Element (L);
if Test_Type_Wrapper.Original_Type = TR_W.Original_Type
then
if Depth >
Test_Type_Wrapper.TT_Info.Max_Inheritance_Depth
then
Test_Type_Wrapper.TT_Info.Max_Inheritance_Depth :=
Depth;
Suite_Data_List.Test_Types.Replace_Element
(L, Test_Type_Wrapper);
exit;
end if;
end if;
end loop;
-- ATM Test_Cases are not taken into account.
TR := TR_W.TR_Info;
LTR.TR_Text_Name := new String'(TR.TR_Text_Name.all);
LTR.Inheritance_Depth := Depth;
LTR_W.TR_Info := LTR;
LTR_W.Original_Type := TR_W.Original_Type;
LTR_W.Test_Package := new String'(TR_W.Test_Package.all);
-- Adding sloc info
LTR_W.TR_Info.Tested_Sloc := new String'
(Base_Name (OSub.Unit.Get_Filename)
& ":"
& Trim
(First_Line_Number (OSub)'Img,
Both)
& ":"
& Trim
(First_Column_Number (OSub)'Img,
Both)
& ": overridden at "
& Base_Name
(TR_W.Original_Type.Unit.Get_Filename)
& ":"
& Trim
(First_Line_Number (TR_W.Original_Subp)'Img,
Both)
& ":"
& Trim
(First_Column_Number (TR_W.Original_Subp)'Img,
Both)
& ":");
Suite_Data_List.LTR_List.Append (LTR_W);
end if;
end if;
end loop;
end Gather_Substitution_Data;
----------------------
-- Is_Fully_Private --
----------------------
function Is_Fully_Private (Arg : Base_Type_Decl) return Boolean is
Type_Part : Base_Type_Decl := Arg;
begin
while not Type_Part.P_Previous_Part.Is_Null loop
Type_Part := Type_Part.P_Previous_Part;
end loop;
return Is_Private (Type_Part);
end Is_Fully_Private;
-----------------------
-- Test_Types_Linked --
-----------------------
function Test_Types_Linked
(Inheritance_Root_Type : Base_Type_Decl;
Inheritance_Final_Type : Base_Type_Decl)
return Boolean
is
Intermidiate : Base_Type_Decl := Inheritance_Final_Type;
begin
while not Intermidiate.Is_Null loop
if Is_Fully_Private (Intermidiate) then
return False;
end if;
if Intermidiate = Inheritance_Root_Type then
return True;
end if;
Intermidiate := Parent_Type_Declaration (Intermidiate);
end loop;
return False;
end Test_Types_Linked;
-------------------------------------
-- No_Inheritance_Through_Generics --
-------------------------------------
function No_Inheritance_Through_Generics
(Inheritance_Root_Type : Base_Type_Decl;
Inheritance_Final_Type : Base_Type_Decl)
return Boolean
is
Intermidiate : Base_Type_Decl := Inheritance_Final_Type;
begin
while not Intermidiate.Is_Null loop
if not Is_Declared_In_Regular_Package (Intermidiate) then
return False;
end if;
if Intermidiate = Inheritance_Root_Type then
return True;
end if;
Intermidiate := Parent_Type_Declaration (Intermidiate);
end loop;
return False;
end No_Inheritance_Through_Generics;
--------------------------
-- Is_Node_From_Generic --
--------------------------
function Is_Node_From_Generic (Node : Ada_Node'Class) return Boolean
is
Elem : Ada_Node := Node.As_Ada_Node;
begin
if Inside_Inst then
return False;
end if;
while not Elem.Is_Null loop
if Elem.Kind = Ada_Generic_Package_Decl then
return True;
end if;
Elem := Elem.Parent;
end loop;
return False;
end Is_Node_From_Generic;
--------------------------------
-- Check_Type_For_Elaboration --
--------------------------------
procedure Check_Type_For_Elaboration (Type_Dec : Base_Type_Decl) is
Dec : Base_Type_Decl := Type_Dec;
Dec2 : Base_Type_Decl;
Elab_Name : constant Langkit_Support.Text.Unbounded_Text_Type :=
To_Unbounded_Text ("preelaborable_initialization");
Unit_SF_Name : constant String :=
Base_Name (Type_Dec.Unit.Get_Filename);
function Check_Pragma (Node : Ada_Node'Class) return Boolean;
-- Checks for pragma in the following nodes
function Check_Pragma (Node : Ada_Node'Class) return Boolean is
Next : Ada_Node := Node.Next_Sibling;
begin
while not Next.Is_Null and then Next.Kind = Ada_Pragma_Node loop
if To_Lower (Node_Image (F_Id (Next.As_Pragma_Node))) =
"preelaborable_initialization"
then
return True;
end if;
Next := Next.Next_Sibling;
end loop;
return False;
end Check_Pragma;
begin
while not Dec.Is_Null loop
-- We need to check all 3 possible declarations, so first roll
-- to the topmost one.
while not Dec.P_Previous_Part.Is_Null loop
Dec := Dec.P_Previous_Part;
end loop;
Dec2 := Dec;
while not Dec2.Is_Null loop
if Dec2.P_Has_Aspect (Elab_Name)
or else not Dec2.P_Get_Pragma (Elab_Name).Is_Null
or else Check_Pragma (Dec2)
then
Report_Std
("warning: (gnattest) "
& Unit_SF_Name
& ":"
& Trim (First_Line_Number (Dec2)'Img, Both)
& ":"
& Trim (First_Column_Number (Dec2)'Img, Both)
& ":"
& " elaboration control pragma given"
& " for ancestor type of "
& Node_Image (Type_Dec.P_Defining_Name));
Report_Std
("this can cause circularity in the test harness",
1);
return;
end if;
if Dec2.P_Next_Part.Is_Null then
Dec := Parent_Type_Declaration (Dec2);
end if;
Dec2 := Dec2.P_Next_Part;
end loop;
end loop;
end Check_Type_For_Elaboration;
function Check_Type_For_Unset_Discriminants
(Type_Dec : Base_Type_Decl) return Boolean
is
Dec : Base_Type_Decl := Type_Dec;
Dec2 : Base_Type_Decl;
Discr : Discriminant_Part;
begin
while not Dec.Is_Null loop
-- We need to check all 3 possible declarations, so first roll
-- to the topmost one.
while not Dec.P_Previous_Part.Is_Null loop
Dec := Dec.P_Previous_Part;
end loop;
Dec2 := Dec;
while not Dec2.Is_Null loop
if Dec2.Kind in Ada_Incomplete_Type_Decl
| Ada_Incomplete_Tagged_Type_Decl
then
Discr := Dec2.As_Incomplete_Type_Decl.F_Discriminants;
elsif Dec2.Kind = Ada_Protected_Type_Decl then
Discr := Dec2.As_Protected_Type_Decl.F_Discriminants;
elsif Dec2.Kind = Ada_Task_Type_Decl then
Discr := Dec2.As_Task_Type_Decl.F_Discriminants;
else
Discr := Dec2.As_Type_Decl.F_Discriminants;
end if;
if not Discr.Is_Null then
if Discr.Kind = Ada_Unknown_Discriminant_Part
then
return True;
end if;
declare
Discr_Specs : constant Discriminant_Spec_List :=
Discr.As_Known_Discriminant_Part.F_Discr_Specs;
begin
for Discr_Spec of Discr_Specs loop
if Discr_Spec.F_Default_Expr.Is_Null then
return True;
end if;
end loop;
end;
end if;
if Dec2.P_Next_Part.Is_Null then
Dec := Parent_Type_Declaration (Dec2);
end if;
Dec2 := Dec2.P_Next_Part;
end loop;
end loop;
return False;
end Check_Type_For_Unset_Discriminants;
begin
Unit := Bod.F_Item.As_Ada_Node;
case Unit.Kind is
when Ada_Package_Decl =>
Data.Is_Generic := False;
when Ada_Generic_Package_Decl =>
Data.Is_Generic := True;
when Ada_Generic_Package_Instantiation =>
Report_Std
("gnattest: "
& Base_Name (The_Unit.Unit.Get_Filename)
& " is a library level instantiation");
Apropriate_Source := False;
Set_Source_Status (The_Unit.Unit.Get_Filename, Bad_Content);
return;
when others =>
Report_Std
("gnattest: "
& Base_Name (The_Unit.Unit.Get_Filename)
& " is an unsupported kind of unit");
Apropriate_Source := False;
Set_Source_Status (The_Unit.Unit.Get_Filename, Bad_Content);
return;
end case;
if Unit.As_Basic_Decl.P_Has_Aspect
(To_Unbounded_Text (To_Text ("Remote_Call_Interface")))
then
Apropriate_Source := False;
Report_Std
("gnattest: "
& Base_Name (The_Unit.Unit.Get_Filename)
& " is RCI package; skipping");
Set_Source_Status (The_Unit.Unit.Get_Filename, Processed_In_Vain);
return;
end if;
declare
Sem_Parent : Ada_Node := Unit;
begin
while not Sem_Parent.Is_Null loop
if Sem_Parent.Kind in Ada_Basic_Decl
and then Is_Ghost_Code (Sem_Parent.As_Basic_Decl)
then
-- The whole UUT is Ghost
Set_Source_Status (The_Unit.Unit.Get_Filename, Bad_Content);
Apropriate_Source := False;
return;
end if;
if not Stub_Mode_ON and then not Separate_Drivers
and then Sem_Parent.Parent.Kind in Ada_Library_Item_Range
and then Sem_Parent.Parent.As_Library_Item.F_Has_Private
then
-- Cannot incorporate test packages of private packages
-- in monolyth mode.
Report_Std
("gnattest: "
& Enclosing_Unit_Name (The_Unit)
& " is private or child of private; skipping");
Set_Source_Status (The_Unit.Unit.Get_Filename, Bad_Content);
Apropriate_Source := False;
return;
end if;
Sem_Parent := Sem_Parent.P_Semantic_Parent;
end loop;
end;
Increase_Indent
(Me,
"processing " & Node_Image (Unit.As_Basic_Decl.P_Defining_Name)
& " (" & Base_Name (The_Unit.Unit.Get_Filename) & ")");
Check_Unit_For_Elaboration (The_Unit);
Data.Unit := The_Unit;
Data.Unit_Full_Name := new String'
(Node_Image (Unit.As_Basic_Decl.P_Defining_Name));
Data.Unit_File_Name := new String'(The_Unit.Unit.Get_Filename);
Trace (Me, "Gathering nested packages");
Traverse (Unit, Get_Nested_Packages'Access);
declare
Test_Type : Test_Type_Info_Wrapper;
Pack_Cur : Package_Info_List.Cursor;
Test_Package : constant String :=
Data.Unit_Full_Name.all & "." &
Test_Data_Unit_Name & "." & Test_Unit_Name;
Nest_Dif : String_Access;
begin
Test_Type.TT_Info.Test_Type := No_Ada_Node;
Test_Type.TT_Info.Test_Type_Name := new String'("Test");
Pack_Cur := Data.Package_Data_List.First;
loop
exit when Pack_Cur = Package_Info_List.No_Element;
Nest_Dif := new String'
(Nesting_Difference
(Package_Info_List.Element (Pack_Cur).Name.all,
Data.Unit_Full_Name.all));
if Nest_Dif.all = "" then
Test_Type.TT_Info.Nesting := new String'(Test_Package);
else
Test_Type.TT_Info.Nesting := new String'
(Test_Package & "." &
Nesting_Difference
(Package_Info_List.Element (Pack_Cur).Name.all,
Data.Unit_Full_Name.all) &
"." & Test_Data_Unit_Name & "." & Test_Unit_Name);
end if;
Free (Nest_Dif);
Test_Type.Test_Package := new String'
(Test_Type.TT_Info.Nesting.all);
Suite_Data_List.Test_Types.Append (Test_Type);
Dummy_Type_Counter := Dummy_Type_Counter + 1;
Package_Info_List.Next (Pack_Cur);
end loop;
end;
Trace (Me, "Gathering tagged records");
Traverse (Unit, Get_Records'Access);
Trace (Me, "Gathering subprograms");
Traverse (Unit, Get_Subprograms'Access);
Decrease_Indent (Me, "Traversings finished");
if Inheritance_To_Suite then
Gather_Inherited_Subprograms
(Dummy_Type_Counter, Suite_Data_List);
end if;
if Substitution_Suite then
Gather_Substitution_Data (Suite_Data_List);
end if;
if Data.Type_Data_List.Is_Empty and Data.Subp_List.Is_Empty then
Apropriate_Source := False;
Set_Source_Status (The_Unit.Unit.Get_Filename, Processed_In_Vain);
else
Apropriate_Source := True;
end if;
declare
Cur : Subp_Data_List.Cursor;
Tmp_Subp : Subp_Info;
begin
Cur := Data.Subp_List.First;
loop
exit when Cur = Subp_Data_List.No_Element;
Tmp_Subp := Subp_Data_List.Element (Cur);
if
Data.Subp_Name_Frequency.Element
(To_Lower (Tmp_Subp.Subp_Text_Name.all)) > 1
then
Tmp_Subp.Is_Overloaded := True;
else
Tmp_Subp.Is_Overloaded := False;
end if;
Data.Subp_List.Replace_Element (Cur, Tmp_Subp);
Subp_Data_List.Next (Cur);
end loop;
end;
if Stub_Mode_ON then
Get_Units_To_Stub (The_Unit, Data);
end if;
end Gather_Data;
-----------------------
-- Gather_Test_Cases --
-----------------------
procedure Gather_Test_Cases
(Subp : Subp_Info;
TR_Info : Test_Routine_Info_Wrapper;
Data : in out Data_Holder;
Suite_Data_List : in out Suites_Data_Type;
TC_Found : out Boolean;
Instance_Sloc : String := "")
is
Me_TC : constant Trace_Handle :=
Create ("Skeletons.Test_Cases", Default => Off);
procedure Get_TC_Info_From_Pragma
(TC_Pragma : Pragma_Node;
Name : out String_Access;
Mode : out Test_Case_Mode;
Requires : out Expr;
Ensures : out Expr);
-- Processes pragma node and sets values of corresponding parameters
procedure Get_TC_Info_From_Aspect
(TC_Aspect : Aspect_Assoc;
Name : out String_Access;
Mode : out Test_Case_Mode;
Requires : out Expr;
Ensures : out Expr);
-- Processes aspect node and sets values of corresponding parameters
function Get_Condition_Image (Elem : Expr) return String;
-- Returns element image as a single line removing all double spaces
type Old_Attr_Loc is record
El : Ada_Node;
Temp_Var_Name : String_Access;
Needs_Deref : Boolean;
end record;
Old_Attr_Counter : Positive := 1;
package Source_Locations is new
Ada.Containers.Indefinite_Vectors (Positive, Old_Attr_Loc);
Old_Attr_Ref : Source_Locations.Vector;
function Replace_Old_Attribute (Elem : Expr) return String;
-- Replaces all entrances of 'old in Post with
-- Gnattest_'Old in Elem's image.
function Replace_Result_Attribute
(Post : String;
F_Name : String;
R_Name : String)
return String;
-- Replaces all entrances of function'Result in Post with R_Name
function Get_Old_Attr_Locations
(Node : Ada_Node'Class) return Visit_Status;
-- Gathers locations of 'Old attribute references through the given
-- expression and populates Old_Attr_Ref.
Subp_Add : Subp_Info;
TR_Info_Add : Test_Routine_Info_Wrapper;
TC : Test_Case_Info;
Dec : constant Basic_Decl := Subp.Subp_Declaration.As_Basic_Decl;
Next : Ada_Node;
Test_Cases : Ada_Nodes_List.List;
Requiers, Ensures : Expr;
Mode : Test_Case_Mode;
Name : String_Access;
GT_Prefix : constant String := "Gnattest_";
Params_To_Temp : String_Set.Set;
Result_Value : String_Access;
-----------------------------
-- Get_TC_Info_From_Pragma --
-----------------------------
procedure Get_TC_Info_From_Pragma
(TC_Pragma : Pragma_Node;
Name : out String_Access;
Mode : out Test_Case_Mode;
Requires : out Expr;
Ensures : out Expr)
is
Pragma_Params : constant Base_Assoc_List := F_Args (TC_Pragma);
PP_First : constant Positive :=
Pragma_Params.Base_Assoc_List_First;
Param_Expr : Expr;
P_Assoc : Pragma_Argument_Assoc;
begin
-- Name
Param_Expr :=
Pragma_Params.List_Child (PP_First).As_Pragma_Argument_Assoc.F_Expr;
if Param_Expr.Kind = Ada_String_Literal then
Name := new String'
(Encode
(Text => Param_Expr.As_String_Literal.P_Denoted_Value,
Charset => Param_Expr.Unit.Get_Charset));
else
Name := null;
Mode := Robustness;
Requires := No_Expr;
Ensures := No_Expr;
return;
end if;
-- Mode
Param_Expr :=
Pragma_Params.List_Child
(PP_First + 1).As_Pragma_Argument_Assoc.F_Expr;
if To_Lower (Node_Image (Param_Expr)) = "nominal" then
Mode := Normal;
else
Mode := Robustness;
end if;
if Pragma_Params.List_Child (PP_First + 2).Is_Null then
Requires := No_Expr;
Ensures := No_Expr;
return;
end if;
-- Requires and Ensures
P_Assoc := Pragma_Params.List_Child
(PP_First + 2).As_Pragma_Argument_Assoc;
if To_Lower (Node_Image (P_Assoc.F_Expr)) = "requires" then
Requires := P_Assoc.F_Expr;
else
Requires := No_Expr;
Ensures := P_Assoc.F_Expr;
return;
end if;
if Pragma_Params.List_Child (PP_First + 3).Is_Null then
Ensures := No_Expr;
else
Ensures :=
Pragma_Params.List_Child
(PP_First + 3).As_Pragma_Argument_Assoc.F_Expr;
end if;
end Get_TC_Info_From_Pragma;
-----------------------------
-- Get_TC_Info_From_Aspect --
-----------------------------
procedure Get_TC_Info_From_Aspect
(TC_Aspect : Aspect_Assoc;
Name : out String_Access;
Mode : out Test_Case_Mode;
Requires : out Expr;
Ensures : out Expr)
is
Aspect_Params : constant Basic_Assoc_List :=
TC_Aspect.F_Expr.As_Aggregate.F_Assocs.As_Basic_Assoc_List;
AP_First : constant Positive :=
Aspect_Params.Basic_Assoc_List_First;
Param_Expr : Expr;
A_Assoc : Aggregate_Assoc;
begin
-- Name
Param_Expr :=
Aspect_Params.List_Child (AP_First).As_Aggregate_Assoc.F_R_Expr;
if Param_Expr.Kind = Ada_String_Literal then
Name := new String'
(Encode
(Text => Param_Expr.As_String_Literal.P_Denoted_Value,
Charset => Param_Expr.Unit.Get_Charset));
else
Name := null;
Mode := Robustness;
Requires := No_Expr;
Ensures := No_Expr;
return;
end if;
-- Mode
Param_Expr :=
Aspect_Params.List_Child
(AP_First + 1).As_Aggregate_Assoc.F_R_Expr;
if To_Lower (Node_Image (Param_Expr)) = "nominal" then
Mode := Normal;
else
Mode := Robustness;
end if;
if Aspect_Params.List_Child (AP_First + 2).Is_Null then
Requires := No_Expr;
Ensures := No_Expr;
return;
end if;
-- Requires and Ensures
A_Assoc := Aspect_Params.List_Child
(AP_First + 2).As_Aggregate_Assoc;
declare
Des : constant Ada_Node_List :=
A_Assoc.F_Designators.As_Ada_Node_List;
begin
if To_Lower (Node_Image (Des.Ada_Node_List_Element
(Des.Ada_Node_List_First))) = "requires"
then
Requires := A_Assoc.F_R_Expr;
else
Requires := No_Expr;
Ensures := A_Assoc.F_R_Expr;
return;
end if;
end;
if Aspect_Params.List_Child (AP_First + 3).Is_Null then
Ensures := No_Expr;
else
Ensures :=
Aspect_Params.List_Child
(AP_First + 3).As_Aggregate_Assoc.F_R_Expr;
end if;
end Get_TC_Info_From_Aspect;
---------------------------
-- Replace_Old_Attribute --
---------------------------
function Replace_Old_Attribute (Elem : Expr) return String
is
Unprocessed_Start : Token_Reference;
Expression_End : Token_Reference;
Result : Unbounded_String;
begin
Trace (Me_TC, "Replace_Old_Attribute");
if Verbose then
Trace (Me_TC, "called for: " & Image (Elem));
end if;
if Elem.Is_Null then
return "";
end if;
Traverse (Elem, Get_Old_Attr_Locations'Access);
if Old_Attr_Ref.Is_Empty then
return Node_Image (Elem);
end if;
-- ??? While there is no proper name resolution for Identifiers from
-- Test_Case expressions that come from pragma Test_Case, it is not
-- possible to properly handle 'Old.
-- For now replace the whole expression with True.
for Par of Parents (Elem) loop
if Par.Kind = Ada_Pragma_Node then
Old_Attr_Ref.Clear;
return "True";
end if;
end loop;
Unprocessed_Start := Elem.Token_Start;
Expression_End := Elem.Token_End;
for Attr_Ref of Old_Attr_Ref loop
Append
(Result,
Encode
(Text
(Unprocessed_Start, Previous (Attr_Ref.El.Token_Start)),
Elem.Unit.Get_Charset));
if Attr_Ref.Needs_Deref then
Append (Result, Attr_Ref.Temp_Var_Name.all & ".all");
else
Append (Result, Attr_Ref.Temp_Var_Name.all);
end if;
Free (Attr_Ref.Temp_Var_Name);
Unprocessed_Start :=
Libadalang.Common.Next (Attr_Ref.El.Token_End);
end loop;
Append
(Result,
Encode
(Text (Unprocessed_Start, Expression_End),
Elem.Unit.Get_Charset));
Old_Attr_Ref.Clear;
return To_String (Result);
end Replace_Old_Attribute;
----------------------------
-- Get_Old_Attr_Locations --
----------------------------
function Get_Old_Attr_Locations
(Node : Ada_Node'Class) return Visit_Status
is
Loc : Old_Attr_Loc;
Nm : Libadalang.Analysis.Name;
Id : Identifier;
Dec : Basic_Decl;
Type_Dec : Basic_Decl;
Def : Type_Def;
Res, Obj : Type_Expr;
begin
if Node.Kind /= Ada_Attribute_Ref
or else To_Lower
(Node_Image (Node.As_Attribute_Ref.F_Attribute)) /= "old"
then
return Into;
end if;
Nm := Node.As_Attribute_Ref.F_Prefix;
Id := Nm.P_Relative_Name.As_Identifier;
Trace (Me_TC, "Resolving name " & Id.Image);
-- ??? While there is no proper name resolution for Identifiers from
-- Test_Case expressions that come from pragma Test_Case, it is not
-- possible to properly handle 'Old.
-- No need to continue processing the expression since it will be
-- replaced with "True" in Replace_Old_Attribute, just add one
-- dummy Loc.
for Par of Parents (Node) loop
if Par.Kind = Ada_Pragma_Node then
Loc.El := No_Ada_Node;
Loc.Temp_Var_Name := null;
Old_Attr_Ref.Append (Loc);
return Stop;
end if;
end loop;
Dec := Id.P_Referenced_Decl;
-- Constructing temp variable assignments
if Nm.Kind = Ada_Explicit_Deref then
Nm := Nm.As_Explicit_Deref.F_Prefix;
Loc.Needs_Deref := True;
else
Loc.Needs_Deref := False;
end if;
case Dec.Kind is
when Ada_Subp_Decl =>
Loc.Temp_Var_Name := new String'
(GT_Prefix
& Trim (Positive'Image (Old_Attr_Counter), Both)
& "_"
& Get_Subp_Name (Dec));
Res := Dec.As_Subp_Decl.F_Subp_Spec.P_Returns;
if Res.Kind = Ada_Anonymous_Type then
Def := F_Type_Def
(Res.As_Anonymous_Type.F_Type_Decl.As_Type_Decl);
if Def.Kind = Ada_Type_Access_Def then
Type_Dec := Def.As_Type_Access_Def.F_Subtype_Indication.
F_Name.P_Relative_Name.P_Referenced_Decl;
Params_To_Temp.Include
(Loc.Temp_Var_Name.all
& " : constant access "
& Encode
(Type_Dec.P_Fully_Qualified_Name,
Type_Dec.Unit.Get_Charset)
& " := "
& Node_Image (Nm)
& ";");
else
Params_To_Temp.Include
(Loc.Temp_Var_Name.all
& " : constant "
& Node_Image (Dec.As_Subp_Decl.F_Subp_Spec.P_Returns)
& " := "
& Node_Image (Nm)
& ";");
end if;
else
Type_Dec := Res.As_Subtype_Indication.F_Name.
P_Relative_Name.P_Referenced_Decl;
Params_To_Temp.Include
(Loc.Temp_Var_Name.all
& " : constant "
& Encode
(Type_Dec.P_Fully_Qualified_Name,
Type_Dec.Unit.Get_Charset)
& " := "
& Node_Image (Nm)
& ";");
end if;
when Ada_Param_Spec =>
Loc.Temp_Var_Name := new String'
(GT_Prefix
& Trim (Positive'Image (Old_Attr_Counter), Both)
& "_"
& Node_Image (Id));
Params_To_Temp.Include
(Loc.Temp_Var_Name.all
& " : constant "
& Node_Image (Dec.As_Param_Spec.F_Type_Expr)
& " := "
& Node_Image (Nm)
& ";");
when Ada_Object_Decl =>
Loc.Temp_Var_Name := new String'
(GT_Prefix
& Trim (Positive'Image (Old_Attr_Counter), Both)
& "_"
& Node_Image (Id));
Obj := Dec.As_Object_Decl.F_Type_Expr;
if Obj.Kind = Ada_Anonymous_Type then
Def := F_Type_Def
(Obj.As_Anonymous_Type.F_Type_Decl.As_Type_Decl);
if Def.Kind = Ada_Type_Access_Def then
Type_Dec := Def.As_Type_Access_Def.F_Subtype_Indication.
F_Name.P_Relative_Name.P_Referenced_Decl;
Params_To_Temp.Include
(Loc.Temp_Var_Name.all
& " : constant access "
& Encode
(Type_Dec.P_Fully_Qualified_Name,
Type_Dec.Unit.Get_Charset)
& " := "
& Node_Image (Nm)
& ";");
else
Params_To_Temp.Include
(Loc.Temp_Var_Name.all
& " : constant "
& Node_Image (Dec.As_Subp_Decl.F_Subp_Spec.P_Returns)
& " := "
& Node_Image (Nm)
& ";");
end if;
else
Type_Dec := Obj.As_Subtype_Indication.F_Name.
P_Relative_Name.P_Referenced_Decl;
Params_To_Temp.Include
(Loc.Temp_Var_Name.all
& " : constant "
& Encode
(Type_Dec.P_Fully_Qualified_Name,
Type_Dec.Unit.Get_Charset)
& " := "
& Node_Image (Nm)
& ";");
end if;
when others =>
null;
end case;
Loc.El := Node.As_Ada_Node;
Old_Attr_Counter := Old_Attr_Counter + 1;
Old_Attr_Ref.Append (Loc);
return Over;
end Get_Old_Attr_Locations;
------------------------------
-- Replace_Result_Attribute --
------------------------------
function Replace_Result_Attribute
(Post : String;
F_Name : String;
R_Name : String)
return String
is
Res : String_Access := new String'("");
Tmp : String_Access;
Quote : Boolean := False;
Subp_Is_Operator : Boolean := False;
Trying_Quote : Boolean := False;
F_Name_Length : constant Integer := F_Name'Length + 7;
Idx : Integer := Post'First;
function Eq (L, R : String) return Boolean is
(To_Lower (L) = To_Lower (R));
-- Case insensitive comparision
begin
if F_Name (F_Name'First) = '"' then
Subp_Is_Operator := True;
end if;
for I in Post'Range loop
if Post (I) = '"' then
if Quote then
if I = Post'Last or else Post (I + 1) /= '"' then
Quote := False;
end if;
else
Quote := True;
if Subp_Is_Operator then
Trying_Quote := True;
end if;
end if;
end if;
if not Quote or else Trying_Quote then
Trying_Quote := False;
if Post'Last >= I + F_Name_Length - 1 then
if Eq (Post (I .. I + F_Name_Length - 1), F_Name & "'Result")
then
Tmp := new String'
(Res.all
& Post (Idx .. I - 1)
& R_Name);
Free (Res);
Res := new String'(Tmp.all);
Free (Tmp);
Idx := I + F_Name_Length;
end if;
end if;
if Post'Last >= I + F_Name_Length then
if Eq (Post (I .. I + F_Name_Length), F_Name & "' Result")
or else Eq (Post (I .. I + F_Name_Length),
F_Name & " 'Result")
then
Tmp := new String'
(Res.all
& Post (Idx .. I - 1)
& R_Name);
Free (Res);
Res := new String'(Tmp.all);
Free (Tmp);
Idx := I + F_Name_Length + 1;
end if;
end if;
if Post'Last >= I + F_Name_Length + 1 then
if Eq (Post (I .. I + F_Name_Length + 1),
F_Name & " ' Result")
then
Tmp := new String'
(Res.all
& Post (Idx .. I - 1)
& R_Name);
Free (Res);
Res := new String'(Tmp.all);
Free (Tmp);
Idx := I + F_Name_Length + 2;
end if;
end if;
if Post'Last = I then
Tmp := new String'(Res.all & Post (Idx .. I));
Free (Res);
Res := new String'(Tmp.all);
Free (Tmp);
end if;
end if;
end loop;
return Res.all;
end Replace_Result_Attribute;
-------------------------
-- Get_Condition_Image --
-------------------------
function Get_Condition_Image (Elem : Expr) return String
is
Res, Tmp, Packed : String_Access;
Idx : Integer;
Space : Boolean;
begin
Res := new String'(Replace_Old_Attribute (Elem));
Tmp := new String'(Trim (Res.all, Both));
Free (Res);
Res := new String'(Tmp.all);
Free (Tmp);
Space := False;
Packed := new String'("");
Idx := Res'First;
for I in Res'Range loop
if Res (I) in ' ' | ASCII.CR | ASCII.LF then
if not Space then
Space := True;
Tmp := new String'(Packed.all & " " & Res (Idx .. I - 1));
Free (Packed);
Packed := new String'(Tmp.all);
Free (Tmp);
end if;
else
if Space then
Idx := I;
Space := False;
end if;
end if;
if I = Res'Last then
Tmp := new String'(Packed.all & " " & Res (Idx .. I));
Free (Packed);
Packed := new String'(Tmp.all);
Free (Tmp);
end if;
end loop;
return Trim (Packed.all, Both);
end Get_Condition_Image;
begin
Increase_Indent
(Me_TC, "Looking for test cases of " & Subp.Subp_Text_Name.all);
TC_Found := False;
Next := Dec.Next_Sibling;
while not Next.Is_Null and then Next.Kind = Ada_Pragma_Node loop
declare
Pragma_Name : constant String :=
To_Lower (Node_Image (F_Id (Next.As_Pragma_Node)));
begin
if Pragma_Name = "test_case" then
Get_TC_Info_From_Pragma
(Next.As_Pragma_Node,
Name, Mode, Requiers, Ensures);
if Name = null then
Report_Std
("warning: (gnattest) "
& Base_Name (Next.Unit.Get_Filename)
& ":"
& Trim (First_Line_Number (Next)'Img, Both)
& ":"
& Trim (First_Column_Number (Next)'Img, Both)
& ": Test_Case has complex name; skipping");
else
Free (Name);
Test_Cases.Append (Next);
end if;
elsif Pragma_Name = "pre" then
TC.Pre := List_Child
(Next.As_Pragma_Node.F_Args,
Next.As_Pragma_Node.F_Args.Base_Assoc_List_First)
.As_Pragma_Argument_Assoc.F_Expr;
elsif Pragma_Name = "post" then
TC.Post := List_Child
(Next.As_Pragma_Node.F_Args,
Next.As_Pragma_Node.F_Args.Base_Assoc_List_First)
.As_Pragma_Argument_Assoc.F_Expr;
end if;
end;
Next := Next.Next_Sibling;
end loop;
if not Dec.F_Aspects.Is_Null then
for Assoc of Dec.F_Aspects.F_Aspect_Assocs loop
declare
Aspect_Name : constant String :=
To_Lower (Node_Image (Assoc.F_Id));
begin
if Aspect_Name = "test_case" then
Get_TC_Info_From_Aspect
(Assoc.As_Aspect_Assoc,
Name, Mode, Requiers, Ensures);
if Name = null then
Report_Std
("warning: (gnattest) "
& Base_Name (Assoc.Unit.Get_Filename)
& ":"
& Trim (First_Line_Number (Assoc)'Img, Both)
& ":"
& Trim (First_Column_Number (Assoc)'Img, Both)
& ": Test_Case has complex name; skipping");
else
Free (Name);
Test_Cases.Append (Assoc.As_Ada_Node);
end if;
elsif Aspect_Name = "pre" then
TC.Pre := Assoc.F_Expr;
elsif Aspect_Name = "post" then
TC.Post := Assoc.F_Expr;
end if;
end;
end loop;
end if;
if Test_Cases.Is_Empty then
if not Test_Case_Only then
Data.Subp_List.Append (Subp);
Suite_Data_List.TR_List.Append (TR_Info);
end if;
Decrease_Indent
(Me_TC, "No test case found for " & Subp.Subp_Text_Name.all);
return;
end if;
-- At this point we are pretty sure that at least one Test_Case exists.
TC_Found := True;
Common.Has_Test_Cases := True;
for Test_Case of Test_Cases loop
Subp_Add.Has_TC_Info := True;
TC.Elem := Test_Case;
Subp_Add.Subp_Declaration := Subp.Subp_Declaration;
Subp_Add.Corresp_Type := Subp.Corresp_Type;
Subp_Add.Nesting := new String'(Subp.Nesting.all);
Subp_Add.Subp_Text_Name := new String'(Subp.Subp_Text_Name.all);
Subp_Add.Subp_Name_Image := new String'(Subp.Subp_Name_Image.all);
Subp_Add.Subp_Full_Hash := new String'(Subp.Subp_Full_Hash.all);
Subp_Add.Subp_Hash_V1 := new String'(Subp.Subp_Hash_V1.all);
Subp_Add.Subp_Hash_V2_1 := new String'(Subp.Subp_Hash_V2_1.all);
TC.Req := No_Expr;
TC.Ens := No_Expr;
if Test_Case.Kind = Ada_Pragma_Node then
Get_TC_Info_From_Pragma
(Test_Case.As_Pragma_Node,
TC.Name, TC.Mode, TC.Req, TC.Ens);
else
Get_TC_Info_From_Aspect
(Test_Case.As_Aspect_Assoc,
TC.Name, TC.Mode, TC.Req, TC.Ens);
end if;
-- Creating second part of hash code for test routine name
if TC.Mode = Normal then
declare
Full_Hash : constant String :=
GNAT.SHA1.Digest
(TC.Name.all
& "#"
& Get_Condition_Image (TC.Pre)
& "#"
& Get_Condition_Image (TC.Post)
& "#"
& Get_Condition_Image (TC.Req)
& "#"
& Get_Condition_Image (TC.Ens));
begin
TC.TC_Hash := new String'
(Full_Hash (Full_Hash'First .. Full_Hash'First + 15));
end;
else
declare
Full_Hash : constant String :=
GNAT.SHA1.Digest
(TC.Name.all
& "#"
& Get_Condition_Image (TC.Req)
& "#"
& Get_Condition_Image (TC.Ens));
begin
TC.TC_Hash := new String'
(Full_Hash (Full_Hash'First .. Full_Hash'First + 15));
end;
end if;
if Is_Function (Subp.Subp_Declaration.As_Basic_Decl) then
Result_Value := new String'
(Subp.Subp_Mangle_Name.all
& "_"
& TC.TC_Hash (TC.TC_Hash'First .. TC.TC_Hash'First + 5)
& "_Result");
end if;
Subp_Add.Subp_Mangle_Name := new String'
(Subp.Subp_Mangle_Name.all
& "_"
& TC.TC_Hash (TC.TC_Hash'First .. TC.TC_Hash'First + 5));
Params_To_Temp.Clear;
Old_Attr_Counter := 1;
if TC.Mode = Normal then
-- Requires and Pre
if TC.Req.Is_Null then
if TC.Pre.Is_Null then
TC.Req_Image := new String'("");
else
TC.Req_Image := new String'(Get_Condition_Image (TC.Pre));
end if;
else
if TC.Pre.Is_Null then
TC.Req_Image := new String'(Get_Condition_Image (TC.Req));
else
TC.Req_Image := new String'
("("
& Get_Condition_Image (TC.Pre)
& ") and ("
& Get_Condition_Image (TC.Req)
& ")");
end if;
end if;
-- Ensures and Post
if TC.Ens.Is_Null then
if TC.Post.Is_Null then
TC.Ens_Image := new String'("");
else
TC.Ens_Image := new String'(Get_Condition_Image (TC.Post));
end if;
else
if TC.Post.Is_Null then
if Result_Value = null then
TC.Ens_Image := new String'(Get_Condition_Image (TC.Ens));
else
TC.Ens_Image := new String'
(Replace_Result_Attribute
(Get_Condition_Image (TC.Ens),
Subp.Subp_Name_Image.all,
Result_Value.all));
end if;
else
if Result_Value = null then
TC.Ens_Image := new String'
("("
& Get_Condition_Image (TC.Post)
& ") and ("
& Get_Condition_Image (TC.Ens)
& ")");
else
TC.Ens_Image := new String'
(Replace_Result_Attribute
("("
& Get_Condition_Image (TC.Post)
& ") and ("
& Get_Condition_Image (TC.Ens)
& ")",
Subp.Subp_Name_Image.all,
Result_Value.all));
end if;
end if;
end if;
else
-- Requires
if TC.Req.Is_Null then
TC.Req_Image := new String'("");
else
TC.Req_Image := new String'(Get_Condition_Image (TC.Req));
end if;
-- Ensures
if TC.Ens.Is_Null then
TC.Ens_Image := new String'("");
else
if Result_Value = null then
TC.Ens_Image := new String'(Get_Condition_Image (TC.Ens));
else
TC.Ens_Image := new String'
(Replace_Result_Attribute
(Get_Condition_Image (TC.Ens),
Subp.Subp_Name_Image.all,
Result_Value.all));
end if;
end if;
end if;
Free (Result_Value);
TC.Params_To_Temp := Params_To_Temp;
Params_To_Temp.Clear;
-- adding requiers and ensures slocs
TC.Req_Line := new String'
(Base_Name (Data.Unit_File_Name.all)
& ":"
& (if TC.Req.Is_Null then "0" else
Trim (First_Line_Number (TC.Req)'Img, Both))
& ":");
TC.Ens_Line := new String'
(Base_Name (Data.Unit_File_Name.all)
& ":"
& (if TC.Ens.Is_Null then "0" else
Trim (First_Line_Number (TC.Ens)'Img, Both))
& ":");
Subp_Add.TC_Info := TC;
Data.Subp_List.Append (Subp_Add);
TR_Info_Add := TR_Info;
TR_Info_Add.TR_Info.TR_Text_Name := new String'
(Subp_Add.Subp_Mangle_Name.all);
-- Changing tested sloc so it corresponds to test case instead
-- of tested subprogram
if Instance_Sloc = "" then
TR_Info_Add.TR_Info.Tested_Sloc := new String'
(Base_Name (Data.Unit_File_Name.all)
& ":"
& Trim (First_Line_Number (TC.Elem)'Img, Both)
& ":"
& Trim (First_Column_Number (TC.Elem)'Img, Both)
& ":");
else
TR_Info_Add.TR_Info.Tested_Sloc := new String'
(Base_Name (Subp.Subp_Declaration.Unit.Get_Filename)
& ":"
& Trim (First_Line_Number (TC.Elem)'Img, Both)
& ":"
& Trim (First_Column_Number (TC.Elem)'Img, Both)
& " instance at "
& Instance_Sloc);
end if;
Suite_Data_List.TR_List.Append (TR_Info_Add);
end loop;
Decrease_Indent (Me_TC, "done");
end Gather_Test_Cases;
-------------------------------
-- Generate_Nested_Hierarchy --
-------------------------------
procedure Generate_Nested_Hierarchy (Data : Data_Holder)
is
use GNAT.OS_Lib;
Cur : Package_Info_List.Cursor := Data.Package_Data_List.First;
Output_Dir : constant String :=
Get_Source_Output_Dir (Data.Unit_File_Name.all);
begin
loop
exit when Cur = Package_Info_List.No_Element;
declare
S : constant String :=
Package_Info_List.Element (Cur).Name.all;
S_Pack : constant String :=
Data.Unit_Full_Name.all & "." &
Test_Data_Unit_Name & "." &
Test_Unit_Name & "." &
Nesting_Difference (Data.Unit_Full_Name.all, S);
begin
if
Data.Unit_Full_Name.all /= S
then
Create
(Output_Dir & Directory_Separator &
Unit_To_File_Name (S_Pack) & ".ads");
S_Put (0, "package " & S_Pack & " is");
Put_New_Line;
S_Put (0, "end " & S_Pack & ";");
Put_New_Line;
Close_File;
end if;
end;
Package_Info_List.Next (Cur);
end loop;
if not Data.Has_Simple_Case then
Create
(Output_Dir & Directory_Separator &
Unit_To_File_Name
(Data.Unit_Full_Name.all & "." &
Test_Data_Unit_Name & "." &
Test_Unit_Name) &
".ads");
S_Put
(0,
"package " & Data.Unit_Full_Name.all &
"." & Test_Data_Unit_Name & "." & Test_Unit_Name & " is");
Put_New_Line;
S_Put
(0,
"end " & Data.Unit_Full_Name.all &
"." & Test_Data_Unit_Name & "." & Test_Unit_Name & ";");
Put_New_Line;
Close_File;
Excluded_Test_Package_Bodies.Include
(Unit_To_File_Name
(Data.Unit_Full_Name.all & "."
& Test_Data_Unit_Name & "."
& Test_Unit_Name)
& ".adb");
Create
(Output_Dir & Directory_Separator &
Unit_To_File_Name
(Data.Unit_Full_Name.all & "." &
Test_Data_Unit_Name) &
".ads");
S_Put
(0,
"package " & Data.Unit_Full_Name.all &
"." & Test_Data_Unit_Name & " is");
Put_New_Line;
S_Put
(0,
"end " & Data.Unit_Full_Name.all &
"." & Test_Data_Unit_Name & ";");
Put_New_Line;
Close_File;
Excluded_Test_Package_Bodies.Include
(Unit_To_File_Name
(Data.Unit_Full_Name.all & "."
& Test_Data_Unit_Name)
& ".adb");
end if;
end Generate_Nested_Hierarchy;
-----------------------------
-- Generate_Test_Package --
-----------------------------
procedure Generate_Test_Package (Data : Data_Holder) is
Output_Dir : constant String :=
Get_Source_Output_Dir (Data.Unit_File_Name.all);
Tmp_File_Name : constant String :=
"gnattest_tmp_test_package";
Test_File_Name : String_Access;
Data_Unit_Name : String_Access;
Unit_Name : String_Access;
Unit_Pref : String_Access;
Setters_Set : String_Set.Set;
Set_Cur : String_Set.Cursor;
Subp_Cur : Subp_Data_List.Cursor;
Pack_Cur : Package_Info_List.Cursor;
Current_Type : Base_Type_Info;
-- The test type for which the primitives are
-- put togather in the corresponding test package
Test_Unit_Suffix : String_Access;
-- Generic or non-generic test package suffix or.
Actual_Test : Boolean;
-- Indicates if current test package has at least one non-abstract test
-- routine. In that case we need to include AUnit.Assertions.
Gen_Tests : Generic_Tests;
-- Used to store all test type names in case of generic tested package.
-- They are to be added at generic test storage.
Nesting_Add : String_Access;
UH : Unique_Hash;
MD : Markered_Data;
MD_Cur : Markered_Data_Maps.Cursor;
Subp_List : Subp_Data_List.List;
Current_Subp : Subp_Info;
Current_Pack : Package_Info;
TP_Map : TP_Mapping;
TP_List : TP_Mapping_List.List;
Tear_Down_Line_Add : Natural := 0;
Short_Names_Used : String_Set.Set;
package Elements_Set is new
Ada.Containers.Indefinite_Hashed_Sets (Ada_Node, Hash, "=", "=");
use Elements_Set;
Shortnamed_Subps : Elements_Set.Set;
-- overlodaing number counting
Name_Numbers : Name_Frequency.Map;
package Elem_Number_Maps is new
Ada.Containers.Indefinite_Hashed_Maps (Ada_Node, Natural, Hash, "=");
use Elem_Number_Maps;
Elem_Numbers : Elem_Number_Maps.Map;
Test_Data_Package_Name : String_Access;
-- temporary storage for slocs of test routines
type TR_SLOC_Buffer_Type is record
TPtarg : String_Access;
Test_F : String_Access;
Test_T : String_Access;
Subp : Subp_Info;
TR_Line : Natural := 1;
end record;
package TR_SLOC_Buffer_Lists is new
Ada.Containers.Doubly_Linked_Lists (TR_SLOC_Buffer_Type);
use TR_SLOC_Buffer_Lists;
TR_SLOC_Buffer : TR_SLOC_Buffer_Lists.List;
procedure Add_Buffered_TR_Slocs
(TP_List : in out TP_Mapping_List.List;
Common_Time : String);
-- Pushes buffered test routine slocs into main mapping container.
function Is_Unimplemented_Test
(TR_Text : String_Vectors.Vector) return Boolean;
-- Searches for specific text pattern which indicates that given test
-- skeleton was not modified by user after generation.
procedure Put_Test_Data_Header;
procedure Put_TP_Header (TD_Package_Name : String);
type Persistent_Section_Type is
(With_Clauses, -- /00/
Body_Declarations, -- /01/
Body_Statements); -- /02/
procedure Put_Persistent_Section (PS_Type : Persistent_Section_Type);
-- Puts persistent section of given kind surrounded with read-only
-- markers and corresponding specific Id.
function Markered_Data_Map_Is_Empty return Boolean;
-- Check if Markered_Data_Map is empty or the only element present is
-- actually the Body_Statements persistent block.
procedure Put_Stub_Data_Import;
-- Put with and use clauses for Stub_Data packages of units stubbed
-- for current UUT.
procedure Put_Persistent_Section (PS_Type : Persistent_Section_Type) is
UH : Unique_Hash;
MD : Markered_Data;
MD_Cur : Markered_Data_Maps.Cursor;
begin
S_Put (0, "-- begin read only");
New_Line_Count;
case PS_Type is
when With_Clauses =>
S_Put (0, "-- id:" & Hash_Version & "/00/");
when Body_Declarations =>
S_Put (0, "-- id:" & Hash_Version & "/01/");
when Body_Statements =>
S_Put (0, "-- id:" & Hash_Version & "/02/");
end case;
New_Line_Count;
S_Put (0, "--");
New_Line_Count;
case PS_Type is
when With_Clauses =>
S_Put (0, "-- This section can be used to add with "
& "clauses if necessary.");
when Body_Declarations =>
S_Put (0, "-- This section can be used to add global "
& "variables and other elements.");
when Body_Statements =>
S_Put (0, "-- This section can be used to add "
& "elaboration code for the global state.");
end case;
New_Line_Count;
S_Put (0, "--");
New_Line_Count;
if PS_Type = Body_Statements then
S_Put (0, "begin");
New_Line_Count;
end if;
S_Put (0, "-- end read only");
New_Line_Count;
UH.Version := new String'(Hash_Version);
case PS_Type is
when With_Clauses =>
UH.Hash := new String'("00");
when Body_Declarations =>
UH.Hash := new String'("01");
when Body_Statements =>
UH.Hash := new String'("02");
end case;
UH.TC_Hash := new String'("");
MD_Cur := Find (Markered_Data_Map, UH);
if MD_Cur /= Markered_Data_Maps.No_Element then
MD := Markered_Data_Maps.Element (MD_Cur);
for I in MD.TR_Text.First_Index .. MD.TR_Text.Last_Index loop
S_Put (0, MD.TR_Text.Element (I));
New_Line_Count;
end loop;
Markered_Data_Map.Delete (MD_Cur);
else
if PS_Type = Body_Statements then
S_Put (3, "null;");
end if;
New_Line_Count;
end if;
S_Put (0, "-- begin read only");
New_Line_Count;
S_Put (0, "-- end read only");
New_Line_Count;
end Put_Persistent_Section;
procedure Add_Buffered_TR_Slocs
(TP_List : in out TP_Mapping_List.List;
Common_Time : String)
is
Cur : TR_SLOC_Buffer_Lists.Cursor := TR_SLOC_Buffer.First;
begin
loop
exit when Cur = TR_SLOC_Buffer_Lists.No_Element;
if TR_SLOC_Buffer_Lists.Element (Cur).Test_T /= null then
Add_TR
(TP_List,
TR_SLOC_Buffer_Lists.Element (Cur).TPtarg.all,
TR_SLOC_Buffer_Lists.Element (Cur).Test_F.all,
"modified",
TR_SLOC_Buffer_Lists.Element (Cur).Subp,
TR_SLOC_Buffer_Lists.Element (Cur).TR_Line);
else
Add_TR
(TP_List,
TR_SLOC_Buffer_Lists.Element (Cur).TPtarg.all,
TR_SLOC_Buffer_Lists.Element (Cur).Test_F.all,
Common_Time,
TR_SLOC_Buffer_Lists.Element (Cur).Subp,
TR_SLOC_Buffer_Lists.Element (Cur).TR_Line);
end if;
TR_SLOC_Buffer_Lists.Next (Cur);
end loop;
TR_SLOC_Buffer.Clear;
end Add_Buffered_TR_Slocs;
function Is_Unimplemented_Test
(TR_Text : String_Vectors.Vector) return Boolean
is
Unimplemented_Line : constant String :=
"""Test not implemented.""";
begin
if TR_Text.Is_Empty then
return True;
end if;
for I in TR_Text.First_Index .. TR_Text.Last_Index loop
if Index (TR_Text.Element (I), Unimplemented_Line) /= 0 then
return True;
end if;
end loop;
return False;
end Is_Unimplemented_Test;
function Markered_Data_Map_Is_Empty return Boolean is
use Ada.Containers;
begin
if Markered_Data_Map.Is_Empty then
return True;
elsif Markered_Data_Map.Length = 1
and then Markered_Data_Map.First_Key.Hash.all = "02"
then
return True;
else
return False;
end if;
end Markered_Data_Map_Is_Empty;
procedure Put_Test_Data_Header is
begin
S_Put
(0,
"-- This package is intended to set up and tear down "
& " the test environment.");
Put_New_Line;
S_Put
(0,
"-- Once created by GNATtest, this package will "
& "never be overwritten");
Put_New_Line;
S_Put
(0,
"-- automatically. Contents of this package can be "
& "modified in any way");
Put_New_Line;
S_Put
(0,
"-- except for sections surrounded by a 'read only' marker.");
Put_New_Line;
Put_New_Line;
end Put_Test_Data_Header;
procedure Put_TP_Header (TD_Package_Name : String) is
begin
S_Put
(0,
"-- This package has been generated automatically by GNATtest.");
New_Line_Count;
S_Put
(0,
"-- You are allowed to add your code to the bodies "
& "of test routines.");
New_Line_Count;
S_Put
(0,
"-- Such changes will be kept during further regeneration "
& "of this file.");
New_Line_Count;
S_Put
(0,
"-- All code placed outside of test routine bodies "
& "will be lost. The");
New_Line_Count;
S_Put
(0,
"-- code intended to set up and tear down the test "
& "environment should be");
New_Line_Count;
S_Put
(0,
"-- placed into "
& TD_Package_Name & ".");
New_Line_Count;
New_Line_Count;
end Put_TP_Header;
procedure Put_Stub_Data_Import is
S_Cur : Ada_Nodes_List.Cursor := Data.Units_To_Stub.First;
Tmp : Unbounded_String;
Def_Name : Defining_Name;
use Ada_Nodes_List;
begin
while S_Cur /= Ada_Nodes_List.No_Element loop
Tmp := To_Unbounded_String
(Element (S_Cur).Unit.Get_Filename);
if
Source_Stubbed (To_String (Tmp)) and then
not Excluded_Test_Data_Files.Contains
(Base_Name
(Get_Source_Stub_Data_Spec (To_String (Tmp))))
then
Def_Name :=
Ada_Nodes_List.Element
(S_Cur).As_Basic_Decl.P_Defining_Name;
S_Put
(0,
"with "
& Node_Image (Def_Name)
& "."
& Stub_Data_Unit_Name
& "; use "
& Node_Image (Def_Name)
& "."
& Stub_Data_Unit_Name
& ";");
New_Line_Count;
end if;
Next (S_Cur);
end loop;
end Put_Stub_Data_Import;
use GNAT.OS_Lib;
begin
if not Generate_Separates then
Test_Info.Include (Data.Unit_File_Name.all, 0);
end if;
Test_Unit_Suffix := new String'(Test_Unit_Name_Suff);
if Data.Is_Generic then
Gen_Tests.Gen_Unit_Full_Name := new String'(Data.Unit_Full_Name.all);
end if;
for I in
Data.Type_Data_List.First_Index .. Data.Type_Data_List.Last_Index
loop
Current_Type := Data.Type_Data_List.Element (I);
-- setting up current package
Pack_Cur := Data.Package_Data_List.First;
loop
exit when Pack_Cur = Package_Info_List.No_Element;
Current_Pack := Package_Info_List.Element (Pack_Cur);
if Current_Type.Nesting.all = Current_Pack.Name.all then
exit;
end if;
Pack_Cur := Package_Info_List.Next (Pack_Cur);
end loop;
Actual_Test := False;
if Data.Unit_Full_Name.all = Current_Type.Nesting.all then
Unit_Pref := new String'(Data.Unit_Full_Name.all);
else
Unit_Pref := new String'
(Data.Unit_Full_Name.all & "." &
Test_Data_Unit_Name & "." &
Test_Unit_Name & "." &
Nesting_Difference
(Data.Unit_Full_Name.all,
Current_Type.Nesting.all));
end if;
Data_Unit_Name := new String'
(Unit_Pref.all & "." &
Current_Type.Main_Type_Text_Name.all &
Test_Data_Unit_Name_Suff);
Test_File_Name := new String'(Unit_To_File_Name (Data_Unit_Name.all));
-- saving test data package name for further reference
Test_Data_Package_Name := new String'(Data_Unit_Name.all);
if not Is_Regular_File
(Output_Dir & Directory_Separator & Test_File_Name.all & ".ads")
then
Create
(Output_Dir & Directory_Separator & Test_File_Name.all & ".ads");
Put_Test_Data_Header;
if not Current_Type.Has_Argument_Father then
if Current_Pack.Data_Kind = Instantiation then
S_Put
(0,
"with "
& Current_Pack.Generic_Containing_Package.all
& "."
& Current_Type.Main_Type_Text_Name.all
& Test_Data_Unit_Name_Suff
& ";");
Put_New_Line;
S_Put
(0,
"with "
& Current_Pack.Generic_Containing_Package.all
& "."
& Current_Type.Main_Type_Text_Name.all
& Test_Data_Unit_Name_Suff
& "."
& Current_Type.Main_Type_Text_Name.all
& Test_Unit_Name_Suff
& ";");
end if;
Put_New_Line;
S_Put (0, "with AUnit.Test_Fixtures;");
else
if
Current_Type.Argument_Father_Unit_Name.all =
Current_Type.Argument_Father_Nesting.all
then
S_Put
(0,
"with " &
Current_Type.Argument_Father_Unit_Name.all &
"." &
Current_Type.Argument_Father_Type_Name.all &
Test_Data_Unit_Name_Suff &
"." &
Current_Type.Argument_Father_Type_Name.all &
Test_Unit_Suffix.all &
";");
else
S_Put
(0,
"with " &
Current_Type.Argument_Father_Unit_Name.all &
"." &
Test_Data_Unit_Name &
"." &
Test_Unit_Name &
"." &
Nesting_Difference
(Current_Type.Argument_Father_Unit_Name.all,
Current_Type.Argument_Father_Nesting.all) &
"." &
Current_Type.Argument_Father_Type_Name.all &
Test_Data_Unit_Name_Suff &
"." &
Current_Type.Argument_Father_Type_Name.all &
Test_Unit_Suffix.all &
";");
end if;
end if;
Put_New_Line;
Put_New_Line;
S_Put (0, "with GNATtest_Generated;");
Put_New_Line;
Put_New_Line;
if Current_Pack.Is_Generic then
S_Put (0, "generic");
Put_New_Line;
S_Put
(3,
"type GNATtest_Test_Type is new "
& "AUnit.Test_Fixtures.Test_Fixture");
Put_New_Line;
S_Put (5, "with private;");
Put_New_Line;
end if;
S_Put (0, "package " & Data_Unit_Name.all & " is");
Put_New_Line;
Put_New_Line;
if Current_Pack.Data_Kind = Declaration_Data then
if Current_Type.Has_Argument_Father then
-- Declaring test type extension from another test type.
S_Put (0, GT_Marker_Begin);
Put_New_Line;
S_Put
(3,
"type Test_" &
Current_Type.Main_Type_Text_Name.all);
if Current_Type.Main_Type_Abstract then
S_Put (0, " is abstract new");
else
S_Put (0, " is new");
end if;
Put_New_Line;
if
Current_Type.Argument_Father_Unit_Name.all /=
Current_Type.Argument_Father_Nesting.all
then
Nesting_Add := new String'
(Test_Data_Unit_Name & "." &
Test_Unit_Name & "." &
Nesting_Difference
(Current_Type.Argument_Father_Unit_Name.all,
Current_Type.Argument_Father_Nesting.all) &
".");
else
Nesting_Add := new String'("");
end if;
S_Put
(5,
"GNATtest_Generated.GNATtest_Standard." &
Current_Type.Argument_Father_Unit_Name.all &
"." &
Nesting_Add.all &
Current_Type.Argument_Father_Type_Name.all &
Test_Data_Unit_Name_Suff &
"." &
Current_Type.Argument_Father_Type_Name.all &
Test_Unit_Suffix.all &
".Test_" &
Current_Type.Argument_Father_Type_Name.all);
Put_New_Line;
S_Put (0, GT_Marker_End);
Put_New_Line;
S_Put (3, "with null record;");
Free (Nesting_Add);
else
-- Declaring access type to tested type.
S_Put
(3,
"type " &
Current_Type.Main_Type_Text_Name.all &
"_Access is access all " &
"GNATtest_Generated.GNATtest_Standard." &
Current_Type.Nesting.all &
"." &
Current_Type.Main_Type_Text_Name.all &
"'Class;");
Put_New_Line;
Put_New_Line;
-- Declaring root test type.
S_Put (0, GT_Marker_Begin);
Put_New_Line;
S_Put
(3,
"type Test_" &
Current_Type.Main_Type_Text_Name.all &
" is");
if Current_Type.Main_Type_Abstract then
S_Put (0, " abstract");
end if;
S_Put (0, " new AUnit.Test_Fixtures.Test_Fixture");
Put_New_Line;
S_Put (0, GT_Marker_End);
Put_New_Line;
S_Put (3, "with record");
Put_New_Line;
S_Put
(6,
"Fixture : " &
Current_Type.Main_Type_Text_Name.all &
"_Access;");
Put_New_Line;
S_Put (3, "end record;");
end if;
else
S_Put (0, GT_Marker_Begin);
Put_New_Line;
S_Put
(3,
"type Test_" &
Current_Type.Main_Type_Text_Name.all &
" is");
S_Put (0, " new AUnit.Test_Fixtures.Test_Fixture");
Put_New_Line;
S_Put (0, GT_Marker_End);
Put_New_Line;
S_Put (3, "with null record;");
end if;
Put_New_Line;
Put_New_Line;
if not Current_Type.Main_Type_Abstract then
S_Put
(3,
"procedure Set_Up (Gnattest_T : in out Test_" &
Current_Type.Main_Type_Text_Name.all &
");");
Put_New_Line;
S_Put
(3,
"procedure Tear_Down (Gnattest_T : in out Test_" &
Current_Type.Main_Type_Text_Name.all &
");");
Put_New_Line;
Put_New_Line;
end if;
if Current_Pack.Data_Kind = Instantiation then
S_Put (0, GT_Marker_Begin);
Put_New_Line;
S_Put
(3,
"package Gnattest_Data_Inst is new "
& "GNATtest_Generated.GNATtest_Standard."
& Current_Pack.Name.all
& "."
& Current_Type.Main_Type_Text_Name.all
& Test_Data_Unit_Name_Suff
& " (Test_"
& Current_Type.Main_Type_Text_Name.all
& ");");
Put_New_Line;
S_Put
(3,
"package Gnattest_Tests_Inst is new Gnattest_Data_Inst."
& Current_Type.Main_Type_Text_Name.all
& Test_Unit_Name_Suff
& ";");
Put_New_Line;
Put_New_Line;
S_Put
(3,
"type New_Test is new Gnattest_Tests_Inst.Test_"
& Current_Type.Main_Type_Text_Name.all
& " with null record;");
Put_New_Line;
S_Put (0, GT_Marker_End);
Put_New_Line;
Put_New_Line;
S_Put
(3,
"procedure User_Set_Up (Gnattest_T : in out New_Test);");
Put_New_Line;
S_Put
(3,
"procedure User_Tear_Down "
& "(Gnattest_T : in out New_Test);");
Put_New_Line;
Put_New_Line;
end if;
if Current_Pack.Is_Generic then
S_Put
(3,
"procedure User_Set_Up (Gnattest_T : in out Test_"
& Current_Type.Main_Type_Text_Name.all
& ");");
Put_New_Line;
S_Put
(3,
"procedure User_Tear_Down (Gnattest_T : in out Test_"
& Current_Type.Main_Type_Text_Name.all
& ");");
Put_New_Line;
Put_New_Line;
end if;
S_Put (0, "end " & Data_Unit_Name.all & ";");
Put_New_Line;
Close_File;
end if;
if not Current_Type.Main_Type_Abstract and then
not Is_Regular_File
(Output_Dir & Directory_Separator & Test_File_Name.all & ".adb")
then
Create
(Output_Dir & Directory_Separator & Test_File_Name.all & ".adb");
Put_Test_Data_Header;
S_Put (0, "package body " & Data_Unit_Name.all & " is");
Put_New_Line;
Put_New_Line;
if Current_Pack.Data_Kind = Declaration_Data then
if Current_Type.No_Default_Discriminant then
S_Put
(3,
"-- Local_" &
Current_Type.Main_Type_Text_Name.all &
" : aliased " &
"GNATtest_Generated.GNATtest_Standard." &
Current_Type.Nesting.all &
"." &
Current_Type.Main_Type_Text_Name.all &
";");
else
S_Put
(3,
"Local_" &
Current_Type.Main_Type_Text_Name.all &
" : aliased " &
"GNATtest_Generated.GNATtest_Standard." &
Current_Type.Nesting.all &
"." &
Current_Type.Main_Type_Text_Name.all &
";");
end if;
Put_New_Line;
end if;
S_Put
(3,
"procedure Set_Up (Gnattest_T : in out Test_" &
Current_Type.Main_Type_Text_Name.all &
") is");
Put_New_Line;
if Current_Pack.Data_Kind = Declaration_Data then
if Current_Pack.Is_Generic then
S_Put
(6,
"X : Test_"
& Current_Type.Main_Type_Text_Name.all
& "'Class renames Test_"
& Current_Type.Main_Type_Text_Name.all
& "'Class (Gnattest_T);");
Put_New_Line;
end if;
end if;
S_Put (3, "begin");
Put_New_Line;
if Current_Type.Has_Argument_Father then
if
Current_Type.Argument_Father_Unit_Name.all /=
Current_Type.Argument_Father_Nesting.all
then
Nesting_Add := new String'
(Test_Data_Unit_Name & "." &
Test_Unit_Name & "." &
Nesting_Difference
(Current_Type.Argument_Father_Unit_Name.all,
Current_Type.Argument_Father_Nesting.all) &
".");
else
Nesting_Add := new String'("");
end if;
S_Put
(6,
"GNATtest_Generated.GNATtest_Standard." &
Current_Type.Argument_Father_Unit_Name.all &
"." &
Nesting_Add.all &
Current_Type.Argument_Father_Type_Name.all &
Test_Data_Unit_Name_Suff &
"." &
Current_Type.Argument_Father_Type_Name.all &
Test_Unit_Suffix.all &
".Set_Up");
Put_New_Line;
S_Put
(8,
"(GNATtest_Generated.GNATtest_Standard." &
Current_Type.Argument_Father_Unit_Name.all &
"." &
Nesting_Add.all &
Current_Type.Argument_Father_Type_Name.all &
Test_Data_Unit_Name_Suff &
"." &
Current_Type.Argument_Father_Type_Name.all &
Test_Unit_Suffix.all &
".Test_" &
Current_Type.Argument_Father_Type_Name.all &
" (Gnattest_T));");
Put_New_Line;
Free (Nesting_Add);
end if;
if Current_Pack.Data_Kind = Declaration_Data then
if Current_Type.No_Default_Discriminant then
S_Put
(6, "null;");
Put_New_Line;
S_Put
(6, "-- Gnattest_T.Fixture := Local_" &
Current_Type.Main_Type_Text_Name.all &
"'Access;");
Put_New_Line;
else
S_Put
(6, "Gnattest_T.Fixture := Local_" &
Current_Type.Main_Type_Text_Name.all &
"'Access;");
Put_New_Line;
if Current_Pack.Data_Kind = Declaration_Data then
if Current_Pack.Is_Generic then
S_Put (6, "User_Set_Up (X);");
Put_New_Line;
end if;
end if;
end if;
else
S_Put
(6, "null;");
Put_New_Line;
end if;
S_Put (3, "end Set_Up;");
Put_New_Line;
Put_New_Line;
S_Put
(3,
"procedure Tear_Down (Gnattest_T : in out Test_" &
Current_Type.Main_Type_Text_Name.all &
") is");
Put_New_Line;
if Current_Pack.Data_Kind = Declaration_Data then
if Current_Pack.Is_Generic then
S_Put
(6,
"X : Test_"
& Current_Type.Main_Type_Text_Name.all
& "'Class renames Test_"
& Current_Type.Main_Type_Text_Name.all
& "'Class (Gnattest_T);");
Put_New_Line;
end if;
end if;
S_Put (3, "begin");
Put_New_Line;
if Current_Type.Has_Argument_Father then
if
Current_Type.Argument_Father_Unit_Name.all /=
Current_Type.Argument_Father_Nesting.all
then
Nesting_Add := new String'
(Test_Data_Unit_Name & "." &
Test_Unit_Name & "." &
Nesting_Difference
(Current_Type.Argument_Father_Unit_Name.all,
Current_Type.Argument_Father_Nesting.all) &
".");
else
Nesting_Add := new String'("");
end if;
S_Put
(6,
"GNATtest_Generated.GNATtest_Standard." &
Current_Type.Argument_Father_Unit_Name.all &
"." &
Nesting_Add.all &
Current_Type.Argument_Father_Type_Name.all &
Test_Data_Unit_Name_Suff &
"." &
Current_Type.Argument_Father_Type_Name.all &
Test_Unit_Suffix.all &
".Tear_Down");
Put_New_Line;
S_Put
(8,
"(GNATtest_Generated.GNATtest_Standard." &
Current_Type.Argument_Father_Unit_Name.all &
"." &
Nesting_Add.all &
Current_Type.Argument_Father_Type_Name.all &
Test_Data_Unit_Name_Suff &
"." &
Current_Type.Argument_Father_Type_Name.all &
Test_Unit_Suffix.all &
".Test_" &
Current_Type.Argument_Father_Type_Name.all &
" (Gnattest_T));");
Free (Nesting_Add);
else
if Current_Pack.Data_Kind = Declaration_Data
and then Current_Pack.Is_Generic
then
S_Put (6, "User_Tear_Down (X);");
else
S_Put
(6, "null;");
end if;
end if;
Put_New_Line;
S_Put (3, "end Tear_Down;");
Put_New_Line;
Put_New_Line;
if Current_Pack.Data_Kind = Instantiation then
S_Put
(3,
"procedure User_Set_Up "
& "(Gnattest_T : in out New_Test) is");
Put_New_Line;
S_Put (6, "pragma Unreferenced (Gnattest_T);");
Put_New_Line;
S_Put (3, "begin");
Put_New_Line;
S_Put (6, "null;");
Put_New_Line;
S_Put (3, "end User_Set_Up;");
Put_New_Line;
Put_New_Line;
S_Put
(3,
"procedure User_Tear_Down "
& "(Gnattest_T : in out New_Test) is");
Put_New_Line;
S_Put (6, "pragma Unreferenced (Gnattest_T);");
Put_New_Line;
S_Put (3, "begin");
Put_New_Line;
S_Put (6, "null;");
Put_New_Line;
S_Put (3, "end User_Tear_Down;");
Put_New_Line;
Put_New_Line;
end if;
if Current_Pack.Is_Generic then
S_Put
(3,
"procedure User_Set_Up (Gnattest_T : in out Test_"
& Current_Type.Main_Type_Text_Name.all
& ") is");
Put_New_Line;
S_Put (3, "begin");
Put_New_Line;
S_Put (6, "null;");
Put_New_Line;
S_Put (3, "end User_Set_Up;");
Put_New_Line;
Put_New_Line;
S_Put
(3,
"procedure User_Tear_Down (Gnattest_T : in out Test_"
& Current_Type.Main_Type_Text_Name.all
& ") is");
Put_New_Line;
S_Put (3, "begin");
Put_New_Line;
S_Put (6, "null;");
Put_New_Line;
S_Put (3, "end User_Tear_Down;");
Put_New_Line;
Put_New_Line;
end if;
S_Put (0, "end " & Data_Unit_Name.all & ";");
Put_New_Line;
Close_File;
end if;
TP_Map.SetUp_Name := new String'(Test_File_Name.all & ".adb");
TP_Map.TearDown_Name := new String'(Test_File_Name.all & ".adb");
TP_Map.SetUp_Line := 9;
TP_Map.SetUp_Column := 4;
Tear_Down_Line_Add := 0;
if Current_Type.No_Default_Discriminant then
Tear_Down_Line_Add := Tear_Down_Line_Add + 1;
end if;
if Current_Type.Has_Argument_Father then
Tear_Down_Line_Add := Tear_Down_Line_Add + 1;
end if;
TP_Map.TearDown_Line := 14 + Tear_Down_Line_Add;
TP_Map.TearDown_Column := 4;
Free (Test_File_Name);
Unit_Name := new
String'(Unit_Pref.all &
"." &
Current_Type.Main_Type_Text_Name.all &
Test_Data_Unit_Name_Suff &
"." &
Current_Type.Main_Type_Text_Name.all &
Test_Unit_Name_Suff);
Free (Unit_Pref);
Test_File_Name := new String'(Unit_To_File_Name (Unit_Name.all));
----------------------------------
-- Creating test package spec --
----------------------------------
Create
(Output_Dir & Directory_Separator & Test_File_Name.all & ".ads");
Put_Harness_Header;
S_Put (0, GT_Marker_Begin);
Put_New_Line;
S_Put (0, "with GNATtest_Generated;");
Put_New_Line;
if Stub_Mode_ON then
S_Put (0, "with AUnit.Test_Caller;");
Put_New_Line;
end if;
Put_New_Line;
if Current_Pack.Is_Generic then
S_Put (0, "generic");
Put_New_Line;
declare
GP : Generic_Package;
begin
GP.Name := new String'(Current_Pack.Name.all);
GP.Sloc := new String'
(Base_Name (Data.Unit_File_Name.all)
& ":"
& Trim
(First_Line_Number (Current_Pack.Element)'Img,
Both)
& ":"
& Trim
(First_Column_Number (Current_Pack.Element)'Img,
Both));
Update_Generic_Packages (GP);
end;
end if;
S_Put (0, "package " & Unit_Name.all & " is");
Put_New_Line;
Put_New_Line;
if Current_Pack.Data_Kind = Declaration_Data then
S_Put
(3,
"type Test_" &
Current_Type.Main_Type_Text_Name.all);
if Current_Type.Main_Type_Abstract then
S_Put (0, " is abstract new");
else
S_Put (0, " is new");
end if;
Put_New_Line;
if Data.Unit_Full_Name.all = Current_Type.Nesting.all then
S_Put
(5,
"GNATtest_Generated.GNATtest_Standard." &
Data.Unit_Full_Name.all &
"." &
Current_Type.Main_Type_Text_Name.all &
Test_Data_Unit_Name_Suff &
".Test_" &
Current_Type.Main_Type_Text_Name.all &
" with null record;");
else
S_Put
(5,
"GNATtest_Generated.GNATtest_Standard." &
Data.Unit_Full_Name.all &
"." &
Test_Data_Unit_Name &
"." &
Test_Unit_Name &
"." &
Nesting_Difference
(Data.Unit_Full_Name.all,
Current_Type.Nesting.all) &
"." &
Current_Type.Main_Type_Text_Name.all &
Test_Data_Unit_Name_Suff &
".Test_" &
Current_Type.Main_Type_Text_Name.all &
" with null record;");
end if;
else
S_Put
(3,
"type Test_"
& Current_Type.Main_Type_Text_Name.all
& " is new GNATtest_Generated.GNATtest_Standard."
& Data_Unit_Name.all & ".New_Test with null record;");
Update_Generic_Packages
(Current_Pack.Generic_Containing_Package.all);
end if;
Put_New_Line;
Put_New_Line;
-- Adding test routine declarations.
if Current_Pack.Data_Kind = Declaration_Data then
Subp_Cur := Data.Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
if
Subp_Data_List.Element (Subp_Cur).Corresp_Type =
Current_Type.Type_Number
then
S_Put
(3,
"procedure "
& Subp_Data_List.Element
(Subp_Cur).Subp_Mangle_Name.all
& " (Gnattest_T : in out Test_"
& Current_Type.Main_Type_Text_Name.all
& ");");
Actual_Test := True;
Put_New_Line;
Print_Comment_Declaration
(Subp_Data_List.Element (Subp_Cur), 3);
Put_New_Line;
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
end if;
if Stub_Mode_ON then
S_Put
(3,
"package Caller is new AUnit.Test_Caller (Test_"
& Current_Type.Main_Type_Text_Name.all
& ");");
Put_New_Line;
Put_New_Line;
end if;
S_Put (0, "end " & Unit_Name.all & ";");
Put_New_Line;
S_Put (0, GT_Marker_End);
Put_New_Line;
Close_File;
if not Current_Type.Main_Type_Abstract then
TP_Map.TP_Name := new String'(Test_File_Name.all & ".ads");
TP_List.Append (TP_Map);
end if;
----------------------------------
-- Creating test package body --
----------------------------------
if Actual_Test then
Reset_Line_Counter;
if Generate_Separates then
Create
(Output_Dir
& Directory_Separator
& Test_File_Name.all
& ".adb");
Put_Harness_Header;
else
Get_Subprograms_From_Package
(Output_Dir
& Directory_Separator
& Test_File_Name.all
& ".adb");
Create (Tmp_File_Name);
Put_TP_Header (Test_Data_Package_Name.all);
-- gathering transition data
if Transition then
Subp_Cur := Data.Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
Current_Subp := Subp_Data_List.Element (Subp_Cur);
if
Current_Subp.Corresp_Type = Current_Type.Type_Number
then
UH.Version := new String'("1");
UH.Hash := new String'
(Subp_Data_List.Element
(Subp_Cur).Subp_Hash_V1.all);
if
Subp_Data_List.Element (Subp_Cur).Has_TC_Info
then
UH.TC_Hash := new String'
(Subp_Data_List.Element
(Subp_Cur).TC_Info.TC_Hash.all);
else
UH.TC_Hash := new String'("");
end if;
Current_Subp := Subp_Data_List.Element (Subp_Cur);
Get_Subprogram_From_Separate
(Output_Dir
& Directory_Separator
& Unit_To_File_Name
(Unit_Name.all
& "."
& Test_Routine_Prefix
& Current_Subp.Subp_Text_Name.all
& "_"
& Current_Subp.Subp_Hash_V1
(Current_Subp.Subp_Hash_V1'First ..
Current_Subp.Subp_Hash_V1'First + 5)
& (if Current_Subp.Has_TC_Info
then "_" & Current_Subp.TC_Info.TC_Hash
(Current_Subp.TC_Info.TC_Hash'First ..
Current_Subp.TC_Info.TC_Hash'First + 5)
else ""))
& ".adb",
UH,
Current_Subp);
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
end if;
-- gathering used short names
Subp_Cur := Data.Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
Current_Subp := Subp_Data_List.Element (Subp_Cur);
if
Current_Subp.Corresp_Type = Current_Type.Type_Number
then
UH.Version := new String'(Hash_Version);
UH.Hash := new String'
(Current_Subp.Subp_Full_Hash.all);
if
Current_Subp.Has_TC_Info
then
UH.TC_Hash := new String'
(Sanitize_TC_Name (Current_Subp.TC_Info.Name.all));
else
UH.TC_Hash := new String'("");
end if;
MD_Cur := Find (Markered_Data_Map, UH);
if MD_Cur /= Markered_Data_Maps.No_Element then
MD := Markered_Data_Maps.Element (MD_Cur);
if MD.Short_Name_Used then
Short_Names_Used.Include
(To_Lower (MD.Short_Name.all));
Shortnamed_Subps.Include
(Current_Subp.Subp_Declaration);
Name_Numbers.Include
(To_Lower (Current_Subp.Subp_Text_Name.all), 1);
Elem_Numbers.Include
(Current_Subp.Subp_Declaration, 1);
end if;
end if;
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
-- updating hash v.1 to hash v.2 where possible
Subp_Cur := Data.Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
Current_Subp := Subp_Data_List.Element (Subp_Cur);
if
Current_Subp.Corresp_Type = Current_Type.Type_Number
then
UH.Version := new String'("1");
UH.Hash := new String'
(Current_Subp.Subp_Hash_V1.all);
if
Current_Subp.Has_TC_Info
then
UH.TC_Hash := new String'
(Current_Subp.TC_Info.TC_Hash.all);
else
UH.TC_Hash := new String'("");
end if;
MD_Cur := Find (Markered_Data_Map, UH);
if MD_Cur /= Markered_Data_Maps.No_Element then
MD := Markered_Data_Maps.Element (MD_Cur);
Markered_Data_Map.Delete (MD_Cur);
Free (UH.Hash);
UH.Hash := new String'
(Current_Subp.Subp_Hash_V2_1.all);
Free (UH.Version);
UH.Version := new String'("2");
Markered_Data_Map.Include (UH, MD);
end if;
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
-- updating hash v.2 to hash v.2.1 where possible
Subp_Cur := Data.Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
Current_Subp := Subp_Data_List.Element (Subp_Cur);
if
Current_Subp.Corresp_Type = Current_Type.Type_Number
then
UH.Version := new String'("2");
UH.Hash := new String'
(Current_Subp.Subp_Hash_V2_1 .all);
if Current_Subp.Has_TC_Info then
UH.TC_Hash := new String'
(Current_Subp.TC_Info.TC_Hash.all);
else
UH.TC_Hash := new String'("");
end if;
MD_Cur := Find (Markered_Data_Map, UH);
if MD_Cur /= Markered_Data_Maps.No_Element then
MD := Markered_Data_Maps.Element (MD_Cur);
Markered_Data_Map.Delete (MD_Cur);
Free (UH.Version);
UH.Version := new String'("2.1");
if UH.TC_Hash.all /= "" then
Free (UH.TC_Hash);
UH.TC_Hash := new String'
(Sanitize_TC_Name
(Current_Subp.TC_Info.Name.all));
end if;
Markered_Data_Map.Include (UH, MD);
end if;
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
-- updating hash v.2.1 to hash v.2.2
-- and looking for new short names
Subp_Cur := Data.Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
Current_Subp := Subp_Data_List.Element (Subp_Cur);
if
Current_Subp.Corresp_Type = Current_Type.Type_Number
then
UH.Version := new String'("2.1");
UH.Hash := new String'
(Current_Subp.Subp_Hash_V2_1 .all);
if Current_Subp.Has_TC_Info then
UH.TC_Hash := new String'
(Sanitize_TC_Name
(Current_Subp.TC_Info.Name.all));
else
UH.TC_Hash := new String'("");
end if;
MD_Cur := Find (Markered_Data_Map, UH);
if MD_Cur /= Markered_Data_Maps.No_Element then
MD := Markered_Data_Maps.Element (MD_Cur);
if not
Short_Names_Used.Contains (MD.Short_Name.all)
or else Shortnamed_Subps.Contains
(Current_Subp.Subp_Declaration)
then
Short_Names_Used.Include (MD.Short_Name.all);
Shortnamed_Subps.Include
(Current_Subp.Subp_Declaration);
Name_Numbers.Include
(To_Lower (Current_Subp.Subp_Text_Name.all), 1);
Elem_Numbers.Include
(Current_Subp.Subp_Declaration, 1);
MD.Short_Name_Used := True;
end if;
Markered_Data_Map.Delete (MD_Cur);
Free (UH.Hash);
UH.Hash := new String'
(Current_Subp.Subp_Full_Hash.all);
Free (UH.Version);
UH.Version := new String'(Hash_Version);
Markered_Data_Map.Include (UH, MD);
end if;
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
-- creating markered_data and deciding on new short names
Subp_Cur := Data.Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
Current_Subp := Subp_Data_List.Element (Subp_Cur);
if
Current_Subp.Corresp_Type = Current_Type.Type_Number
then
UH.Version := new String'(Hash_Version);
UH.Hash := new String'
(Current_Subp.Subp_Full_Hash.all);
if Current_Subp.Has_TC_Info then
UH.TC_Hash := new String'
(Sanitize_TC_Name (Current_Subp.TC_Info.Name.all));
else
UH.TC_Hash := new String'("");
end if;
MD_Cur := Find (Markered_Data_Map, UH);
if MD_Cur = Markered_Data_Maps.No_Element then
MD.Commented_Out := False;
MD.Short_Name_Used := False;
MD.Short_Name := new String'
(To_Lower (Current_Subp.Subp_Text_Name.all));
MD.TR_Text.Clear;
if
not Short_Names_Used.Contains
(To_Lower (Current_Subp.Subp_Text_Name.all))
or else Shortnamed_Subps.Contains
(Current_Subp.Subp_Declaration)
then
-- Short name is free, we can use it
MD.Short_Name_Used := True;
Short_Names_Used.Include
(To_Lower (Current_Subp.Subp_Text_Name.all));
Shortnamed_Subps.Include
(Current_Subp.Subp_Declaration);
Name_Numbers.Include
(To_Lower (Current_Subp.Subp_Text_Name.all), 1);
Elem_Numbers.Include
(Current_Subp.Subp_Declaration, 1);
-- Looking for a dangling test with same short
-- name but different hash.
MD_Cur := Find_Same_Short_Name
(Markered_Data_Map,
Current_Subp);
if MD_Cur /= Markered_Data_Maps.No_Element then
-- Using corresponding dangling test
MD.TR_Text.Clear;
MD.TR_Text :=
Markered_Data_Maps.Element (MD_Cur).TR_Text;
-- also need to copy Commented_Out since
-- the test can be dangling for a long time
-- or just become dangling
MD.Commented_Out :=
Markered_Data_Maps.Element
(MD_Cur).Commented_Out;
Markered_Data_Map.Delete (MD_Cur);
MD.Issue_Warning := True;
end if;
end if;
Markered_Data_Map.Insert (UH, MD);
end if;
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
-- setting overloading numbers;
Subp_Cur := Data.Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
Current_Subp := Subp_Data_List.Element (Subp_Cur);
if
Current_Subp.Corresp_Type = Current_Type.Type_Number
then
if
Name_Numbers.Find
(To_Lower (Current_Subp.Subp_Text_Name.all)) =
Name_Frequency.No_Element
then
Name_Numbers.Include
(To_Lower (Current_Subp.Subp_Text_Name.all), 1);
Elem_Numbers.Include
(Current_Subp.Subp_Declaration, 1);
else
if
Elem_Numbers.Find
(Current_Subp.Subp_Declaration) =
Elem_Number_Maps.No_Element
then
declare
X : constant Natural :=
Name_Numbers.Element
(To_Lower
(Current_Subp.Subp_Text_Name.all));
begin
Name_Numbers.Replace
(To_Lower (Current_Subp.Subp_Text_Name.all),
X + 1);
Elem_Numbers.Include
(Current_Subp.Subp_Declaration, X + 1);
end;
end if;
end if;
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
Name_Numbers.Clear;
end if;
S_Put (0, "with AUnit.Assertions; use AUnit.Assertions;");
New_Line_Count;
S_Put (0, "with System.Assertions;");
New_Line_Count;
if Stub_Mode_ON then
Put_Stub_Data_Import;
end if;
New_Line_Count;
Put_Persistent_Section (With_Clauses);
S_Put (0, "package body " & Unit_Name.all & " is");
New_Line_Count;
New_Line_Count;
Put_Persistent_Section (Body_Declarations);
-- Adding test routine body stubs.
Subp_Cur := Data.Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
if
Subp_Data_List.Element (Subp_Cur).Corresp_Type =
Current_Type.Type_Number
then
Current_Subp := Subp_Data_List.Element (Subp_Cur);
if Subp_Data_List.Element (Subp_Cur).Has_TC_Info then
if Is_Function
(Subp_Data_List.Element
(Subp_Cur).Subp_Declaration.As_Basic_Decl)
then
Generate_Function_Wrapper
(Subp_Data_List.Element (Subp_Cur));
else
Generate_Procedure_Wrapper
(Subp_Data_List.Element (Subp_Cur));
end if;
end if;
if Generate_Separates then
S_Put
(3,
"procedure " &
Subp_Data_List.Element
(Subp_Cur).Subp_Mangle_Name.all &
" (Gnattest_T : in out Test_" &
Current_Type.Main_Type_Text_Name.all &
") is separate;");
New_Line_Count;
Print_Comment_Declaration
(Subp_Data_List.Element (Subp_Cur), 3);
New_Line_Count;
else
Test_Info.Replace
(Data.Unit_File_Name.all,
Test_Info.Element (Data.Unit_File_Name.all) + 1);
All_Tests_Counter := All_Tests_Counter + 1;
UH.Version := new String'(Hash_Version);
UH.Hash := new String'
(Subp_Data_List.Element
(Subp_Cur).Subp_Full_Hash.all);
if Subp_Data_List.Element (Subp_Cur).Has_TC_Info then
UH.TC_Hash := new String'
(Sanitize_TC_Name
(Subp_Data_List.Element
(Subp_Cur).TC_Info.Name.all));
else
UH.TC_Hash := new String'("");
end if;
MD_Cur := Find (Markered_Data_Map, UH);
MD := Markered_Data_Maps.Element (MD_Cur);
Put_Opening_Comment_Section
(Subp_Data_List.Element (Subp_Cur),
Elem_Numbers.Element
(Current_Subp.Subp_Declaration),
Use_Short_Name => MD.Short_Name_Used,
Type_Name => Current_Type.Main_Type_Text_Name.all);
if Is_Unimplemented_Test (MD.TR_Text) then
TR_SLOC_Buffer.Append
((new String'(Test_File_Name.all & ".ads"),
new String'(Test_File_Name.all & ".adb"),
null,
Subp_Data_List.Element (Subp_Cur),
New_Line_Counter));
else
TR_SLOC_Buffer.Append
((new String'(Test_File_Name.all & ".ads"),
new String'(Test_File_Name.all & ".adb"),
new String'("modified"),
Subp_Data_List.Element (Subp_Cur),
New_Line_Counter));
end if;
if MD.TR_Text.Is_Empty then
if Stub_Mode_ON then
Setters_Set := Get_Direct_Callees_Setters
(Current_Subp.Subp_Declaration.As_Basic_Decl);
end if;
New_Tests_Counter := New_Tests_Counter + 1;
New_Line_Count;
S_Put (6, "pragma Unreferenced (Gnattest_T);");
New_Line_Count;
New_Line_Count;
S_Put (3, "begin");
New_Line_Count;
New_Line_Count;
if not Setters_Set.Is_Empty then
Set_Cur := Setters_Set.First;
while Set_Cur /= String_Set.No_Element loop
S_Put
(3,
"-- "
& String_Set.Element (Set_Cur)
& "( );");
New_Line_Count;
Next (Set_Cur);
end loop;
New_Line_Count;
Setters_Set.Clear;
end if;
S_Put (6, "AUnit.Assertions.Assert");
New_Line_Count;
S_Put
(8, "(Gnattest_Generated.Default_Assert_Value,");
New_Line_Count;
S_Put (9, """Test not implemented."");");
New_Line_Count;
New_Line_Count;
else
if MD.Issue_Warning then
Report_Std
("warning: (gnattest) "
& Base_Name (Data.Unit_File_Name.all)
& ":"
& Trim
(First_Line_Number
(Current_Subp.Subp_Declaration)'Img,
Both)
& ":"
& Trim
(First_Column_Number
(Current_Subp.Subp_Declaration)'Img,
Both)
& ": test for "
& MD.Short_Name.all
& " at "
& Unit_Name.all
& ":"
& Trim
(Integer'Image (New_Line_Counter),
Both)
& " might be out of date ("
& MD.Short_Name.all
& " has been changed)");
end if;
for I in
MD.TR_Text.First_Index .. MD.TR_Text.Last_Index
loop
if MD.Commented_Out then
S_Put
(0,
Uncomment_Line (MD.TR_Text.Element (I)));
else
S_Put (0, MD.TR_Text.Element (I));
end if;
New_Line_Count;
end loop;
end if;
Markered_Data_Map.Delete (MD_Cur);
Put_Closing_Comment_Section
(Subp_Data_List.Element (Subp_Cur),
Elem_Numbers.Element
(Current_Subp.Subp_Declaration),
Use_Short_Name => MD.Short_Name_Used);
New_Line_Count;
end if;
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
-- printing dangling tests
if not Markered_Data_Map_Is_Empty then
Report_Std
("warning: (gnattest) "
& Unit_Name.all
& " has dangling test(s)");
end if;
MD_Cur := Markered_Data_Map.First;
loop
exit when MD_Cur = Markered_Data_Maps.No_Element;
MD := Markered_Data_Maps.Element (MD_Cur);
if Markered_Data_Maps.Key (MD_Cur).Hash.all /= "02" then
declare
Stub : Subp_Info;
begin
Stub.Subp_Full_Hash := new String'
(Markered_Data_Maps.Key (MD_Cur).Hash.all);
Stub.Subp_Text_Name := new String'
(Markered_Data_Maps.Element (MD_Cur).Short_Name.all);
Stub.Subp_Mangle_Name := new String'
(Test_Routine_Prefix
& Stub.Subp_Text_Name.all
& "_"
& Stub.Subp_Full_Hash
(Stub.Subp_Full_Hash'First ..
Stub.Subp_Full_Hash'First + 5));
if Markered_Data_Maps.Key (MD_Cur).TC_Hash.all = "" then
Stub.Has_TC_Info := False;
else
Stub.Has_TC_Info := True;
Stub.TC_Info.TC_Hash := new String'
(Markered_Data_Maps.Key (MD_Cur).TC_Hash.all);
Stub.TC_Info.Name := Stub.TC_Info.TC_Hash;
end if;
Put_Opening_Comment_Section
(Stub, 0, True, False,
Current_Type.Main_Type_Text_Name.all);
Add_DT
(TP_List,
Test_File_Name.all & ".ads",
Test_File_Name.all & ".adb",
New_Line_Counter,
1);
for I in
MD.TR_Text.First_Index .. MD.TR_Text.Last_Index
loop
if MD.Commented_Out then
S_Put (0, MD.TR_Text.Element (I));
else
S_Put (0, "-- " & MD.TR_Text.Element (I));
end if;
New_Line_Count;
end loop;
Put_Closing_Comment_Section
(Stub,
Elem_Numbers.Element
(Current_Subp.Subp_Declaration),
True,
False);
New_Line_Count;
end;
end if;
Markered_Data_Maps.Next (MD_Cur);
end loop;
Put_Persistent_Section (Body_Statements);
S_Put (0, "end " & Unit_Name.all & ";");
New_Line_Count;
Close_File;
Add_Buffered_TR_Slocs
(TP_List,
Format_Time
(File_Time_Stamp
(Tmp_File_Name)));
if not Generate_Separates then
declare
Old_Package : constant String :=
Output_Dir & Directory_Separator
& Test_File_Name.all & ".adb";
Success : Boolean;
begin
if Is_Regular_File (Old_Package) then
Delete_File (Old_Package, Success);
if not Success then
Cmd_Error_No_Help ("cannot delete " & Old_Package);
end if;
end if;
Copy_File (Tmp_File_Name, Old_Package, Success);
if not Success then
Cmd_Error_No_Help
("cannot copy tmp test package to " & Old_Package);
end if;
Delete_File (Tmp_File_Name, Success);
if not Success then
Cmd_Error_No_Help ("cannot delete tmp test package");
end if;
end;
end if;
Markered_Data_Map.Clear;
end if;
Short_Names_Used.Clear;
Shortnamed_Subps.Clear;
Elem_Numbers.Clear;
end loop;
-- Simple case
if Data.Has_Simple_Case then
Pack_Cur := Data.Package_Data_List.First;
loop
exit when Pack_Cur = Package_Info_List.No_Element;
Current_Pack := Package_Info_List.Element (Pack_Cur);
Subp_Cur := Data.Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
Current_Subp := Subp_Data_List.Element (Subp_Cur);
if Current_Subp.Nesting.all = Current_Pack.Name.all then
Subp_List.Append (Current_Subp);
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
if Current_Pack.Name.all = Data.Unit_Full_Name.all then
Data_Unit_Name := new String'
(Current_Pack.Name.all & "." & Test_Data_Unit_Name);
else
Data_Unit_Name := new String'
(Data.Unit_Full_Name.all & "." &
Test_Data_Unit_Name & "." &
Test_Unit_Name & "." &
Nesting_Difference
(Current_Pack.Name.all,
Data.Unit_Full_Name.all) &
"." & Test_Data_Unit_Name);
end if;
Test_File_Name := new String'
(Unit_To_File_Name (Data_Unit_Name.all));
-- saving test data package name for further reference
Test_Data_Package_Name := new String'(Data_Unit_Name.all);
-- Generating simple test data package spec
if not Is_Regular_File
(Output_Dir & Directory_Separator & Test_File_Name.all & ".ads")
then
Create
(Output_Dir & Directory_Separator &
Test_File_Name.all & ".ads");
Put_Test_Data_Header;
if Current_Pack.Data_Kind = Instantiation then
S_Put
(0,
"with "
& Current_Pack.Generic_Containing_Package.all
& "."
& Test_Data_Unit_Name
& ";");
Put_New_Line;
S_Put
(0,
"with "
& Current_Pack.Generic_Containing_Package.all
& "."
& Test_Data_Unit_Name
& "."
& Test_Unit_Name
& ";");
else
S_Put (0, "with AUnit.Test_Fixtures;");
end if;
Put_New_Line;
Put_New_Line;
if Current_Pack.Is_Generic then
S_Put (0, "generic");
Put_New_Line;
S_Put
(3,
"type GNATtest_Test_Type is new "
& "AUnit.Test_Fixtures.Test_Fixture");
Put_New_Line;
S_Put (5, "with private;");
Put_New_Line;
end if;
S_Put (0, "package " & Data_Unit_Name.all & " is");
Put_New_Line;
Put_New_Line;
S_Put (0, GT_Marker_Begin);
Put_New_Line;
S_Put
(3,
"type Test is new AUnit.Test_Fixtures.Test_Fixture");
Put_New_Line;
S_Put (0, GT_Marker_End);
Put_New_Line;
S_Put (3, "with null record;");
Put_New_Line;
Put_New_Line;
S_Put (3, "procedure Set_Up (Gnattest_T : in out Test);");
Put_New_Line;
S_Put (3, "procedure Tear_Down (Gnattest_T : in out Test);");
Put_New_Line;
Put_New_Line;
if Current_Pack.Data_Kind = Instantiation then
S_Put (0, GT_Marker_Begin);
Put_New_Line;
S_Put
(3,
"package Gnattest_Data_Inst is new "
& "GNATtest_Generated.GNATtest_Standard."
& Current_Pack.Name.all
& "."
& Test_Data_Unit_Name
& " (Test);");
Put_New_Line;
S_Put
(3,
"package Gnattest_Tests_Inst is new Gnattest_Data_Inst."
& Test_Unit_Name
& ";");
Put_New_Line;
Put_New_Line;
S_Put
(3,
"type New_Test is new Gnattest_Tests_Inst.Test"
& " with null record;");
Put_New_Line;
S_Put (0, GT_Marker_End);
Put_New_Line;
Put_New_Line;
S_Put
(3,
"procedure User_Set_Up (Gnattest_T : in out New_Test);");
Put_New_Line;
S_Put
(3,
"procedure User_Tear_Down "
& "(Gnattest_T : in out New_Test);");
Put_New_Line;
Put_New_Line;
end if;
if Current_Pack.Is_Generic then
S_Put
(3,
"procedure User_Set_Up (Gnattest_T : in out Test);");
Put_New_Line;
S_Put
(3,
"procedure User_Tear_Down (Gnattest_T : in out Test);");
Put_New_Line;
Put_New_Line;
end if;
S_Put (0, "end " & Data_Unit_Name.all & ";");
Put_New_Line;
Close_File;
end if;
if not Is_Regular_File
(Output_Dir & Directory_Separator & Test_File_Name.all & ".adb")
then
Create
(Output_Dir & Directory_Separator &
Test_File_Name.all & ".adb");
Put_Test_Data_Header;
S_Put (0, "package body " & Data_Unit_Name.all & " is");
Put_New_Line;
Put_New_Line;
if Current_Pack.Data_Kind = Declaration_Data then
S_Put (3, "procedure Set_Up (Gnattest_T : in out Test) is");
Put_New_Line;
if Current_Pack.Is_Generic then
S_Put
(6, "X : Test'Class renames Test'Class (Gnattest_T);");
Put_New_Line;
S_Put (3, "begin");
Put_New_Line;
S_Put (6, "User_Set_Up (X);");
else
S_Put (6, "pragma Unreferenced (Gnattest_T);");
Put_New_Line;
S_Put (3, "begin");
Put_New_Line;
S_Put (6, "null;");
end if;
Put_New_Line;
S_Put (3, "end Set_Up;");
Put_New_Line;
Put_New_Line;
S_Put
(3, "procedure Tear_Down (Gnattest_T : in out Test) is");
Put_New_Line;
if Current_Pack.Is_Generic then
S_Put
(6, "X : Test'Class renames Test'Class (Gnattest_T);");
Put_New_Line;
S_Put (3, "begin");
Put_New_Line;
S_Put (6, "User_Tear_Down (X);");
else
S_Put (6, "pragma Unreferenced (Gnattest_T);");
Put_New_Line;
S_Put (3, "begin");
Put_New_Line;
S_Put (6, "null;");
end if;
Put_New_Line;
S_Put (3, "end Tear_Down;");
Put_New_Line;
Put_New_Line;
else
S_Put
(3,
"procedure Set_Up "
& "(Gnattest_T : in out Test) is");
Put_New_Line;
S_Put (6, "pragma Unreferenced (Gnattest_T);");
Put_New_Line;
S_Put (3, "begin");
Put_New_Line;
S_Put (6, "null;");
Put_New_Line;
S_Put (3, "end Set_Up;");
Put_New_Line;
Put_New_Line;
S_Put
(3,
"procedure Tear_Down "
& "(Gnattest_T : in out Test) is");
Put_New_Line;
S_Put (6, "pragma Unreferenced (Gnattest_T);");
Put_New_Line;
S_Put (3, "begin");
Put_New_Line;
S_Put (6, "null;");
Put_New_Line;
S_Put (3, "end Tear_Down;");
Put_New_Line;
Put_New_Line;
S_Put
(3,
"procedure User_Set_Up "
& "(Gnattest_T : in out New_Test) is");
Put_New_Line;
S_Put (6, "pragma Unreferenced (Gnattest_T);");
Put_New_Line;
S_Put (3, "begin");
Put_New_Line;
S_Put (6, "null;");
Put_New_Line;
S_Put (3, "end User_Set_Up;");
Put_New_Line;
Put_New_Line;
S_Put
(3,
"procedure User_Tear_Down "
& "(Gnattest_T : in out New_Test) is");
Put_New_Line;
S_Put (6, "pragma Unreferenced (Gnattest_T);");
Put_New_Line;
S_Put (3, "begin");
Put_New_Line;
S_Put (6, "null;");
Put_New_Line;
S_Put (3, "end User_Tear_Down;");
Put_New_Line;
Put_New_Line;
end if;
if Current_Pack.Is_Generic then
S_Put
(3,
"procedure User_Set_Up "
& "(Gnattest_T : in out Test) is");
Put_New_Line;
S_Put (3, "begin");
Put_New_Line;
S_Put (6, "null;");
Put_New_Line;
S_Put (3, "end User_Set_Up;");
Put_New_Line;
Put_New_Line;
S_Put
(3,
"procedure User_Tear_Down "
& "(Gnattest_T : in out Test) is");
Put_New_Line;
S_Put (3, "begin");
Put_New_Line;
S_Put (6, "null;");
Put_New_Line;
S_Put (3, "end User_Tear_Down;");
Put_New_Line;
Put_New_Line;
end if;
S_Put (0, "end " & Data_Unit_Name.all & ";");
Put_New_Line;
Close_File;
end if;
TP_Map.SetUp_Name := new String'(Test_File_Name.all & ".adb");
TP_Map.TearDown_Name := new String'(Test_File_Name.all & ".adb");
TP_Map.SetUp_Line := 8;
TP_Map.SetUp_Column := 4;
TP_Map.TearDown_Line := 14;
TP_Map.TearDown_Column := 4;
Free (Test_File_Name);
if Current_Pack.Name.all = Data.Unit_Full_Name.all then
Unit_Name := new String'
(Current_Pack.Name.all & "." &
Test_Data_Unit_Name & "." &
Test_Unit_Name);
else
Unit_Name := new String'
(Data.Unit_Full_Name.all & "." &
Test_Data_Unit_Name & "." &
Test_Unit_Name & "." &
Nesting_Difference
(Current_Pack.Name.all,
Data.Unit_Full_Name.all) &
"." & Test_Data_Unit_Name & "." & Test_Unit_Name);
end if;
Test_File_Name := new String'(Unit_To_File_Name (Unit_Name.all));
Actual_Test := False;
-- Generating simple test package spec.
Create
(Output_Dir & Directory_Separator & Test_File_Name.all & ".ads");
Put_Harness_Header;
S_Put (0, GT_Marker_Begin);
Put_New_Line;
S_Put (0, "with Gnattest_Generated;");
Put_New_Line;
if Stub_Mode_ON then
S_Put (0, "with AUnit.Test_Caller;");
Put_New_Line;
end if;
Put_New_Line;
if Current_Pack.Is_Generic then
S_Put (0, "generic");
Put_New_Line;
declare
GP : Generic_Package;
begin
GP.Name := new String'(Current_Pack.Name.all);
GP.Sloc := new String'
(Base_Name (Data.Unit_File_Name.all)
& ":"
& Trim
(First_Line_Number (Current_Pack.Element)'Img,
Both)
& ":"
& Trim
(First_Column_Number (Current_Pack.Element)'Img,
Both));
Update_Generic_Packages (GP);
end;
end if;
S_Put (0, "package " & Unit_Name.all & " is");
Put_New_Line;
Put_New_Line;
-- Declaring simple test type.
if Current_Pack.Data_Kind = Declaration_Data then
S_Put
(3,
"type Test is new GNATtest_Generated.GNATtest_Standard." &
Data_Unit_Name.all & ".Test");
else
S_Put
(3,
"type Test is new GNATtest_Generated.GNATtest_Standard." &
Data_Unit_Name.all & ".New_Test");
Update_Generic_Packages
(Current_Pack.Generic_Containing_Package.all);
end if;
Put_New_Line;
S_Put (3, "with null record;");
Put_New_Line;
Put_New_Line;
-- Adding test routine declarations.
if Current_Pack.Data_Kind = Declaration_Data then
Subp_Cur := Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then
S_Put
(3,
"procedure "
& Subp_Data_List.Element
(Subp_Cur).Subp_Mangle_Name.all
& " (Gnattest_T : in out Test);");
Put_New_Line;
Print_Comment_Declaration
(Subp_Data_List.Element (Subp_Cur),
3);
Put_New_Line;
Actual_Test := True;
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
end if;
if Stub_Mode_ON then
S_Put (3, "package Caller is new AUnit.Test_Caller (Test);");
Put_New_Line;
Put_New_Line;
end if;
S_Put (0, "end " & Unit_Name.all & ";");
Put_New_Line;
S_Put (0, GT_Marker_End);
Put_New_Line;
Close_File;
TP_Map.TP_Name := new String'(Test_File_Name.all & ".ads");
TP_List.Append (TP_Map);
Reset_Line_Counter;
-- Generating simple test package body
if Actual_Test then
if Generate_Separates then
Create
(Output_Dir
& Directory_Separator
& Test_File_Name.all
& ".adb");
Put_Harness_Header;
else
Get_Subprograms_From_Package
(Output_Dir
& Directory_Separator
& Test_File_Name.all
& ".adb");
-- updating hash v2 to v2.1 and change TC hash to TC names
Subp_Cur := Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then
UH.Version := new String'("2");
UH.Hash := new String'
(Subp_Data_List.Element
(Subp_Cur).Subp_Full_Hash.all);
if
Subp_Data_List.Element (Subp_Cur).Has_TC_Info
then
UH.TC_Hash := new String'
(Subp_Data_List.Element
(Subp_Cur).TC_Info.TC_Hash.all);
else
UH.TC_Hash := new String'("");
end if;
MD_Cur := Find (Markered_Data_Map, UH);
if MD_Cur /= Markered_Data_Maps.No_Element then
MD := Markered_Data_Maps.Element (MD_Cur);
Free (UH.Version);
UH.Version := new String'(Hash_Version);
if UH.TC_Hash.all /= "" then
Free (UH.TC_Hash);
UH.TC_Hash := new String'
(Sanitize_TC_Name
(Subp_Data_List.Element
(Subp_Cur).TC_Info.Name.all));
end if;
end if;
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
-- gathering transition data
if Transition then
Subp_Cur := Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
if
Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0
then
UH.Version := new String'("1");
UH.Hash := new String'
(Subp_Data_List.Element
(Subp_Cur).Subp_Hash_V1.all);
if
Subp_Data_List.Element (Subp_Cur).Has_TC_Info
then
UH.TC_Hash := new String'
(Subp_Data_List.Element
(Subp_Cur).TC_Info.TC_Hash.all);
else
UH.TC_Hash := new String'("");
end if;
Current_Subp := Subp_Data_List.Element (Subp_Cur);
Get_Subprogram_From_Separate
(Output_Dir
& Directory_Separator
& Unit_To_File_Name
(Unit_Name.all
& "."
& Test_Routine_Prefix
& Current_Subp.Subp_Text_Name.all
& "_"
& Current_Subp.Subp_Hash_V1
(Current_Subp.Subp_Hash_V1'First ..
Current_Subp.Subp_Hash_V1'First + 5)
& (if Current_Subp.Has_TC_Info
then "_" & Current_Subp.TC_Info.TC_Hash
(Current_Subp.TC_Info.TC_Hash'First ..
Current_Subp.TC_Info.TC_Hash'First + 5)
else ""))
& ".adb",
UH,
Current_Subp);
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
end if;
-- gathering used short names
Subp_Cur := Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
Current_Subp := Subp_Data_List.Element (Subp_Cur);
if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then
UH.Version := new String'(Hash_Version);
UH.Hash := new String'
(Subp_Data_List.Element
(Subp_Cur).Subp_Full_Hash.all);
if
Subp_Data_List.Element (Subp_Cur).Has_TC_Info
then
UH.TC_Hash := new String'
(Sanitize_TC_Name
(Subp_Data_List.Element
(Subp_Cur).TC_Info.Name.all));
else
UH.TC_Hash := new String'("");
end if;
MD_Cur := Find (Markered_Data_Map, UH);
if MD_Cur /= Markered_Data_Maps.No_Element then
MD := Markered_Data_Maps.Element (MD_Cur);
if MD.Short_Name_Used then
Short_Names_Used.Include
(To_Lower (MD.Short_Name.all));
Shortnamed_Subps.Include
(Current_Subp.Subp_Declaration);
Name_Numbers.Include
(To_Lower (Current_Subp.Subp_Text_Name.all),
1);
Elem_Numbers.Include
(Current_Subp.Subp_Declaration, 1);
end if;
end if;
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
-- updating short names from markered data with hash v.1
-- to hash v.2.1 where possible
Subp_Cur := Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
Current_Subp := Subp_Data_List.Element (Subp_Cur);
if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then
UH.Version := new String'("1");
UH.Hash := new String'(Current_Subp.Subp_Hash_V1.all);
if
Current_Subp.Has_TC_Info
then
UH.TC_Hash := new String'
(Current_Subp.TC_Info.TC_Hash.all);
else
UH.TC_Hash := new String'("");
end if;
MD_Cur := Find (Markered_Data_Map, UH);
if MD_Cur /= Markered_Data_Maps.No_Element then
MD := Markered_Data_Maps.Element (MD_Cur);
Markered_Data_Map.Delete (MD_Cur);
Free (UH.Hash);
UH.Hash := new String'
(Current_Subp.Subp_Hash_V2_1.all);
Free (UH.Version);
UH.Version := new String'(Hash_Version);
if UH.TC_Hash.all /= "" then
Free (UH.TC_Hash);
UH.TC_Hash := new String'
(Sanitize_TC_Name
(Current_Subp.TC_Info.Name.all));
end if;
Markered_Data_Map.Include (UH, MD);
end if;
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
-- updating short names from markered data with hash v.2.1
-- to hash v.2.2 where possible and gnathering short names
Subp_Cur := Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
Current_Subp := Subp_Data_List.Element (Subp_Cur);
if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then
UH.Version := new String'("2.1");
UH.Hash := new String'
(Current_Subp.Subp_Hash_V2_1.all);
if
Current_Subp.Has_TC_Info
then
UH.TC_Hash := new String'
(Sanitize_TC_Name
(Current_Subp.TC_Info.Name.all));
else
UH.TC_Hash := new String'("");
end if;
MD_Cur := Find (Markered_Data_Map, UH);
if MD_Cur /= Markered_Data_Maps.No_Element then
MD := Markered_Data_Maps.Element (MD_Cur);
if not
Short_Names_Used.Contains (MD.Short_Name.all)
or else Shortnamed_Subps.Contains
(Current_Subp.Subp_Declaration)
then
Short_Names_Used.Include (MD.Short_Name.all);
Shortnamed_Subps.Include
(Current_Subp.Subp_Declaration);
Name_Numbers.Include
(To_Lower (Current_Subp.Subp_Text_Name.all),
1);
Elem_Numbers.Include
(Current_Subp.Subp_Declaration, 1);
MD.Short_Name_Used := True;
end if;
Markered_Data_Map.Delete (MD_Cur);
Free (UH.Hash);
UH.Hash := new String'
(Current_Subp.Subp_Full_Hash.all);
Free (UH.Version);
UH.Version := new String'(Hash_Version);
Markered_Data_Map.Include (UH, MD);
end if;
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
-- creating markered_data and deciding on new short names
Subp_Cur := Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
Current_Subp := Subp_Data_List.Element (Subp_Cur);
if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then
UH.Version := new String'(Hash_Version);
UH.Hash := new String'
(Current_Subp.Subp_Full_Hash.all);
if
Subp_Data_List.Element (Subp_Cur).Has_TC_Info
then
UH.TC_Hash := new String'
(Sanitize_TC_Name
(Current_Subp.TC_Info.Name.all));
else
UH.TC_Hash := new String'("");
end if;
MD_Cur := Find (Markered_Data_Map, UH);
if MD_Cur = Markered_Data_Maps.No_Element then
MD.Commented_Out := False;
MD.Short_Name_Used := False;
MD.Short_Name := new String'
(To_Lower (Current_Subp.Subp_Text_Name.all));
MD.TR_Text.Clear;
if
not Short_Names_Used.Contains
(To_Lower (Current_Subp.Subp_Text_Name.all))
or else Shortnamed_Subps.Contains
(Current_Subp.Subp_Declaration)
then
-- Short name is free, we can use it
MD.Short_Name_Used := True;
Short_Names_Used.Include
(To_Lower (Current_Subp.Subp_Text_Name.all));
Shortnamed_Subps.Include
(Current_Subp.Subp_Declaration);
Name_Numbers.Include
(To_Lower (Current_Subp.Subp_Text_Name.all),
1);
Elem_Numbers.Include
(Current_Subp.Subp_Declaration, 1);
-- Looking for a dangling test with same short
-- name but different hash.
MD_Cur := Find_Same_Short_Name
(Markered_Data_Map,
Current_Subp);
if MD_Cur /= Markered_Data_Maps.No_Element then
-- Using corresponding dangling test
MD.TR_Text.Clear;
MD.TR_Text :=
Markered_Data_Maps.Element (MD_Cur).TR_Text;
-- also need to copy Commented_Out since
-- the test can be dangling for a long time
-- or just become dangling
MD.Commented_Out :=
Markered_Data_Maps.Element
(MD_Cur).Commented_Out;
Markered_Data_Map.Delete (MD_Cur);
MD.Issue_Warning := True;
end if;
end if;
Markered_Data_Map.Insert (UH, MD);
end if;
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
-- setting overloading numbers;
Subp_Cur := Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
Current_Subp := Subp_Data_List.Element (Subp_Cur);
if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then
if
Name_Numbers.Find
(To_Lower (Current_Subp.Subp_Text_Name.all)) =
Name_Frequency.No_Element
then
Name_Numbers.Include
(To_Lower (Current_Subp.Subp_Text_Name.all), 1);
Elem_Numbers.Include
(Current_Subp.Subp_Declaration, 1);
else
if
Elem_Numbers.Find
(Current_Subp.Subp_Declaration) =
Elem_Number_Maps.No_Element
then
declare
X : constant Natural :=
Name_Numbers.Element
(To_Lower
(Current_Subp.Subp_Text_Name.all));
begin
Name_Numbers.Replace
(To_Lower (Current_Subp.Subp_Text_Name.all),
X + 1);
Elem_Numbers.Include
(Current_Subp.Subp_Declaration, X + 1);
end;
end if;
end if;
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
Name_Numbers.Clear;
Create (Tmp_File_Name);
Put_TP_Header (Test_Data_Package_Name.all);
end if;
S_Put (0, "with AUnit.Assertions; use AUnit.Assertions;");
New_Line_Count;
S_Put (0, "with System.Assertions;");
New_Line_Count;
if Stub_Mode_ON then
Put_Stub_Data_Import;
end if;
New_Line_Count;
Put_Persistent_Section (With_Clauses);
S_Put (0, "package body " & Unit_Name.all & " is");
New_Line_Count;
New_Line_Count;
Put_Persistent_Section (Body_Declarations);
-- Adding test routine body stubs.
Subp_Cur := Subp_List.First;
loop
exit when Subp_Cur = Subp_Data_List.No_Element;
if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then
Current_Subp := Subp_Data_List.Element (Subp_Cur);
if Subp_Data_List.Element (Subp_Cur).Has_TC_Info then
if Is_Function
(Subp_Data_List.Element
(Subp_Cur).Subp_Declaration.As_Basic_Decl)
then
Generate_Function_Wrapper
(Subp_Data_List.Element (Subp_Cur));
else
Generate_Procedure_Wrapper
(Subp_Data_List.Element (Subp_Cur));
end if;
end if;
if Generate_Separates then
S_Put
(3,
"procedure "
& Subp_Data_List.Element
(Subp_Cur).Subp_Mangle_Name.all
& " (Gnattest_T : in out Test) is separate;");
New_Line_Count;
Print_Comment_Declaration
(Subp_Data_List.Element (Subp_Cur), 3);
New_Line_Count;
else
Test_Info.Replace
(Data.Unit_File_Name.all,
Test_Info.Element (Data.Unit_File_Name.all) + 1);
All_Tests_Counter := All_Tests_Counter + 1;
UH.Version := new String'(Hash_Version);
UH.Hash := new String'
(Subp_Data_List.Element
(Subp_Cur).Subp_Full_Hash.all);
if Subp_Data_List.Element (Subp_Cur).Has_TC_Info then
UH.TC_Hash := new String'
(Sanitize_TC_Name
(Subp_Data_List.Element
(Subp_Cur).TC_Info.Name.all));
else
UH.TC_Hash := new String'("");
end if;
MD_Cur := Find (Markered_Data_Map, UH);
MD := Markered_Data_Maps.Element (MD_Cur);
Put_Opening_Comment_Section
(Subp_Data_List.Element (Subp_Cur),
Elem_Numbers.Element
(Current_Subp.Subp_Declaration),
Use_Short_Name => MD.Short_Name_Used);
if Is_Unimplemented_Test (MD.TR_Text) then
TR_SLOC_Buffer.Append
((new String'(Test_File_Name.all & ".ads"),
new String'(Test_File_Name.all & ".adb"),
null,
Subp_Data_List.Element (Subp_Cur),
New_Line_Counter));
else
TR_SLOC_Buffer.Append
((new String'(Test_File_Name.all & ".ads"),
new String'(Test_File_Name.all & ".adb"),
new String'("modified"),
Subp_Data_List.Element (Subp_Cur),
New_Line_Counter));
end if;
if MD.TR_Text.Is_Empty then
if Stub_Mode_ON then
Setters_Set := Get_Direct_Callees_Setters
(Current_Subp.Subp_Declaration.As_Basic_Decl);
end if;
New_Tests_Counter := New_Tests_Counter + 1;
New_Line_Count;
S_Put (6, "pragma Unreferenced (Gnattest_T);");
New_Line_Count;
New_Line_Count;
S_Put (3, "begin");
New_Line_Count;
New_Line_Count;
if not Setters_Set.Is_Empty then
Set_Cur := Setters_Set.First;
while Set_Cur /= String_Set.No_Element loop
S_Put
(3,
"-- "
& String_Set.Element (Set_Cur)
& "( );");
New_Line_Count;
Next (Set_Cur);
end loop;
New_Line_Count;
Setters_Set.Clear;
end if;
S_Put (6, "AUnit.Assertions.Assert");
New_Line_Count;
S_Put
(8, "(Gnattest_Generated.Default_Assert_Value,");
New_Line_Count;
S_Put (9, """Test not implemented."");");
New_Line_Count;
New_Line_Count;
else
if MD.Issue_Warning then
Report_Std
("warning: (gnattest) "
& Base_Name (Data.Unit_File_Name.all)
& ":"
& Trim
(First_Line_Number
(Current_Subp.Subp_Declaration)'Img,
Both)
& ":"
& Trim
(First_Column_Number
(Current_Subp.Subp_Declaration)'Img,
Both)
& ": test for "
& MD.Short_Name.all
& " at "
& Unit_Name.all
& ":"
& Trim
(Integer'Image (New_Line_Counter),
Both)
& " might be out of date ("
& MD.Short_Name.all
& " has been changed)");
end if;
for I in
MD.TR_Text.First_Index .. MD.TR_Text.Last_Index
loop
if MD.Commented_Out then
S_Put
(0,
Uncomment_Line (MD.TR_Text.Element (I)));
else
S_Put (0, MD.TR_Text.Element (I));
end if;
New_Line_Count;
end loop;
end if;
Markered_Data_Map.Delete (MD_Cur);
Put_Closing_Comment_Section
(Subp_Data_List.Element (Subp_Cur),
Elem_Numbers.Element
(Current_Subp.Subp_Declaration),
Use_Short_Name => MD.Short_Name_Used);
New_Line_Count;
end if;
end if;
Subp_Data_List.Next (Subp_Cur);
end loop;
-- printing dangling tests
if not Markered_Data_Map_Is_Empty then
Report_Std
(" warning: (gnattest) "
& Unit_Name.all
& " has dangling test(s)");
end if;
MD_Cur := Markered_Data_Map.First;
loop
exit when MD_Cur = Markered_Data_Maps.No_Element;
MD := Markered_Data_Maps.Element (MD_Cur);
if Markered_Data_Maps.Key (MD_Cur).Hash.all /= "02" then
declare
Stub : Subp_Info;
begin
Stub.Subp_Full_Hash := new String'
(Markered_Data_Maps.Key (MD_Cur).Hash.all);
Stub.Subp_Text_Name := new String'
(MD.Short_Name.all);
if Markered_Data_Maps.Key (MD_Cur).TC_Hash.all = ""
then
Stub.Has_TC_Info := False;
Stub.Subp_Mangle_Name := new String'
(Test_Routine_Prefix
& Markered_Data_Maps.Element
(MD_Cur).Short_Name.all
& "_"
& Stub.Subp_Full_Hash
(Stub.Subp_Full_Hash'First ..
Stub.Subp_Full_Hash'First + 5));
else
Stub.Has_TC_Info := True;
Stub.TC_Info.TC_Hash := new String'
(Markered_Data_Maps.Key (MD_Cur).TC_Hash.all);
Stub.TC_Info.Name := Stub.TC_Info.TC_Hash;
Stub.Subp_Mangle_Name := new String'
(Test_Routine_Prefix
& Markered_Data_Maps.Element
(MD_Cur).Short_Name.all
& "_"
& Stub.Subp_Full_Hash
(Stub.Subp_Full_Hash'First ..
Stub.Subp_Full_Hash'First + 5)
& "_"
& Stub.TC_Info.TC_Hash.all);
end if;
Put_Opening_Comment_Section
(Stub, 0, True, MD.Short_Name_Used);
Add_DT
(TP_List,
Test_File_Name.all & ".ads",
Test_File_Name.all & ".adb",
New_Line_Counter,
1);
for I in
MD.TR_Text.First_Index .. MD.TR_Text.Last_Index
loop
if MD.Commented_Out then
S_Put (0, MD.TR_Text.Element (I));
else
S_Put (0, "-- " & MD.TR_Text.Element (I));
end if;
New_Line_Count;
end loop;
Put_Closing_Comment_Section
(Stub, 0, True, MD.Short_Name_Used);
New_Line_Count;
end;
end if;
Markered_Data_Maps.Next (MD_Cur);
end loop;
Put_Persistent_Section (Body_Statements);
S_Put (0, "end " & Unit_Name.all & ";");
New_Line_Count;
Close_File;
Add_Buffered_TR_Slocs
(TP_List,
Format_Time
(File_Time_Stamp
(Tmp_File_Name)));
if not Generate_Separates then
declare
Old_Package : constant String :=
Output_Dir & Directory_Separator
& Test_File_Name.all & ".adb";
Success : Boolean;
begin
if Is_Regular_File (Old_Package) then
Delete_File (Old_Package, Success);
if not Success then
Cmd_Error_No_Help ("cannot delete " & Old_Package);
end if;
end if;
Copy_File (Tmp_File_Name, Old_Package, Success);
if not Success then
Cmd_Error_No_Help
("cannot copy tmp test package to " & Old_Package);
end if;
Delete_File (Tmp_File_Name, Success);
if not Success then
Cmd_Error_No_Help ("cannot delete tmp test package");
end if;
end;
end if;
Markered_Data_Map.Clear;
else
Excluded_Test_Package_Bodies.Include
(Test_File_Name.all & ".adb");
end if;
Short_Names_Used.Clear;
Shortnamed_Subps.Clear;
Elem_Numbers.Clear;
Subp_List.Clear;
Package_Info_List.Next (Pack_Cur);
end loop;
end if;
Add_Test_List (Data.Unit_File_Name.all, TP_List);
TP_List.Clear;
if Data.Is_Generic then
Gen_Tests_Storage.Append (Gen_Tests);
end if;
end Generate_Test_Package;
------------
-- Add_DT --
------------
procedure Add_DT
(TP_List : in out TP_Mapping_List.List;
TPtarg : String;
Test_F : String;
Line : Natural;
Column : Natural)
is
TP : TP_Mapping;
TD : DT_Mapping;
TP_Cur : TP_Mapping_List.Cursor := TP_List.First;
begin
TD.File := new String'(Test_F);
TD.Line := Line;
TD.Column := Column;
loop
exit when TP_Cur = TP_Mapping_List.No_Element;
if TP_Mapping_List.Element (TP_Cur).TP_Name.all = TPtarg then
exit;
end if;
TP_Mapping_List.Next (TP_Cur);
end loop;
TP := TP_Mapping_List.Element (TP_Cur);
TP.DT_List.Append (TD);
TP_List.Replace_Element (TP_Cur, TP);
end Add_DT;
------------
-- Add_TR --
------------
procedure Add_TR
(TP_List : in out TP_Mapping_List.List;
TPtarg : String;
Test_F : String;
Test_T : String;
Subp : Subp_Info;
TR_Line : Natural := 1)
is
TC : TC_Mapping;
TR : TR_Mapping;
TP : TP_Mapping;
TR_Cur : TR_Mapping_List.Cursor;
TP_Cur : TP_Mapping_List.Cursor := TP_List.First;
Subp_Span : constant Source_Location_Range :=
Subp.Subp_Declaration.As_Basic_Decl.P_Defining_Name.Sloc_Range;
TC_Span : constant Source_Location_Range := No_Source_Location_Range;
begin
loop
exit when TP_Cur = TP_Mapping_List.No_Element;
if TP_Mapping_List.Element (TP_Cur).TP_Name.all = TPtarg then
exit;
end if;
TP_Mapping_List.Next (TP_Cur);
end loop;
if TP_Cur = TP_Mapping_List.No_Element then
TP.TP_Name := new String'(TPtarg);
TR.TR_Name := new String'(Subp.Subp_Text_Name.all);
TR.Line := Natural (Subp_Span.Start_Line);
TR.Column := Natural (Subp_Span.Start_Column);
if Subp.Has_TC_Info then
TC.T_Name := new String'(Subp.Subp_Mangle_Name.all);
TC.TC_Name := new String'(Subp.TC_Info.Name.all);
TC.Line := Natural (TC_Span.Start_Line);
TC.Column := Natural (TC_Span.Start_Column);
TC.Test := new String'(Test_F);
TC.Test_Time := new String'(Test_T);
TC.TR_Line := TR_Line;
TR.TC_List.Append (TC);
else
TR.Test := new String'(Test_F);
TR.Test_Time := new String'(Test_T);
TR.TR_Line := TR_Line;
TR.T_Name := new String'(Subp.Subp_Mangle_Name.all);
end if;
TP.TR_List.Append (TR);
TP_List.Append (TP);
return;
end if;
TP := TP_Mapping_List.Element (TP_Cur);
TR_Cur := TP.TR_List.First;
loop
exit when TR_Cur = TR_Mapping_List.No_Element;
if
TR_Mapping_List.Element (TR_Cur).Line =
Natural (Subp_Span.Start_Line) and then
TR_Mapping_List.Element (TR_Cur).Column =
Natural (Subp_Span.Start_Column)
then
exit;
end if;
TR_Mapping_List.Next (TR_Cur);
end loop;
if TR_Cur = TR_Mapping_List.No_Element then
TR.TR_Name := new String'(Subp.Subp_Text_Name.all);
TR.Line := Natural (Subp_Span.Start_Line);
TR.Column := Natural (Subp_Span.Start_Column);
if Subp.Has_TC_Info then
TC.T_Name := new String'(Subp.Subp_Mangle_Name.all);
TC.TC_Name := new String'(Subp.TC_Info.Name.all);
TC.Line := Natural (TC_Span.Start_Line);
TC.Column := Natural (TC_Span.Start_Column);
TC.Test := new String'(Test_F);
TC.Test_Time := new String'(Test_T);
TC.TR_Line := TR_Line;
TR.TC_List.Append (TC);
else
TR.Test := new String'(Test_F);
TR.Test_Time := new String'(Test_T);
TR.TR_Line := TR_Line;
TR.T_Name := new String'(Subp.Subp_Mangle_Name.all);
end if;
TP.TR_List.Append (TR);
TP_List.Replace_Element (TP_Cur, TP);
return;
end if;
TR := TR_Mapping_List.Element (TR_Cur);
-- The only way that there is same subprogram already is when it has
-- test_cases. So no need to check if it has TC_Info.
TC.T_Name := new String'(Subp.Subp_Mangle_Name.all);
TC.TC_Name := new String'(Subp.TC_Info.Name.all);
TC.Line := Natural (TC_Span.Start_Line);
TC.Column := Natural (TC_Span.Start_Column);
TC.Test := new String'(Test_F);
TC.Test_Time := new String'(Test_T);
TC.TR_Line := TR_Line;
TR.TC_List.Append (TC);
TP.TR_List.Replace_Element (TR_Cur, TR);
TP_List.Replace_Element (TP_Cur, TP);
end Add_TR;
-------------------------------
-- Print_Comment_Declaration --
-------------------------------
procedure Print_Comment_Declaration (Subp : Subp_Info; Span : Natural := 0)
is
File_Name : constant String := Base_Name
(Subp.Subp_Declaration.Unit.Get_Filename);
Elem_Span : constant Source_Location_Range :=
Subp.Subp_Declaration.Sloc_Range;
begin
if Omit_Sloc then
return;
end if;
S_Put
(Span,
"-- " &
File_Name &
":" &
Trim (Elem_Span.Start_Line'Img, Both) &
":" &
Trim (Elem_Span.Start_Column'Img, Both) &
":" &
Subp.Subp_Text_Name.all);
if Subp.Has_TC_Info then
S_Put (0, ":" & Subp.TC_Info.Name.all);
end if;
New_Line_Count;
end Print_Comment_Declaration;
--------------------------------
-- Get_Direct_Callees_Setters --
--------------------------------
function Get_Direct_Callees_Setters
(Subp : Basic_Decl) return String_Set.Set
is
Result : String_Set.Set;
function Get_Callees (Node : Ada_Node'Class) return Visit_Status;
-- Traverses subprogram body in search for callees
function Get_Callees (Node : Ada_Node'Class) return Visit_Status is
Decl : Basic_Decl;
begin
-- P_Is_Call may occasionally crash on some constructs, commented out
-- setter suggestions are not important enough to keep the tool
-- exposed to possible crashes, so instead we just skip such cases
-- and issue error data in the traces.
begin
if (Node.Kind = Ada_Identifier
and then Node.As_Name.P_Is_Call)
or else Node.Kind in Ada_Op
then
Decl := Node.As_Name.P_Referenced_Decl;
if Decl.Is_Null then
return Over;
end if;
else
return Into;
end if;
exception
when Ex : Langkit_Support.Errors.Property_Error =>
Trace (Me_Direct_Callees,
"Error while processing" & Node.Image);
Trace (Me_Direct_Callees,
Ada.Exceptions.Exception_Name (Ex)
& " : "
& Ada.Exceptions.Exception_Message (Ex));
return Over;
end;
if Decl.Unit = Node.Unit or else Decl.Unit = Subp.Unit then
-- Callee is from the same unit spec or even from the body,
-- it won't be stubbed.
return Over;
end if;
if not Source_Present (Decl.Unit.Get_Filename) then
--
return Over;
end if;
-- Process simple cases for now. Dispatchings, renamings and parts of
-- instances are not yet supported.
if Decl.Kind in Ada_Generic_Subp_Instantiation | Ada_Formal_Subp_Decl
| Ada_Subp_Renaming_Decl | Ada_Enum_Literal_Decl | Ada_Entry_Decl
| Ada_Null_Subp_Decl | Ada_Subp_Body | Ada_Subp_Body_Stub
then
return Over;
end if;
for Parent of Decl.Parents loop
if Parent.Kind = Ada_Generic_Package_Decl then
return Over;
end if;
end loop;
if Decl.Parent.Kind = Ada_Library_Item then
-- Library level supprograms are not stubbed
return Over;
end if;
declare
Suffix : constant String :=
"_"
& Head (Mangle_Hash_Full (Decl), 6)
& "_"
& Head (GNAT.SHA1.Digest (Get_Nesting (Decl)), 6);
begin
Result.Include
(Get_Nesting (Decl)
& "."
& Stub_Data_Unit_Name
& "."
& Setter_Prefix
& Get_Subp_Name (Decl)
& Suffix);
end;
return Into;
end Get_Callees;
begin
Increase_Indent
(Me_Direct_Callees,
"Gathering direct callees for " & Subp.Image);
if Subp.Kind = Ada_Expr_Function then
Traverse (Subp.As_Expr_Function.F_Expr, Get_Callees'Access);
elsif Subp.Kind = Ada_Subp_Decl then
Traverse (Subp.As_Subp_Decl.P_Body_Part, Get_Callees'Access);
end if;
Trace
(Me_Direct_Callees,
"Direct callees gathered");
Decrease_Indent;
return Result;
end Get_Direct_Callees_Setters;
----------------------------------
-- Get_Subprogram_From_Separate --
----------------------------------
procedure Get_Subprogram_From_Separate
(File : String;
UH : Unique_Hash;
Subp : Subp_Info)
is
Input_File : Ada.Text_IO.File_Type;
MD : Markered_Data;
Line : String_Access;
Append_Line : Boolean;
use GNAT.OS_Lib;
begin
if not Is_Regular_File (File) then
return;
end if;
MD.Commented_Out := False;
MD.TR_Text := String_Vectors.Empty_Vector;
MD.Short_Name := new String'(Subp.Subp_Text_Name.all);
Open (Input_File, In_File, File);
loop
exit when End_Of_File (Input_File);
Line := new String'(Get_Line (Input_File));
Append_Line := True;
if To_Lower (Line.all) = "with gnattest_generated;" then
Append_Line := False;
end if;
-- skipping test routine profile up to declaration section;
-- depending on line breaks it can take different number of lines
if Index (To_Lower (Line.all), "separate", Line'First) /= 0 then
loop
if
Index (To_Lower (Line.all), ") is", Line'First) /= 0
or else Trim (To_Lower (Line.all), Both) = "is"
then
Append_Line := False;
exit;
else
Free (Line);
Line := new String'(Get_Line (Input_File));
end if;
end loop;
end if;
-- skipping "end test_outine_name;"
if
Index
(To_Lower (Line.all),
"end "
& To_Lower
(Test_Routine_Prefix
& Subp.Subp_Text_Name.all
& "_"
& Subp.Subp_Hash_V1
(Subp.Subp_Hash_V1'First .. Subp.Subp_Hash_V1'First + 5))
& ";",
Line'First) /= 0
then
Append_Line := False;
end if;
if Append_Line then
MD.TR_Text.Append (Line.all);
end if;
Free (Line);
end loop;
Close (Input_File);
if Find (Markered_Data_Map, UH) = Markered_Data_Maps.No_Element then
Markered_Data_Map.Insert (UH, MD);
else
Markered_Data_Map.Replace (UH, MD);
end if;
end Get_Subprogram_From_Separate;
----------------------------------
-- Get_Subprograms_From_Package --
----------------------------------
procedure Get_Subprograms_From_Package (File : String) is
Input_File : Ada.Text_IO.File_Type;
Line_Counter : Natural := 0;
Line : String_Access;
Idx, Idx2 : Natural;
UH : Unique_Hash;
MD : Markered_Data;
ID_Found : Boolean;
type Parsing_Modes is (TR, Marker, Other);
Parsing_Mode : Parsing_Modes := Other;
Prev_Parsing_Mode : Parsing_Modes := Other;
procedure Report_Corrupted_Marker;
pragma Unreferenced (Report_Corrupted_Marker);
procedure Report_Corrupted_Marker is
begin
Report_Err
("marker corrupted at "
& Base_Name (File)
& ":"
& Natural'Image (Line_Counter));
end Report_Corrupted_Marker;
use GNAT.OS_Lib;
begin
if not Is_Regular_File (File) then
return;
end if;
MD.Commented_Out := False;
MD.Short_Name_Used := False;
MD.TR_Text := String_Vectors.Empty_Vector;
UH.Hash := new String'("");
UH.TC_Hash := new String'("");
Open (Input_File, In_File, File);
loop
exit when End_Of_File (Input_File);
Line := new String'(Get_Line (Input_File));
Line_Counter := Line_Counter + 1;
case Parsing_Mode is
when Other =>
if Index (Line.all, GT_Marker_Begin) /= 0 then
Parsing_Mode := Marker;
Prev_Parsing_Mode := Other;
ID_Found := False;
end if;
when Marker =>
Idx := Index (Line.all, "-- id:");
if Idx /= 0 then
ID_Found := True;
Idx := Idx + 7;
Idx2 := Index (Line.all, "/", Idx + 1);
UH.Version := new String'(Line (Idx .. Idx2 - 1));
Idx := Idx2 + 1;
Idx2 := Index (Line.all, "/", Idx + 1);
UH.Hash := new String'(Line (Idx .. Idx2 - 1));
Idx := Idx2 + 1;
Idx2 := Index (Line.all, "/", Idx + 1);
MD.Short_Name := new String'(Line (Idx .. Idx2 - 1));
Idx := Idx2 + 1;
Idx2 := Index (Line.all, "/", Idx + 1);
if Line (Idx .. Idx2 - 1) = "1" then
MD.Short_Name_Used := True;
else
MD.Short_Name_Used := False;
end if;
Idx := Idx2 + 1;
Idx2 := Index (Line.all, "/", Idx + 1);
if Line (Idx .. Idx2 - 1) = "1" then
MD.Commented_Out := True;
else
MD.Commented_Out := False;
end if;
if Idx2 < Line'Last then
Idx := Idx2 + 1;
Idx2 := Index (Line.all, "/", Idx + 1);
UH.TC_Hash := new String'(Line (Idx .. Idx2 - 1));
end if;
else
if Index (Line.all, GT_Marker_End) /= 0 then
if Prev_Parsing_Mode = Other then
if ID_Found then
Parsing_Mode := TR;
else
Parsing_Mode := Other;
end if;
end if;
if Prev_Parsing_Mode = TR then
Parsing_Mode := Other;
end if;
end if;
end if;
when TR =>
if Index (Line.all, GT_Marker_Begin) /= 0 then
Markered_Data_Map.Include (UH, MD);
Prev_Parsing_Mode := TR;
Parsing_Mode := Marker;
MD.Commented_Out := False;
MD.Short_Name_Used := False;
MD.TR_Text := String_Vectors.Empty_Vector;
UH.Hash := new String'("");
UH.TC_Hash := new String'("");
else
MD.TR_Text.Append (Line.all);
end if;
end case;
end loop;
Close (Input_File);
end Get_Subprograms_From_Package;
-----------------------
-- Get_Units_To_Stub --
-----------------------
procedure Get_Units_To_Stub
(The_Unit : Compilation_Unit;
Data : in out Data_Holder)
is
Body_N : Body_Node;
Body_Unit : Compilation_Unit;
Parent : Ada_Node;
Already_Stubbing : String_Set.Set := String_Set.Empty_Set;
-- It is generally easier to store units to stub in a list, however
-- to avoid duplications we use this local set since it is easier
-- and faster to check membership in a set.
function Good_To_Stub (Check_Unit : Analysis_Unit) return Boolean;
-- Checks that given unit is suitable for stubbing
procedure Add_Units_To_Stub (The_Unit : Compilation_Unit);
-- Adds units from with clauses and parent units to the list of
-- units to stub.
procedure Iterate_Separates (The_Unit : Compilation_Unit);
-- Looks for inuts withed in separate bodies
-----------------------
-- Add_Units_To_Stub --
-----------------------
procedure Add_Units_To_Stub (The_Unit : Compilation_Unit)
is
Clauses : constant Ada_Node_List := The_Unit.F_Prelude;
begin
for Cl of Clauses loop
if
Cl.Kind = Ada_With_Clause
and then not Cl.As_With_Clause.F_Has_Limited
then
declare
With_Names : constant Name_List :=
Cl.As_With_Clause.F_Packages;
Withed_Spec : Basic_Decl;
Parent_Unit : Ada_Node;
begin
for WN of With_Names loop
Withed_Spec := WN.As_Name.P_Referenced_Decl;
if not Withed_Spec.Is_Null then
declare
Withed_Spec_Image : constant String :=
Withed_Spec.Unit.Get_Filename;
begin
if Good_To_Stub (Withed_Spec.Unit)
and then not Already_Stubbing.Contains
(Withed_Spec_Image)
then
Already_Stubbing.Include (Withed_Spec_Image);
Data.Units_To_Stub.Append
(Withed_Spec.As_Ada_Node);
Trace (Me, Withed_Spec_Image);
end if;
end;
-- Gathering parent packages
Parent_Unit := Withed_Spec.P_Semantic_Parent;
while
not Parent_Unit.Is_Null and then
Parent_Unit.Unit /= Parent_Unit.P_Standard_Unit
loop
if Parent_Unit.Kind = Ada_Package_Decl then
declare
Parent_File : constant String :=
Parent_Unit.Unit.Get_Filename;
begin
if Good_To_Stub (Parent_Unit.Unit)
and then not Already_Stubbing.Contains
(Parent_File)
then
Already_Stubbing.Include (Parent_File);
Data.Units_To_Stub.Append (Parent_Unit);
Trace (Me, Parent_File);
end if;
end;
end if;
Parent_Unit := Parent_Unit.P_Semantic_Parent;
end loop;
end if;
end loop;
end;
end if;
end loop;
end Add_Units_To_Stub;
-----------------------
-- Iterate_Separates --
-----------------------
procedure Iterate_Separates (The_Unit : Compilation_Unit) is
Bod : Ada_Node;
function Find (Node : Ada_Node'Class) return Visit_Status;
function Find (Node : Ada_Node'Class) return Visit_Status is
Separate_A_Unit : Analysis_Unit;
Separate_C_Unit : Compilation_Unit;
begin
if Node.Kind in Ada_Body_Stub then
Separate_A_Unit := Node.As_Basic_Decl.P_Next_Part_For_Decl.Unit;
Separate_C_Unit := Separate_A_Unit.Root.As_Compilation_Unit;
Add_Units_To_Stub (Separate_C_Unit);
Iterate_Separates (Separate_C_Unit);
end if;
return Into;
end Find;
begin
if The_Unit.F_Body.Kind = Ada_Library_Item then
Bod := The_Unit.F_Body.As_Library_Item.F_Item.As_Ada_Node;
else
Bod := The_Unit.F_Body.As_Subunit.F_Body.As_Ada_Node;
end if;
Traverse (Bod, Find'Access);
end Iterate_Separates;
------------------
-- Good_To_Stub --
------------------
function Good_To_Stub (Check_Unit : Analysis_Unit) return Boolean is
File_Name : constant String :=
Base_Name (Check_Unit.Get_Filename);
Arg_File_Name : constant String :=
Base_Name (The_Unit.Unit.Get_Filename);
Lib_Item : constant Library_Item :=
Check_Unit.Root.As_Compilation_Unit.F_Body.As_Library_Item;
begin
if not Source_Present (Check_Unit.Get_Filename) then
return False;
end if;
if Check_Unit = The_Unit.Unit then
-- No self stubbing
return False;
end if;
if Lib_Item.F_Item.Kind /= Ada_Package_Decl then
-- Only packages are stubbed
return False;
end if;
if Lib_Item.F_Item.As_Basic_Decl.P_Has_Aspect
(To_Unbounded_Text (To_Text ("Remote_Call_Interface")))
then
return False;
end if;
if Default_Stub_Exclusion_List.Contains (File_Name) then
return False;
end if;
if Stub_Exclusion_Lists.Contains (Arg_File_Name) then
if
Stub_Exclusion_Lists.Element (Arg_File_Name).Contains (File_Name)
then
return False;
end if;
end if;
return True;
end Good_To_Stub;
begin
Trace
(Me,
"units to stub for "
& Base_Name (The_Unit.Unit.Get_Filename));
Increase_Indent (Me);
-- Gathering with clauses from spec
Add_Units_To_Stub (The_Unit);
Body_N :=
The_Unit.F_Body.As_Library_Item.F_Item.As_Basic_Decl.
P_Body_Part_For_Decl;
-- Gathering with clauses from body
if Body_N /= No_Body_Node
and then Body_N.Unit.Root.Kind = Ada_Compilation_Unit
then
Body_Unit := Body_N.Unit.Root.As_Compilation_Unit;
Add_Units_To_Stub (Body_Unit);
Iterate_Separates (Body_Unit);
end if;
-- Gathering parent packages
Parent :=
The_Unit.F_Body.As_Library_Item.F_Item.As_Ada_Node.P_Semantic_Parent;
while
not Parent.Is_Null and then Parent.Unit /= Parent.P_Standard_Unit
loop
if Parent.Kind = Ada_Package_Decl then
declare
Parent_File : constant String := Parent.Unit.Get_Filename;
begin
if Good_To_Stub (Parent.Unit)
and then not Already_Stubbing.Contains (Parent_File)
then
Already_Stubbing.Include (Parent_File);
Data.Units_To_Stub.Append (Parent);
Trace (Me, Parent_File);
end if;
end;
end if;
Parent := Parent.P_Semantic_Parent;
end loop;
Decrease_Indent (Me);
Already_Stubbing.Clear;
end Get_Units_To_Stub;
----------------------
-- Sanitize_TC_Name --
----------------------
function Sanitize_TC_Name (TC_Name : String) return String
is
Name : String := Trim (TC_Name, Both);
Tmp : String_Access := new String'("");
Buff : String_Access;
Underscore : Boolean := True;
begin
for I in Name'Range loop
if Name (I) = ' ' then
Name (I) := '_';
end if;
end loop;
for I in Name'Range loop
if Underscore then
if Name (I) /= '_' then
Underscore := False;
if Is_Letter (Name (I)) or else Is_Digit (Name (I)) then
Buff := new String'(Tmp.all & Name (I));
Free (Tmp);
Tmp := Buff;
Buff := null;
end if;
end if;
else
if
Is_Letter (Name (I))
or else Is_Digit (Name (I))
or else Name (I) = '_'
then
Buff := new String'(Tmp.all & Name (I));
Free (Tmp);
Tmp := Buff;
Buff := null;
if Name (I) = '_' then
Underscore := True;
end if;
end if;
end if;
end loop;
return To_Lower (Tmp.all);
end Sanitize_TC_Name;
--------------------------
-- Find_Same_Short_Name --
--------------------------
function Find_Same_Short_Name
(MD_Map : Markered_Data_Maps.Map;
Subp : Subp_Info) return Markered_Data_Maps.Cursor
is
Short_Name : constant String := Subp.Subp_Text_Name.all;
TC_Hash : constant String :=
(if Subp.Has_TC_Info then
Sanitize_TC_Name (Subp.TC_Info.Name.all)
else "");
Cur : Markered_Data_Maps.Cursor := MD_Map.First;
MD : Markered_Data;
begin
Trace
(Me,
"Looking for a compatible dangling test for " & Short_Name);
loop
exit when Cur = Markered_Data_Maps.No_Element;
MD := Markered_Data_Maps.Element (Cur);
if
MD.Short_Name_Used
and then MD.Short_Name.all = Short_Name
-- It is hard to understand what happens when test case name
-- is changed, so we do not handle this scenario.
and then Markered_Data_Maps.Key (Cur).TC_Hash.all = TC_Hash
then
exit;
end if;
Markered_Data_Maps.Next (Cur);
end loop;
return Cur;
end Find_Same_Short_Name;
---------------------------------
-- Put_Closing_Comment_Section --
---------------------------------
procedure Put_Closing_Comment_Section
(Subp : Subp_Info;
Overloading_N : Natural;
Commented_Out : Boolean := False;
Use_Short_Name : Boolean := True)
is
Overloading_Prefix : String_Access;
begin
if Overloading_N /= 0 then
if Subp.Is_Overloaded then
if Use_Short_Name then
Overloading_Prefix := new String'("1_");
else
Overloading_Prefix := new String'
(Trim (Natural'Image (Overloading_N), Both) & "_");
end if;
else
Overloading_Prefix := new String'("");
end if;
end if;
S_Put (0, "-- begin read only");
New_Line_Count;
if Commented_Out then
S_Put
(3,
"-- end "
& Test_Routine_Prefix
& Subp.Subp_Text_Name.all
& (if Subp.Has_TC_Info
then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all)
else "")
& ";");
else
S_Put
(3,
"end "
& Test_Routine_Prefix
& Overloading_Prefix.all
& Subp.Subp_Text_Name.all
& (if Subp.Has_TC_Info
then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all)
else "")
& ";");
end if;
New_Line_Count;
S_Put (0, "-- end read only");
New_Line_Count;
end Put_Closing_Comment_Section;
---------------------------------
-- Put_Opening_Comment_Section --
---------------------------------
procedure Put_Opening_Comment_Section
(Subp : Subp_Info;
Overloading_N : Natural;
Commented_Out : Boolean := False;
Use_Short_Name : Boolean := True;
Type_Name : String := "")
is
Hash_Length_Used : constant := 15;
Hash_First : constant Integer := Subp.Subp_Full_Hash'First;
Hash_Last : constant Integer :=
Subp.Subp_Full_Hash'First + Hash_Length_Used;
Overloading_Prefix : String_Access;
begin
if Overloading_N /= 0 then
if Subp.Is_Overloaded then
if Use_Short_Name then
Overloading_Prefix := new String'("1_");
else
Overloading_Prefix := new String'
(Trim (Natural'Image (Overloading_N), Both) & "_");
end if;
else
Overloading_Prefix := new String'("");
end if;
end if;
New_Line_Count;
S_Put (0, "-- begin read only");
New_Line_Count;
if Subp.Corresp_Type = 0 then
if Commented_Out then
S_Put
(3,
"-- procedure "
& Test_Routine_Prefix
& Subp.Subp_Text_Name.all
& (if Subp.Has_TC_Info
then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all)
else "")
& " (Gnattest_T : in out Test);");
New_Line_Count;
S_Put
(3,
"-- procedure "
& Subp.Subp_Mangle_Name.all
& " (Gnattest_T : in out Test) renames "
& Test_Routine_Prefix
& Subp.Subp_Text_Name.all
& (if Subp.Has_TC_Info
then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all)
else "")
& ";");
New_Line_Count;
else
S_Put
(3,
"procedure "
& Test_Routine_Prefix
& Overloading_Prefix.all
& Subp.Subp_Text_Name.all
& (if Subp.Has_TC_Info
then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all)
else "")
& " (Gnattest_T : in out Test);");
New_Line_Count;
S_Put
(3,
"procedure "
& Subp.Subp_Mangle_Name.all
& " (Gnattest_T : in out Test) renames "
& Test_Routine_Prefix
& Overloading_Prefix.all
& Subp.Subp_Text_Name.all
& (if Subp.Has_TC_Info
then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all)
else "")
& ";");
New_Line_Count;
end if;
else
if Commented_Out then
S_Put
(3,
"-- procedure "
& Test_Routine_Prefix
& Subp.Subp_Text_Name.all
& (if Subp.Has_TC_Info
then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all)
else "")
& " (Gnattest_T : in out Test_"
& Type_Name
& ");");
New_Line_Count;
S_Put
(3,
"-- procedure "
& Subp.Subp_Mangle_Name.all
& " (Gnattest_T : in out Test_"
& Type_Name
& ") renames "
& Test_Routine_Prefix
& Subp.Subp_Text_Name.all
& (if Subp.Has_TC_Info
then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all)
else "")
& ";");
New_Line_Count;
else
S_Put
(3,
"procedure "
& Test_Routine_Prefix
& Overloading_Prefix.all
& Subp.Subp_Text_Name.all
& (if Subp.Has_TC_Info
then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all)
else "")
& " (Gnattest_T : in out Test_"
& Type_Name
& ");");
New_Line_Count;
S_Put
(3,
"procedure "
& Subp.Subp_Mangle_Name.all
& " (Gnattest_T : in out Test_"
& Type_Name
& ") renames "
& Test_Routine_Prefix
& Overloading_Prefix.all
& Subp.Subp_Text_Name.all
& (if Subp.Has_TC_Info
then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all)
else "")
& ";");
New_Line_Count;
end if;
end if;
S_Put
(0,
"-- id:"
& Hash_Version
& "/"
& Subp.Subp_Full_Hash (Hash_First .. Hash_Last)
& "/"
& Subp.Subp_Text_Name.all
& "/"
& (if Use_Short_Name then "1" else "0")
& "/"
& (if Commented_Out then "1" else "0")
& "/");
if Subp.Has_TC_Info then
S_Put
(0,
Sanitize_TC_Name (Subp.TC_Info.Name.all)
& "/");
end if;
New_Line_Count;
if Commented_Out then
S_Put
(3,
"-- procedure "
& Test_Routine_Prefix
& Subp.Subp_Text_Name.all
& (if Subp.Has_TC_Info
then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all)
else "")
& " (Gnattest_T : in out ");
else
S_Put
(3,
"procedure "
& Test_Routine_Prefix
& Overloading_Prefix.all
& Subp.Subp_Text_Name.all
& (if Subp.Has_TC_Info
then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all)
else "")
& " (Gnattest_T : in out ");
end if;
if Subp.Corresp_Type = 0 then
S_Put (0, "Test) is");
else
S_Put
(0,
"Test_"
& Type_Name
& ") is");
end if;
New_Line_Count;
if not Commented_Out then
-- we cannot relate to any sloc in case of a dangling test
if not Omit_Sloc then
S_Put
(3,
"-- "
& Base_Name
(Subp.Subp_Declaration.Unit.Get_Filename)
& ":"
& Trim
(First_Line_Number (Subp.Subp_Declaration)'Img, Both)
& ":"
& Trim
(First_Column_Number (Subp.Subp_Declaration)'Img, Both)
& ":"
& Subp.Subp_Name_Image.all);
New_Line_Count;
end if;
if Subp.Has_TC_Info then
Put_Wrapper_Rename (6, Subp);
end if;
end if;
S_Put (0, "-- end read only");
New_Line_Count;
end Put_Opening_Comment_Section;
--------------------
-- Uncomment_Line --
--------------------
function Uncomment_Line (S : String) return String is
begin
if S = "-- " then
return "";
end if;
if S'Length < 5 then
return S;
end if;
if S (S'First .. S'First + 3) = "-- " then
return S (S'First + 4 .. S'Last);
end if;
return S;
end Uncomment_Line;
-----------------
-- Format_Time --
-----------------
function Format_Time (Time : GNAT.OS_Lib.OS_Time) return String is
function Prefix_With_Zero (S : String) return String;
function Prefix_With_Zero (S : String) return String is
S_Trimmed : constant String := Trim (S, Both);
begin
if S_Trimmed'Length = 1 then
return "0" & S_Trimmed;
else
return S_Trimmed;
end if;
end Prefix_With_Zero;
use GNAT.OS_Lib;
begin
return
Trim (Integer'Image (GM_Year (Time)), Both) & "-" &
Prefix_With_Zero (Integer'Image (GM_Month (Time))) & "-" &
Prefix_With_Zero (Integer'Image (GM_Day (Time))) & " " &
Prefix_With_Zero (Integer'Image (GM_Hour (Time))) & ":" &
Prefix_With_Zero (Integer'Image (GM_Minute (Time))) & ":" &
Prefix_With_Zero (Integer'Image (GM_Second (Time)));
end Format_Time;
---------------------------
-- Generate_Project_File --
---------------------------
procedure Generate_Project_File (Source_Prj : String) is
Tmp_Str : GNAT.OS_Lib.String_Access;
package Srcs is new
Ada.Containers.Indefinite_Ordered_Sets (String);
use Srcs;
Out_Dirs : Srcs.Set;
Out_Dirs_Cur : Srcs.Cursor;
Output_Prj : GNAT.OS_Lib.String_Access;
Source_Prj_Name : String :=
Base_Name (Source_Prj, File_Extension (Source_Prj));
use GNAT.OS_Lib;
begin
for I in Source_Prj_Name'Range loop
if Source_Prj_Name (I) = '-' then
Source_Prj_Name (I) := '_';
end if;
end loop;
Reset_Source_Iterator;
loop
Tmp_Str := new String'(Next_Source_Name);
exit when Tmp_Str.all = "";
if Is_Directory (Get_Source_Output_Dir (Tmp_Str.all)) then
Include (Out_Dirs, Get_Source_Output_Dir (Tmp_Str.all));
end if;
Free (Tmp_Str);
end loop;
Output_Prj :=
new String'(Harness_Dir_Str.all
& Directory_Separator
& Test_Prj_Prefix
& Source_Prj_Name
& ".gpr");
Create (Output_Prj.all);
S_Put (0, "with ""aunit"";");
Put_New_Line;
S_Put (0, "with ""gnattest_common.gpr"";");
Put_New_Line;
S_Put (0, "with """);
S_Put
(0,
+Relative_Path
(Create (+Source_Prj),
Create (+Harness_Dir_Str.all)) &
""";");
Put_New_Line;
S_Put
(0,
"project "
& Test_Prj_Prefix
& Base_Name (Source_Prj_Name)
& " is");
Put_New_Line;
Put_New_Line;
S_Put (3, "for Source_Dirs use");
Put_New_Line;
if Out_Dirs.Is_Empty then
S_Put (5, "(""common"");");
Put_New_Line;
Put_New_Line;
else
Out_Dirs_Cur := Out_Dirs.First;
S_Put (5, "(""");
S_Put
(0,
+Relative_Path
(Create (+Srcs.Element (Out_Dirs_Cur)),
Create (+Harness_Dir_Str.all)) &
"""");
loop
Srcs.Next (Out_Dirs_Cur);
exit when Out_Dirs_Cur = Srcs.No_Element;
S_Put (0, ",");
Put_New_Line;
S_Put (6, """");
S_Put
(0,
+Relative_Path
(Create (+Srcs.Element (Out_Dirs_Cur)),
Create (+Harness_Dir_Str.all)) &
"""");
end loop;
S_Put (0, ",");
Put_New_Line;
S_Put (6, """common"");");
Put_New_Line;
Put_New_Line;
end if;
S_Put (3, "for Object_Dir use ""test_obj"";");
Put_New_Line;
declare
Obj_Dir : constant String :=
Harness_Dir_Str.all
& Directory_Separator
& "test_obj";
Dir : File_Array_Access;
begin
Append (Dir, GNATCOLL.VFS.Create (+Obj_Dir));
Create_Dirs (Dir);
exception
when Directory_Error =>
Cmd_Error_No_Help
("cannot create directory " & Obj_Dir);
end;
S_Put (3, "for Languages use Gnattest_Common'Languages & (""Ada"");");
Put_New_Line;
S_Put (3, "package Compiler renames Gnattest_Common.Compiler;");
Put_New_Line;
Put_New_Line;
if IDE_Package_Present then
S_Put
(3,
"package Ide renames " &
Base_Name (Source_Prj, File_Extension (Source_Prj)) &
".Ide;");
Put_New_Line;
Put_New_Line;
end if;
if Make_Package_Present then
S_Put
(3,
"package Make renames " &
Base_Name (Source_Prj, File_Extension (Source_Prj)) &
".Make;");
Put_New_Line;
Put_New_Line;
end if;
S_Put (3, "package Coverage is");
Put_New_Line;
S_Put (6, "for Units use ();");
Put_New_Line;
S_Put (3, "end Coverage;");
Put_New_Line;
Put_New_Line;
S_Put
(0,
"end "
& Test_Prj_Prefix
& Base_Name (Source_Prj_Name)
& ";");
Put_New_Line;
Close_File;
Tmp_Test_Prj := new String'(Normalize_Pathname
(Name => Output_Prj.all,
Case_Sensitive => False));
end Generate_Project_File;
-------------------
-- Process_Stubs --
-------------------
procedure Process_Stubs (List : Ada_Nodes_List.List)
is
Cur : Ada_Nodes_List.Cursor;
Str : String_Access;
Stub_Success : Boolean;
use Ada_Nodes_List;
begin
if Is_Empty (List) then
return;
end if;
-- Once we change the context, contents of List won't make sense.
Cur := List.First;
while Cur /= Ada_Nodes_List.No_Element loop
Str := new String'(Ada_Nodes_List.Element (Cur).Unit.Get_Filename);
if Get_Source_Body (Str.all) /= "" then
if not Source_Stubbed (Str.all) then
begin
Test.Stub.Process_Unit
(Ada_Nodes_List.Element (Cur),
Get_Source_Stub_Dir (Str.all)
& GNAT.OS_Lib.Directory_Separator
& Base_Name (Get_Source_Body (Str.all)),
Get_Source_Stub_Dir (Str.all)
& GNAT.OS_Lib.Directory_Separator
& Get_Source_Stub_Data_Spec (Str.all),
Get_Source_Stub_Dir (Str.all)
& GNAT.OS_Lib.Directory_Separator
& Get_Source_Stub_Data_Body (Str.all));
Stub_Success := True;
exception
when Test.Stub.Stub_Processing_Error =>
-- Error message has been printed already
Stub_Success := False;
end;
if Stub_Success then
Mark_Sourse_Stubbed (Str.all);
end if;
end if;
end if;
Free (Str);
Next (Cur);
end loop;
end Process_Stubs;
------------------------------------
-- Is_Declared_In_Regular_Package --
------------------------------------
function Is_Declared_In_Regular_Package
(Elem : Ada_Node'Class) return Boolean
is
Nesting : constant Ada_Node_Array := Parents (Elem);
begin
for I in Nesting'First + 1 .. Nesting'Last loop
if Kind (Nesting (I)) = Ada_Generic_Package_Decl then
return False;
end if;
end loop;
return True;
end Is_Declared_In_Regular_Package;
------------------------
-- Put_Wrapper_Rename --
------------------------
procedure Put_Wrapper_Rename (Span : Natural; Current_Subp : Subp_Info)
is
Spec : constant Base_Subp_Spec'Class :=
(if Current_Subp.Subp_Declaration.Kind = Ada_Expr_Function then
Current_Subp.Subp_Declaration.As_Expr_Function.F_Subp_Spec
else
Current_Subp.Subp_Declaration.As_Basic_Subp_Decl.P_Subp_Decl_Spec);
Params : constant Param_Spec_Array := Spec.P_Params;
Is_Func : constant Boolean :=
Is_Function (Current_Subp.Subp_Declaration.As_Basic_Decl);
begin
if Is_Func then
S_Put
(Span,
"function " & Current_Subp.Subp_Name_Image.all);
else
S_Put
(Span,
"procedure " & Current_Subp.Subp_Name_Image.all);
end if;
if Params'Length /= 0 then
S_Put (1, "(");
for P in Params'Range loop
S_Put (0, Node_Image (Params (P)));
if P = Params'Last then
S_Put (0, ")");
else
S_Put (0, "; ");
end if;
end loop;
end if;
if Is_Func then
S_Put (1, "return " & Node_Image (Spec.P_Returns));
end if;
S_Put
(1,
"renames "
& Wrapper_Prefix
& Current_Subp.Subp_Mangle_Name.all
& ";");
New_Line_Count;
end Put_Wrapper_Rename;
-------------------------------
-- Generate_Function_Wrapper --
-------------------------------
procedure Generate_Function_Wrapper (Current_Subp : Subp_Info)
is
Spec : constant Base_Subp_Spec'Class :=
(if Current_Subp.Subp_Declaration.Kind = Ada_Expr_Function then
Current_Subp.Subp_Declaration.As_Expr_Function.F_Subp_Spec
else
Current_Subp.Subp_Declaration.As_Basic_Subp_Decl.P_Subp_Decl_Spec);
Params : constant Param_Spec_Array := Spec.P_Params;
Str_Set : String_Set.Set;
Cur : String_Set.Cursor;
begin
S_Put (0, GT_Marker_Begin);
New_Line_Count;
S_Put
(3,
"function " &
Wrapper_Prefix &
Current_Subp.Subp_Mangle_Name.all);
for I in Params'Range loop
if I = Params'First then
S_Put (0, " (");
end if;
S_Put (0, Node_Image (Params (I)));
if I = Params'Last then
S_Put (0, ") ");
else
S_Put (0, "; ");
end if;
end loop;
S_Put (0, " return " & Node_Image (Spec.P_Returns));
New_Line_Count;
S_Put (3, "is");
New_Line_Count;
Str_Set := Current_Subp.TC_Info.Params_To_Temp;
Cur := Str_Set.First;
loop
exit when Cur = String_Set.No_Element;
S_Put (6, String_Set.Element (Cur));
New_Line_Count;
String_Set.Next (Cur);
end loop;
S_Put (3, "begin");
New_Line_Count;
if Current_Subp.TC_Info.Req_Image.all /= "" then
S_Put (6, "begin");
New_Line_Count;
S_Put (9, "pragma Assert");
New_Line_Count;
S_Put
(11,
"(" &
Current_Subp.TC_Info.Req_Image.all &
");");
New_Line_Count;
S_Put (9, "null;");
New_Line_Count;
S_Put (6, "exception");
New_Line_Count;
S_Put (12, "when System.Assertions.Assert_Failure =>");
New_Line_Count;
S_Put (15, "AUnit.Assertions.Assert");
New_Line_Count;
S_Put (17, "(False,");
New_Line_Count;
S_Put
(18,
"""req_sloc("
& Current_Subp.TC_Info.Req_Line.all
& "):"
& Current_Subp.TC_Info.Name.all
& " test requirement violated"");");
New_Line_Count;
S_Put (6, "end;");
New_Line_Count;
end if;
S_Put (6, "declare");
New_Line_Count;
S_Put
(9,
Current_Subp.Subp_Mangle_Name.all
& "_Result : constant "
& Node_Image (Spec.P_Returns)
& " := GNATtest_Generated.GNATtest_Standard."
& Current_Subp.Nesting.all
& "."
& Current_Subp.Subp_Name_Image.all);
if Params'Length = 0 then
S_Put (0, ";");
else
S_Put (1, "(");
for I in Params'Range loop
declare
Name_List : constant Defining_Name_List := F_Ids (Params (I));
Idx : Positive :=
Name_List.Defining_Name_List_First;
begin
while Name_List.Defining_Name_List_Has_Element (Idx) loop
S_Put
(0,
Node_Image (Name_List.Defining_Name_List_Element (Idx)));
Idx := Name_List.Defining_Name_List_Next (Idx);
if Name_List.Defining_Name_List_Has_Element (Idx) then
S_Put (0, ", ");
end if;
end loop;
end;
if I = Params'Last then
S_Put (0, ");");
else
S_Put (0, ", ");
end if;
end loop;
end if;
New_Line_Count;
S_Put (6, "begin");
New_Line_Count;
if Current_Subp.TC_Info.Ens_Image.all /= "" then
S_Put (9, "begin");
New_Line_Count;
S_Put (12, "pragma Assert");
New_Line_Count;
S_Put
(14,
"(" &
Current_Subp.TC_Info.Ens_Image.all &
");");
New_Line_Count;
S_Put (12, "null;");
New_Line_Count;
S_Put (9, "exception");
New_Line_Count;
S_Put (12, "when System.Assertions.Assert_Failure =>");
New_Line_Count;
S_Put (15, "AUnit.Assertions.Assert");
New_Line_Count;
S_Put (17, "(False,");
New_Line_Count;
S_Put
(18,
"""ens_sloc("
& Current_Subp.TC_Info.Ens_Line.all
& "):"
& Current_Subp.TC_Info.Name.all
& " test commitment violated"");");
New_Line_Count;
S_Put (9, "end;");
New_Line_Count;
end if;
S_Put
(9,
"return " &
Current_Subp.Subp_Mangle_Name.all &
"_Result;");
New_Line_Count;
S_Put (6, "end;");
New_Line_Count;
S_Put
(3,
"end " &
Wrapper_Prefix &
Current_Subp.Subp_Mangle_Name.all &
";");
New_Line_Count;
S_Put (0, GT_Marker_End);
New_Line_Count;
end Generate_Function_Wrapper;
--------------------------------
-- Generate_Procedure_Wrapper --
--------------------------------
procedure Generate_Procedure_Wrapper (Current_Subp : Subp_Info)
is
Spec : constant Base_Subp_Spec :=
Current_Subp.Subp_Declaration.As_Basic_Subp_Decl.P_Subp_Decl_Spec;
Params : constant Param_Spec_Array := Spec.P_Params;
Str_Set : String_Set.Set;
Cur : String_Set.Cursor;
begin
S_Put (0, GT_Marker_Begin);
New_Line_Count;
S_Put
(3,
"procedure " &
Wrapper_Prefix &
Current_Subp.Subp_Mangle_Name.all);
for I in Params'Range loop
if I = Params'First then
S_Put (0, " (");
end if;
S_Put (0, Node_Image (Params (I)));
if I = Params'Last then
S_Put (0, ") ");
else
S_Put (0, "; ");
end if;
end loop;
New_Line_Count;
S_Put (3, "is");
New_Line_Count;
Str_Set := Current_Subp.TC_Info.Params_To_Temp;
Cur := Str_Set.First;
loop
exit when Cur = String_Set.No_Element;
S_Put (6, String_Set.Element (Cur));
New_Line_Count;
String_Set.Next (Cur);
end loop;
S_Put (3, "begin");
New_Line_Count;
if Current_Subp.TC_Info.Req_Image.all /= "" then
S_Put (6, "begin");
New_Line_Count;
S_Put (9, "pragma Assert");
New_Line_Count;
S_Put
(11,
"(" &
Current_Subp.TC_Info.Req_Image.all &
");");
New_Line_Count;
S_Put (9, "null;");
New_Line_Count;
S_Put (6, "exception");
New_Line_Count;
S_Put (9, "when System.Assertions.Assert_Failure =>");
New_Line_Count;
S_Put (12, "AUnit.Assertions.Assert");
New_Line_Count;
S_Put (14, "(False,");
New_Line_Count;
S_Put
(15,
"""req_sloc("
& Current_Subp.TC_Info.Req_Line.all
& "):"
& Current_Subp.TC_Info.Name.all
& " test requirement violated"");");
New_Line_Count;
S_Put (6, "end;");
New_Line_Count;
end if;
S_Put
(6,
"GNATtest_Generated.GNATtest_Standard." &
Current_Subp.Nesting.all &
"." &
Current_Subp.Subp_Text_Name.all);
if Params'Length = 0 then
S_Put (0, ";");
else
S_Put (1, "(");
for I in Params'Range loop
declare
Name_List : constant Defining_Name_List := F_Ids (Params (I));
Idx : Positive :=
Name_List.Defining_Name_List_First;
begin
while Name_List.Defining_Name_List_Has_Element (Idx) loop
S_Put
(0,
Node_Image (Name_List.Defining_Name_List_Element (Idx)));
Idx := Name_List.Defining_Name_List_Next (Idx);
if Name_List.Defining_Name_List_Has_Element (Idx) then
S_Put (0, ", ");
end if;
end loop;
end;
if I = Params'Last then
S_Put (0, ");");
else
S_Put (0, ", ");
end if;
end loop;
end if;
New_Line_Count;
if Current_Subp.TC_Info.Ens_Image.all /= "" then
S_Put (6, "begin");
New_Line_Count;
S_Put (9, "pragma Assert");
New_Line_Count;
S_Put
(11,
"(" &
Current_Subp.TC_Info.Ens_Image.all &
");");
New_Line_Count;
S_Put (9, "null;");
New_Line_Count;
S_Put (6, "exception");
New_Line_Count;
S_Put (9, "when System.Assertions.Assert_Failure =>");
New_Line_Count;
S_Put (12, "AUnit.Assertions.Assert");
New_Line_Count;
S_Put (14, "(False,");
New_Line_Count;
S_Put
(15,
"""ens_sloc("
& Current_Subp.TC_Info.Ens_Line.all
& "):"
& Current_Subp.TC_Info.Name.all
& " test commitment violated"");");
New_Line_Count;
S_Put (6, "end;");
New_Line_Count;
end if;
S_Put
(3,
"end " &
Wrapper_Prefix &
Current_Subp.Subp_Mangle_Name.all &
";");
New_Line_Count;
S_Put (0, GT_Marker_End);
New_Line_Count;
end Generate_Procedure_Wrapper;
-----------------------------
-- Update_Generic_Packages --
-----------------------------
procedure Update_Generic_Packages (Gen_Pack : Generic_Package) is
Cur : Generic_Package_Storage.Cursor := Gen_Package_Storage.First;
GP : Generic_Package;
use Generic_Package_Storage;
begin
while Cur /= Generic_Package_Storage.No_Element loop
GP := Generic_Package_Storage.Element (Cur);
if GP.Name.all = Gen_Pack.Name.all then
if GP.Sloc /= null then
-- Same package can be added several times.
return;
end if;
GP.Sloc := Gen_Pack.Sloc;
Gen_Package_Storage.Replace_Element (Cur, GP);
return;
end if;
Next (Cur);
end loop;
Gen_Package_Storage.Append (Gen_Pack);
end Update_Generic_Packages;
-----------------------------
-- Update_Generic_Packages --
-----------------------------
procedure Update_Generic_Packages (Instantiation : String) is
Cur : Generic_Package_Storage.Cursor := Gen_Package_Storage.First;
GP : Generic_Package;
use Generic_Package_Storage;
begin
while Cur /= Generic_Package_Storage.No_Element loop
GP := Generic_Package_Storage.Element (Cur);
if GP.Name.all = Instantiation then
if GP.Has_Instantiation then
-- Same package can be instantiated multiple times.
return;
end if;
GP.Has_Instantiation := True;
Gen_Package_Storage.Replace_Element (Cur, GP);
return;
end if;
Next (Cur);
end loop;
-- Instantiation is processed ahead of coresponding generic.
-- Adding a template for it to later fill in the sloc.
GP.Name := new String'(Instantiation);
GP.Sloc := null;
GP.Has_Instantiation := True;
Gen_Package_Storage.Append (GP);
end Update_Generic_Packages;
------------------------
-- Report_Tests_Total --
------------------------
procedure Report_Tests_Total is
Cur : Tests_Per_Unit.Cursor := Test_Info.First;
begin
loop
exit when Cur = Tests_Per_Unit.No_Element;
Report_Std
(Natural'Image (Tests_Per_Unit.Element (Cur)) &
" testable subprograms in " &
Base_Name (Tests_Per_Unit.Key (Cur)));
Tests_Per_Unit.Next (Cur);
end loop;
Test_Info.Clear;
Report_Std
("gnattest:" &
Natural'Image (All_Tests_Counter) &
" testable subprogram(s) processed");
Report_Std
("gnattest:" &
Natural'Image (New_Tests_Counter) &
" new skeleton(s) generated");
end Report_Tests_Total;
---------------------------------
-- Report_Unused_Generic_Tests --
---------------------------------
procedure Report_Unused_Generic_Tests is
begin
for GP of Gen_Package_Storage loop
if not GP.Has_Instantiation then
Report_Std
("warning: (gnattest) "
& GP.Sloc.all
& ": no instance of "
& GP.Name.all);
Report_Std
(" corresponding tests are not included into harness");
Free (GP.Name);
Free (GP.Sloc);
end if;
end loop;
Gen_Package_Storage.Clear;
end Report_Unused_Generic_Tests;
end Test.Skeleton;