Johannes Kanig [Wed, 3 Jul 2019 08:16:15 +0000 (08:16 +0000)]
[Ada] New routine to access file on command line
This patch adds a new routine to query the first file argument of the
commandline without moving to the next file. This is needed in SPARK.
There is no impact on compilation.
2019-07-03 Johannes Kanig <kanig@adacore.com>
gcc/ada/
* osint.ads, osint.adb (Get_First_Main_File_Name): New routine
to access the first file provided on the command line.
From-SVN: r272984
Ed Schonberg [Wed, 3 Jul 2019 08:16:11 +0000 (08:16 +0000)]
[Ada] Crash on front-end inlining of subp. with aspect specifications
This patch fixes a gap in the handling of formals when inlining a call
to a subprogram marked Inline_Always. For the inlining, the formals are
replaced by the actuals in the block constructed for inlining, The
traversal that performs this replacement does not apply to aspect
specifications that may appear in the original body, because these
aspects are only indirectly reachable from the nodes to which they
apply: a separate traversal is required to perform the replacement in
the expressions for any aspect specification present in the source.
2019-07-03 Ed Schonberg <schonberg@adacore.com>
gcc/ada/
* inline.adb (Process_Formals_In_Aspects): New procedure within
Expand_Inlined_Call, to perform a replacement of references to
formals that appear in aspect specifications within the body
being inlined.
gcc/testsuite/
* gnat.dg/inline16.adb, gnat.dg/inline16_gen.adb,
gnat.dg/inline16_gen.ads, gnat.dg/inline16_types.ads: New
testcase.
From-SVN: r272983
Justin Squirek [Wed, 3 Jul 2019 08:16:06 +0000 (08:16 +0000)]
[Ada] Incorrect expansion on renamings of formal parameters
This patch fixes an issue whereby a renaming of an unconstrained formal
parameter leads to spurious runtime errors; manifesting either as a
storage or constraint error due to incorrect bounds being assumed.
This issue also occurs when the renamings are implicit such as through
generic instantiations.
2019-07-03 Justin Squirek <squirek@adacore.com>
gcc/ada/
* sem_ch8.adb (Analyze_Object_Renaming): Add call to search for
the appropriate actual subtype of the object renaming being
analyzed.
(Check_Constrained_Object): Minor cleanup.
gcc/testsuite/
* gnat.dg/renaming13.adb, gnat.dg/renaming14.adb: New testcases.
From-SVN: r272982
Yannick Moy [Wed, 3 Jul 2019 08:16:01 +0000 (08:16 +0000)]
[Ada] Refine pointer support in SPARK
Refine the implementation of pointer support for SPARK analysis.
There is no impact on compilation.
2019-07-03 Yannick Moy <moy@adacore.com>
gcc/ada/
* sem_spark.adb (Get_Observed_Or_Borrowed_Expr): New function to
return go through traversal function call.
(Check_Type): Consistently use underlying type.
(Get_Perm): Adapt for case of elaboration code where variables
are not declared in the environment. Remove incorrect handling
of borrow and observe.
From-SVN: r272981
Hristian Kirtchev [Wed, 3 Jul 2019 08:15:54 +0000 (08:15 +0000)]
[Ada] Spurious visibility error in inlined function
This patch corrects the use of tree replication when inlining a function
that returns an unconstrained result, and its sole statement is an
extended return statement. The use of New_Copy_Tree ensires that global
references saved in a generic template are properly carried over when
the function is instantiated and inlined.
2019-07-03 Hristian Kirtchev <kirtchev@adacore.com>
gcc/ada/
* inline.adb (Build_Return_Object_Formal): New routine.
(Can_Split_Unconstrained_Function): Code clean up.
(Copy_Formals,Copy_Return_Object): New routines.
(Split_Unconstrained_Function): Code clean up and refactoring.
gcc/testsuite/
* gnat.dg/inline15.adb, gnat.dg/inline15_gen.adb,
gnat.dg/inline15_gen.ads, gnat.dg/inline15_types.ads: New
testcase.
From-SVN: r272980
Gary Dismukes [Wed, 3 Jul 2019 08:15:39 +0000 (08:15 +0000)]
[Ada] Minor editorial corrections and reformatting
2019-07-03 Gary Dismukes <dismukes@adacore.com>
gcc/ada/
* bindo-augmentors.adb, bindo-augmentors.ads,
bindo-builders.ads, bindo-elaborators.adb, sem_ch12.adb,
sem_ch13.adb, sem_spark.adb, sinfo.ads: Minor editorial
corrections and reformatting.
From-SVN: r272979
Bob Duff [Wed, 3 Jul 2019 08:15:28 +0000 (08:15 +0000)]
[Ada] Improve warnings about infinite loops
The compiler now has fewer false alarms when warning about infinite
loops. For example, a loop of the form "for X of A ...", where A is an
array, cannot be infinite. The compiler no longer warns in this case.
2019-07-03 Bob Duff <duff@adacore.com>
gcc/ada/
* sem_warn.adb (Check_Infinite_Loop_Warning): Avoid the warning
if an Iterator_Specification is present.
gcc/testsuite/
* gnat.dg/warn20.adb, gnat.dg/warn20_pkg.adb,
gnat.dg/warn20_pkg.ads: New testcase.
From-SVN: r272978
Bob Duff [Wed, 3 Jul 2019 08:15:03 +0000 (08:15 +0000)]
[Ada] Document default new-line behavior for GNATpp
2019-07-03 Bob Duff <duff@adacore.com>
gcc/ada/
* doc/gnat_ugn/gnat_utility_programs.rst: Document default
new-line behavior.
From-SVN: r272977
Hristian Kirtchev [Wed, 3 Jul 2019 08:14:57 +0000 (08:14 +0000)]
[Ada] ABE checks v3.0, foundations of Elaboration order v4.0
------------------------
-- Elaboration checks --
------------------------
The dynamic ABE checks model now emits the same diagnostics as those of the
static ABE checks model.
The ABE checks mechanism has been redesigned and refactored in the face of
increasing requirements. Most of the functionality can now be toggled, thus
allowing for various combinations of behavior. The combinations are defined
as "initial states" and may be further altered.
Scenarios and targets have been distinctly separated at the higher level,
instead of directly working with nodes and entitites. Scenarios and targets
now carry a representation which removes the need to constantly recompute
relevant attributes, and offers a common interface for the various processors.
Most processing has now been refactored into "services" which perform a single
ABE-related function.
-----------------------
-- Elaboration order --
-----------------------
A new elaboration order mechanism based on the use of an invocation graph to
provide extra information about the flow of execution at elaboration time has
been introduced.
The ABE checks mechanism has been altered to encode pieces of the invocation
graph in the associated ALI files of units.
The new elaboration order mechanism reconstructs the full invocation graph at
bind time, and coupled with the library item graph, determines the elaboration
order of units.
The new elaboration order mechanism is currently inaccessible.
------------
-- Source --
------------
-- pack.ads
package Pack is
procedure ABE_Proc;
procedure Safe_Proc;
end Pack;
-- pack.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Pack is
function Call_Proc (ABE : Boolean) return Integer;
procedure Safe_Proc is
begin
Put_Line ("safe");
end Safe_Proc;
function Call_Proc (ABE : Boolean) return Integer is
begin
if ABE then
ABE_Proc;
else
Safe_Proc;
end if;
return 0;
end Call_Proc;
Elab_1 : constant Integer := Call_Proc (ABE => False);
Elab_2 : constant Integer := Call_Proc (ABE => True);
procedure ABE_Proc is
begin
Put_Line ("ABE");
end ABE_Proc;
end Pack;
-- main.adb
with Pack;
procedure Main is begin null; end Main;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -f -q -gnatE main.adb
$ ./main
$ gnatmake -f -q -gnatE main.adb -gnatDG -gnatwL
$ grep -c "safeE" pack.adb.dg
pack.adb:14:10: warning: cannot call "ABE_Proc" before body seen
pack.adb:14:10: warning: Program_Error may be raised at run time
pack.adb:14:10: warning: body of unit "Pack" elaborated
pack.adb:14:10: warning: function "Call_Proc" called at line 22
pack.adb:14:10: warning: procedure "ABE_Proc" called at line 14
pack.adb:14:10: warning: cannot call "ABE_Proc" before body seen
pack.adb:14:10: warning: Program_Error may be raised at run time
pack.adb:14:10: warning: body of unit "Pack" elaborated
pack.adb:14:10: warning: function "Call_Proc" called at line 23
pack.adb:14:10: warning: procedure "ABE_Proc" called at line 14
safe
raised PROGRAM_ERROR : pack.adb:14 access before elaboration
0
2019-07-03 Hristian Kirtchev <kirtchev@adacore.com>
gcc/ada/
* ali.adb: Add with and use clauses for GNAT,
GNAT.Dynamic_HTables, and Snames. Add a map from invocation
signature records to invocation signature ids. Add various
encodings of invocation-related attributes. Sort and update
table Known_ALI_Lines.
(Add_Invocation_Construct, Add_Invocation_Relation,
Body_Placement_Kind_To_Code, Code_To_Body_Placement_Kind,
Code_To_Invocation_Construct_Kind, Code_To_Invocation_Kind,
Code_To_Invocation_Graph_Line_Kind, Destroy, Hash): New
routines.
(Initialize_ALI): Sort the initialization sequence. Add
initialization for all invocation-related tables.
(Invocation_Construct_Kind_To_Code,
Invocation_Graph_Line_Kind_To_Code, Invocation_Kind_To_Code,
Invocation_Signature_Of, Present): New routines.
(Scan_ALI): Add the default values for invocation-related ids.
Scan invocation graph lines.
(Scan_Invocation_Graph_Line): New routine.
* ali.ads: Add with clause for GNAT.Dynamic_Tables. Add types
for invocation constructs, relations, and signatures. Add
tables for invocation constructs, relations, and signatures.
Update Unit_Record to capture invocation-related ids. Relocate
table Unit_Id_Tables and subtypes Unit_Id_Table, Unit_Id_Array
from Binde.
(Add_Invocation_Construct, Add_Invocation_Relation,
Body_Placement_Kind_To_Code, Code_To_Body_Placement_Kind,
Code_To_Invocation_Construct_Kind, Code_To_Invocation_Kind,
Code_To_Invocation_Graph_Line_Kind,
Invocation_Construct_Kind_To_Code,
Invocation_Graph_Line_Kind_To_Code, Invocation_Kind_To_Code,
Invocation_Signature_Of, Present): New routines.
* binde.adb: Add with and use clause for Types. Add use clause
for ALI.Unit_Id_Tables;
* binde.ads: Relocate table Unit_Id_Tables and subtypes
Unit_Id_Table, Unit_Id_Array to ALI.
* bindgen.adb: Remove with and use clause for ALI.
* bindgen.ads: Remove with and use clause for Binde. Add with
and use clause for ALI.
* bindo.adb, bindo.ads, bindo-augmentors.adb,
bindo-augmentors.ads, bindo-builders.adb, bindo-builders.ads,
bindo-diagnostics.adb, bindo-diagnostics.ads,
bindo-elaborators.adb, bindo-elaborators.ads, bindo-graphs.adb,
bindo-graphs.ads, bindo-units.adb, bindo-units.ads,
bindo-validators.adb, bindo-validators.ads, bindo-writers.adb,
bindo-writers.ads: New units.
* debug.adb: Use and describe GNAT debug switches -gnatd_F and
-gnatd_G. Add GNATbind debug switches in the ranges dA .. dZ,
d.a .. d.z, d.A .. d.Z, d.1 .. d.9, d_a .. d_z, d_A .. d_Z, and
d_1 .. d_9. Use and describe GNATbind debug switches -d_A,
-d_I, -d_L, -d_N, -d_O, -d_T, and -d_V.
* exp_util.adb, exp_util.ads (Exceptions_OK): Relocate to
Sem_Util.
* gnatbind.adb: Add with and use clause for Bindo. Use the new
Bindo elaboration order only when -d_N is in effect.
* lib-writ.adb
(Column, Extra, Invoker, Kind, Line, Locations, Name, Placement,
Scope, Signature, Target): New routines.
(Write_ALI): Output all invocation-related data.
(Write_Invocation_Graph): New routine.
* lib-writ.ads: Document the invocation graph ALI line.
* namet.adb, namet.ads (Present): New routines.
* sem_ch8.adb (Find_Direct_Name): Capture the status of
elaboration checks and warnings of an identifier.
(Find_Expanded_Name): Capture the status of elaboration checks
and warnings of an expanded name.
* sem_ch12.adb (Analyze_Generic_Package_Declaration): Ensure
that invocation graph-related data within the body of the main
unit is encoded in the ALI file.
(Analyze_Generic_Subprogram_Declaration): Ensure that invocation
graph-related data within the body of the main unit is encoded
in the ALI file.
(Analyze_Package_Instantiation): Perform minimal decoration of
the instance entity.
(Analyze_Subprogram_Instantiation): Perform minimal decoration
of the instance entity.
* sem_elab.adb: Perform heavy refactoring of all code. The unit
is now split into "services" which specialize in one area of ABE
checks. Add processing in order to capture invocation-graph
related attributes of the main unit, and encode them in the ALI
file. The Processing phase can now operate in multiple modes,
all described by type Processing_Kind. Scenarios and targets
are now distinct at the higher level, and carry their own
representations. This eliminates the need to constantly
recompute their attributes, and offers the various processors a
uniform interface. The various initial states of the Processing
phase are now encoded using type Processing_In_State, and
xxx_State constants.
* sem_elab.ads: Update the literals of type
Enclosing_Level_Kind. Add Inline pragmas on several routines.
* sem_prag.adb (Process_Inline): Ensure that invocation
graph-related data within the body of the main unit is encoded
in the ALI file.
* sem_util.adb (Enclosing_Generic_Body, Enclosing_Generic_Unit):
Code clean up.
(Exceptions_OK): Relocated from Sem_Util.
(Mark_Save_Invocation_Graph_Of_Body): New routine.
* sem_util.ads (Exceptions_OK): Relocated from Sem_Util.
(Mark_Save_Invocation_Graph_Of_Body): New routine.
* sinfo.adb (Is_Elaboration_Checks_OK_Node): Now applicable to
N_Variable_Reference_Marker.
(Is_Elaboration_Warnings_OK_Node): Now applicable to
N_Expanded_Name, N_Identifier, N_Variable_Reference_Marker.
(Is_Read): Use Flag4.
(Is_SPARK_Mode_On_Node): New applicable to
N_Variable_Reference_Marker.
(Is_Write): Use Flag5.
(Save_Invocation_Graph_Of_Body): New routine.
(Set_Is_Elaboration_Checks_OK_Node): Now applicable to
N_Variable_Reference_Marker.
(Set_Is_Elaboration_Warnings_OK_Node): Now applicable to
N_Expanded_Name, N_Identifier, N_Variable_Reference_Marker.
(Set_Is_SPARK_Mode_On_Node): New applicable to
N_Variable_Reference_Marker.
(Set_Save_Invocation_Graph_Of_Body): New routine.
* sinfo.ads: Update the documentation of attributes
Is_Elaboration_Checks_OK_Node, Is_Elaboration_Warnings_OK_Node,
Is_SPARK_Mode_On_Node. Update the flag usage of attributes
Is_Read, Is_Write. Add attribute Save_Invocation_Graph_Of_Body
and update its occurrence in nodes.
(Save_Invocation_Graph_Of_Body): New routine along with pragma
Inline.
(Set_Save_Invocation_Graph_Of_Body): New routine along with
pragma Inline.
* switch-b.adb (Scan_Binder_Switches): Refactor the scanning of
debug switches.
(Scan_Debug_Switches): New routine.
* libgnat/g-dynhta.adb, libgnat/g-dynhta.ads (Contains): New routine.
* libgnat/g-graphs.adb (Associate_Vertices): Update the use of
Component_Vertex_Iterator.
(Contains_Component, Contains_Edge, Contains_Vertex, Has_Next):
Reimplemented.
(Iterate_Component_Vertices): New routine.
(Iterate_Vertices): Removed.
(Next): Update the parameter profile.
(Number_Of_Component_Vertices, Number_Of_Outgoing_Edges): New
routines.
* libgnat/g-graphs.ads: Update the initialization of
No_Component. Add type Component_Vertex_Iterator. Remove type
Vertex_Iterator.
(Has_Next): Add new versions and remove old ones.
(Iterate_Component_Vertices): New routine.
(Iterate_Vertices): Removed.
(Next): Add new versions and remove old ones.
(Number_Of_Component_Vertices, Number_Of_Outgoing_Edges): New
routines.
* libgnat/g-sets.adb (Contains): Reimplemented.
* gcc-interface/Make-lang.in (GNATBIND_OBJS): Add
GNAT.Dynamic_HTables, GNAT.Graphs and Bindo units.
* rtsfind.ads: Remove extra space.
From-SVN: r272976
Yannick Moy [Wed, 3 Jul 2019 08:14:52 +0000 (08:14 +0000)]
[Ada] SPARK pointer support extended to local borrowers and observers
SPARK rules allow local borrowers and observers to be declared. During
their lifetime, the access to the borrowed/observed object is
restricted.
There is no impact on compilation.
2019-07-03 Yannick Moy <moy@adacore.com>
gcc/ada/
* sem_spark.adb: Add support for locally borrowing and observing
a path.
(Get_Root_Object): Add parameter Through_Traversal to denote
when we are interesting in getting to the traversed parameter.
(Is_Prefix_Or_Almost): New function to support detection of
illegal access to borrowed or observed paths.
(Check_Pragma): Add analysis of assertion pragmas.
From-SVN: r272975
Ed Schonberg [Wed, 3 Jul 2019 08:14:47 +0000 (08:14 +0000)]
[Ada] Spurious error with static predicate in generic unit
This patch fixes a spurious error in a generic unit that invludes a
subtype with a static predicate, when the type is used in a case
expression.
2019-07-03 Ed Schonberg <schonberg@adacore.com>
gcc/ada/
* sem_ch13.adb (Build_Predicate_Functions): In a generic context
we do not build the bodies of predicate fuctions, but the
expression in a static predicate must be elaborated to allow
case coverage checking within the generic unit.
(Build_Discrete_Static_Predicate): In a generic context, return
without building function body once the
Static_Discrete_Predicate expression for the type has been
constructed.
gcc/testsuite/
* gnat.dg/predicate6.adb, gnat.dg/predicate6.ads: New testcase.
* gnat.dg/static_pred1.adb: Remove expected error.
From-SVN: r272974
Hristian Kirtchev [Wed, 3 Jul 2019 08:14:43 +0000 (08:14 +0000)]
[Ada] Minor reformatting
2019-07-03 Hristian Kirtchev <kirtchev@adacore.com>
gcc/ada/
* bindgen.adb, inline.adb, layout.adb, sem_ch12.adb,
sem_ch13.adb, sem_ch7.adb, styleg.adb: Minor reformatting.
From-SVN: r272973
Bob Duff [Wed, 3 Jul 2019 08:14:38 +0000 (08:14 +0000)]
[Ada] Style check for mixed-case identifiers
This patch implements a new switch, -gnatyD, enables a style check that
requires defining identifiers to be in mixed case.
2019-07-03 Bob Duff <duff@adacore.com>
gcc/ada/
* par-ch3.adb (P_Defining_Identifier): Call
Check_Defining_Identifier_Casing.
* style.ads, styleg.ads, styleg.adb
(Check_Defining_Identifier_Casing): New procedure to check for
mixed-case defining identifiers.
* stylesw.ads, stylesw.adb (Style_Check_Mixed_Case_Decls): New
flag for checking for mixed-case defining identifiers.
* doc/gnat_ugn/building_executable_programs_with_gnat.rst:
Document new feature.
* gnat_ugn.texi: Regenerate.
From-SVN: r272972
Eric Botcazou [Wed, 3 Jul 2019 08:14:33 +0000 (08:14 +0000)]
[Ada] Extend -gnatw.z warning to array types
The -gnatw.z switch causes the compiler to issue a warning on record
types subject to both an alignment clause and a size clause, when the
specified size is not a multiple of the alignment in bits, because this
means that the Object_Size will be strictly larger than the specified
size.
It makes sense to extend this warning to array types, but not to the
cases of bit-packed arrays where the size is not a multiple of storage
unit and the specified alignment is the minimum one, because there would
be no way to get rid of it apart from explicitly silencing it.
The compiler must issue the warning:
p.ads:5:03: warning: size is not a multiple of alignment for "Triplet"
p.ads:5:03: warning: size of 24 specified at line 4
p.ads:5:03: warning: Object_Size will be increased to 32
on the following package:
package P is
type Triplet is new String (1 .. 3);
for Triplet'Size use 24;
for Triplet'Alignment use 4;
type Arr is array (1 .. 7) of Boolean;
pragma Pack (Arr);
for Arr'Size use 7;
for Arr'Alignment use 1;
end P;
2019-07-03 Eric Botcazou <ebotcazou@adacore.com>
gcc/ada/
* doc/gnat_ugn/building_executable_programs_with_gnat.rst
(Warning message control): Document that -gnatw.z/Z apply to
array types.
* freeze.adb (Freeze_Entity): Give -gnatw.z warning for array
types as well, but not if the specified alignment is the minimum
one.
* gnat_ugn.texi: Regenerate.
From-SVN: r272971
Bob Duff [Wed, 3 Jul 2019 08:14:29 +0000 (08:14 +0000)]
[Ada] Spell "laid" correctly
2019-07-03 Bob Duff <duff@adacore.com>
gcc/ada/
* einfo.ads, exp_util.adb, layout.ads, sinfo.ads: Spell "laid"
correctly.
From-SVN: r272970
Ed Schonberg [Wed, 3 Jul 2019 08:14:24 +0000 (08:14 +0000)]
[Ada] Spurious error on dynamic predicate in a generic context
This patch fixes a spurious error on the conformance checking between
the expression for an aspect analyzed at the freeze point of the type,
and the analysis of a copy of the expression performed at the end of the
enclosing list of declarationss. In a generic context the first may not
have been analyzed yet and this must be done before the conformance
check.
2019-07-03 Ed Schonberg <schonberg@adacore.com>
gcc/ada/
* sem_ch13.adb (Analyze_Attribute_Definition_Clause): No error
message on attribute applied to a renaming when the renamed
object is an aggregate (from code reading).
(Check_Aspect_At_End_Of_Declarations): In a generic context
where freeze nodes are not generated, the original expression
for an aspect may need to be analyzed to precent spurious
conformance errors when compared with the expression that is
anakyzed at the end of the current declarative list.
gcc/testsuite/
* gnat.dg/predicate5.adb, gnat.dg/predicate5.ads: New testcase.
From-SVN: r272969
Eric Botcazou [Wed, 3 Jul 2019 08:14:15 +0000 (08:14 +0000)]
[Ada] Fix bogus error on array with overaligned scalar component
The compiler would wrongly reject an alignment clause larger than 8 on
the component type of an array of scalars, which is valid albeit
pathological.
2019-07-03 Eric Botcazou <ebotcazou@adacore.com>
gcc/ada/
* layout.adb (Layout_Type): Do not set the component size of an
array with a scalar component if the component type is
overaligned.
gcc/testsuite/
* gnat.dg/alignment14.adb: New testcase.
From-SVN: r272968
Ed Schonberg [Wed, 3 Jul 2019 08:14:10 +0000 (08:14 +0000)]
[Ada] Make loop labels unique for front-end inlined calls
This patch transforms loop labels in the body of subprograms that are to
be inlined by the front-end, to prevent accidental duplication of loop
labels, which might make the resulting source illegal.
----
Source program:
----
package P is
procedure Get_Rom_Addr_Offset
with Inline_Always;
end P;
----
package body P is
procedure Get_Rom_Addr_Offset is
X : Integer;
begin
Main_Block :
for I in 1 .. 10 loop
X := 2;
exit Main_Block when I > 4;
other_loop:
for J in character'('a') .. 'z' loop
if I < 5 then
exit Main_Block when J = 'k';
else
Exit Other_Loop;
end if;
end loop other_loop;
end loop Main_Block;
end Get_Rom_Addr_Offset;
procedure P2 is
begin
Main_Block :
for I in 1 .. 1 loop
Get_Rom_Addr_Offset;
end loop Main_Block;
end P2;
end P;
----
Command:
gcc -c -gnatN -gnatd.u -gnatDG p.adb
----
Output
----
package body p is
procedure p__get_rom_addr_offset is
x : integer;
other_loop : label
main_block : label
begin
main_block : for i in 1 .. 10 loop
x := 2;
exit main_block when i > 4;
other_loop : for j in 'a' .. 'z' loop
if i < 5 then
exit main_block when j = 'k';
else
exit other_loop;
end if;
end loop other_loop;
end loop main_block;
return;
end p__get_rom_addr_offset;
procedure p__p2 is
main_block : label
begin
main_block : for i in 1 .. 1 loop
B6b : declare
x : integer;
other_loopL10b : label
main_blockL9b : label
begin
main_blockL9b : for i in 1 .. 10 loop
x := 2;
exit main_blockL9b when i > 4;
other_loopL10b : for j in 'a' .. 'z' loop
if i < 5 then
exit main_blockL9b when j = 'k';
else
exit other_loopL10b;
end if;
end loop other_loopL10b;
end loop main_blockL9b;
end B6b;
end loop main_block;
return;
end p__p2;
begin
null;
end p;
2019-07-03 Ed Schonberg <schonberg@adacore.com>
gcc/ada/
* inline.adb (Make_Loop_Labels_Unique): New procedure to modify
the source code of subprograms that are inlined by the
front-end, to prevent accidental duplication between loop labels
in the inlined code and the code surrounding the inlined call.
From-SVN: r272967
Hristian Kirtchev [Wed, 3 Jul 2019 08:14:05 +0000 (08:14 +0000)]
[Ada] Update the section on resolving elaboration circularities
2019-07-03 Hristian Kirtchev <kirtchev@adacore.com>
gcc/ada/
* doc/gnat_ugn/elaboration_order_handling_in_gnat.rst: Update
the section on resolving elaboration circularities to eliminate
certain combinations of switches which together do not produce
the desired effect and confuse users.
* gnat_ugn.texi: Regenerate.
From-SVN: r272966
Arnaud Charlet [Wed, 3 Jul 2019 08:14:00 +0000 (08:14 +0000)]
[Ada] Add a gnatbind option to generate C code
2019-07-03 Arnaud Charlet <charlet@adacore.com>
gcc/ada/
* bindgen.adb (Gen_Main): Disable generation of reference to
Ada_Main_Program_Name for CCG.
* bindusg.adb (Display): Add -G to the command-line usage for
gnatbind.
* opt.ads (Generate_C_Code): Update comment.
* switch-b.adb (Scan_Binder_Switches): Add handling for -G.
From-SVN: r272965
Arnaud Charlet [Wed, 3 Jul 2019 08:13:55 +0000 (08:13 +0000)]
[Ada] Do not consider inlined subprograms when generating C code
2019-07-03 Arnaud Charlet <charlet@adacore.com>
gcc/ada/
* sem_ch7.adb (Has_Referencer): Do not consider inlined
subprograms when generating C code, which allows us to generate
static inline subprograms.
From-SVN: r272964
Justin Squirek [Wed, 3 Jul 2019 08:13:51 +0000 (08:13 +0000)]
[Ada] Missing consistency check for constant modifier
This patch fixes an issue whereby instantiations of generic packages
were incorrectly allowed despite formal and actual subprograms not
having matching declarations with anonymous constant access type
parameters.
------------
-- Source --
------------
-- gen1.ads
package Gen1 is
generic
with procedure View (IA : not null access constant Integer);
procedure Dispatch (IA : access Integer);
end;
-- gen2.adb
package body Gen1 is
procedure Dispatch (IA : access Integer) is
begin
View (IA);
end;
end;
-- bad1.ads
with Gen1;
package Bad1 is
procedure Bad_View (IA : not null access Integer);
procedure Bad_Dispatch is new Gen1.Dispatch (Bad_View);
end;
-- bad1.adb
package body Bad1 is
procedure Bad_View (IA : not null access Integer) is
begin
IA.all := IA.all + 1;
end;
end;
-- gen2.ads
package Gen2 is
generic
with procedure View (IA : access constant Integer);
procedure Dispatch (IA : access Integer);
end;
-- gen2.adb
package body Gen2 is
procedure Dispatch (IA : access Integer) is
begin
View (IA);
end;
end;
-- bad2.ads
with Gen2;
package Bad2 is
procedure Bad_View (IA : access Integer);
procedure Bad_Dispatch is new Gen2.Dispatch (Bad_View);
end;
-- bad2.adb
package body Bad2 is
procedure Bad_View (IA : access Integer) is
begin
IA.all := IA.all + 1;
end;
end;
-----------------
-- Compilation --
-----------------
$ gnatmake -q bad1.adb
$ bad1.ads:4:04: instantiation error at gen1.ads:3
$ bad1.ads:4:04: not mode conformant with declaration at line 3
$ bad1.ads:4:04: constant modifier does not match
$ gnatmake: "bad1.adb" compilation error
$ gnatmake -q bad2.adb
$ bad2.ads:4:04: instantiation error at gen2.ads:3
$ bad2.ads:4:04: not mode conformant with declaration at line 3
$ bad2.ads:4:04: constant modifier does not match
$ gnatmake: "bad2.adb" compilation error
2019-07-03 Justin Squirek <squirek@adacore.com>
gcc/ada/
* sem_ch6.adb (Check_Conformance): Add expression checking for
constant modifiers in anonymous access types (in addition to
"non-null" types) so that they are considered "matching" for
subsequent conformance tests.
From-SVN: r272963
Arnaud Charlet [Wed, 3 Jul 2019 08:13:46 +0000 (08:13 +0000)]
[Ada] Clarify wording on documentation for No_Multiple_Elaboration
2019-07-03 Arnaud Charlet <charlet@adacore.com>
gcc/ada/
* doc/gnat_rm/standard_and_implementation_defined_restrictions.rst:
Clarify wording on No_Multiple_Elaboration.
* gnat_rm.texi: Regenerate.
From-SVN: r272962
Ed Schonberg [Wed, 3 Jul 2019 08:13:41 +0000 (08:13 +0000)]
[Ada] Spurious error on predicate of subtype in generic
This patch fixes a spurious error on a dynamic predicate of a record
subtype when the expression for the predicate includes a selected
component that denotes a component of the subtype.
2019-07-03 Ed Schonberg <schonberg@adacore.com>
gcc/ada/
* sem_ch8.adb (Find_Selected_Component): If the prefix is the
current instance of a type or subtype, complete the resolution
of the name by finding the component of the type denoted by the
selector name.
gcc/testsuite/
* gnat.dg/predicate4.adb, gnat.dg/predicate4_pkg.ads: New
testcase.
From-SVN: r272961
Eric Botcazou [Wed, 3 Jul 2019 08:13:34 +0000 (08:13 +0000)]
[Ada] Document that boolean types with convention C now map to C99 bool
2019-07-03 Eric Botcazou <ebotcazou@adacore.com>
gcc/ada/
* doc/gnat_rm/interfacing_to_other_languages.rst (Interfacing to C):
Document that boolean types with convention C now map to C99 bool.
* gnat_rm.texi: Regenerate.
From-SVN: r272960
Javier Miranda [Wed, 3 Jul 2019 08:13:29 +0000 (08:13 +0000)]
[Ada] Exp_Attr: remove dead code
2019-07-03 Javier Miranda <miranda@adacore.com>
gcc/ada/
* exp_attr.adb (Expand_Min_Max_Attribute): Code cleanup:
removing code that it is now never executed in the CCG compiler
(dead code).
From-SVN: r272959
Jakub Jelinek [Wed, 3 Jul 2019 05:03:58 +0000 (07:03 +0200)]
tree-core.h (enum omp_clause_code): Add OMP_CLAUSE__SCANTEMP_ clause.
* tree-core.h (enum omp_clause_code): Add OMP_CLAUSE__SCANTEMP_
clause.
* tree.h (OMP_CLAUSE_DECL): Use OMP_CLAUSE__SCANTEMP_ instead of
OMP_CLAUSE__CONDTEMP_ as range's upper bound.
(OMP_CLAUSE__SCANTEMP__ALLOC, OMP_CLAUSE__SCANTEMP__CONTROL): Define.
* tree.c (omp_clause_num_ops, omp_clause_code_name): Add
OMP_CLAUSE__SCANTEMP_ entry.
(walk_tree_1): Handle OMP_CLAUSE__SCANTEMP_.
* tree-pretty-print.c (dump_omp_clause): Likewise.
* tree-nested.c (convert_nonlocal_omp_clauses,
convert_local_omp_clauses): Likewise.
* omp-general.h (struct omp_for_data): Add have_scantemp and
have_nonctrl_scantemp members.
* omp-general.c (omp_extract_for_data): Initialize them.
* omp-low.c (struct omp_context): Add scan_exclusive member.
(scan_omp_1_stmt): Don't unnecessarily mask gimple_omp_for_kind
result again with GF_OMP_FOR_KIND_MASK. Initialize also
ctx->scan_exclusive.
(lower_rec_simd_input_clauses): Use ctx->scan_exclusive instead
of !ctx->scan_inclusive.
(lower_rec_input_clauses): Simplify gimplification of dtors using
gimplify_and_add. For non-is_simd test OMP_CLAUSE_REDUCTION_INSCAN
rather than rvarp. Handle OMP_CLAUSE_REDUCTION_INSCAN in worksharing
loops. Don't add barrier for reduction_omp_orig_ref if
ctx->scan_??xclusive.
(lower_reduction_clauses): Don't do anything for ctx->scan_??xclusive.
(lower_omp_scan): Use ctx->scan_exclusive instead
of !ctx->scan_inclusive. Handle worksharing loops with inscan
reductions. Use new_vard != new_var instead of repeated
omp_is_reference calls.
(omp_find_scan, lower_omp_for_scan): New functions.
(lower_omp_for): Call lower_omp_for_scan for worksharing loops with
inscan reductions.
* omp-expand.c (expand_omp_scantemp_alloc): New function.
(expand_omp_for_static_nochunk): Handle fd->have_nonctrl_scantemp
and fd->have_scantemp.
* c-c++-common/gomp/scan-3.c (f1): Don't expect a sorry message.
* c-c++-common/gomp/scan-5.c (foo): Likewise.
* testsuite/libgomp.c++/scan-1.C: New test.
* testsuite/libgomp.c++/scan-2.C: New test.
* testsuite/libgomp.c++/scan-3.C: New test.
* testsuite/libgomp.c++/scan-4.C: New test.
* testsuite/libgomp.c++/scan-5.C: New test.
* testsuite/libgomp.c++/scan-6.C: New test.
* testsuite/libgomp.c++/scan-7.C: New test.
* testsuite/libgomp.c++/scan-8.C: New test.
* testsuite/libgomp.c/scan-1.c: New test.
* testsuite/libgomp.c/scan-2.c: New test.
* testsuite/libgomp.c/scan-3.c: New test.
* testsuite/libgomp.c/scan-4.c: New test.
* testsuite/libgomp.c/scan-5.c: New test.
* testsuite/libgomp.c/scan-6.c: New test.
* testsuite/libgomp.c/scan-7.c: New test.
* testsuite/libgomp.c/scan-8.c: New test.
From-SVN: r272958
Jakub Jelinek [Wed, 3 Jul 2019 04:56:25 +0000 (06:56 +0200)]
gimplify.c (gimplify_scan_omp_clauses): For inscan reductions on worksharing loop propagate it as shared clause to...
* gimplify.c (gimplify_scan_omp_clauses): For inscan reductions
on worksharing loop propagate it as shared clause to containing
combined parallel.
* c-omp.c (c_omp_split_clauses): Put OMP_CLAUSE_REDUCTION_INSCAN
clauses on OMP_FOR rather than OMP_PARALLEL when OMP_FOR is combined
with OMP_PARALLEL.
* c-c++-common/gomp/scan-5.c: New test.
From-SVN: r272957
Jakub Jelinek [Wed, 3 Jul 2019 04:51:45 +0000 (06:51 +0200)]
omp-expand.c (expand_omp_for_static_nochunk, [...]): For nowait worksharing loop with conditional lastprivate clause(s)...
* omp-expand.c (expand_omp_for_static_nochunk,
expand_omp_for_static_chunk): For nowait worksharing loop with
conditional lastprivate clause(s), emit GOMP_loop_end_nowait call
at the end.
* c-c++-common/gomp/lastprivate-conditional-5.c: New test.
From-SVN: r272956
Ian Lance Taylor [Wed, 3 Jul 2019 00:56:35 +0000 (00:56 +0000)]
compiler: rework type and package tracking in exporter
Revamps the way the exporter tracks exported types and imported
packages that need to be mentioned in the export data.
The previous implementation wasn't properly handling the case where an
exported non-inlinable function refers to an imported type whose
method set includes an inlinable function whose body makes a call to a
function in another package that's not directly used in the original
package.
This patch integrates together two existing traversal helper classes,
"Collect_references_from_inline" and "Find_types_to_prepare" into a
single helper "Collect_export_references", so as to have common/shared
code that looks for indirectly imported packages.
Fixes golang/go#32778
Reviewed-on: https://go-review.googlesource.com/c/gofrontend/+/183850
From-SVN: r272955
Joern Rennecke [Wed, 3 Jul 2019 00:22:53 +0000 (00:22 +0000)]
re PR testsuite/91065 (gcc.dg/plugin/start_unit_plugin.c uses ggc memory without registering a root_tab)
PR testsuite/91065
* testsuite/gcc.dg/plugin/start_unit_plugin.c: Register a root tab
to reference fake_var.
From-SVN: r272954
GCC Administrator [Wed, 3 Jul 2019 00:16:15 +0000 (00:16 +0000)]
Daily bump.
From-SVN: r272953
Jeff Law [Tue, 2 Jul 2019 23:01:53 +0000 (17:01 -0600)]
re PR tree-optimization/90883 (Generated code is worse if returned struct is unnamed)
PR tree-optimization/90883
* g++.dg/tree-ssa/pr90883.c: Add -Os. Check dse2 for the
deleted store on some targets.
From-SVN: r272949
Qing Zhao [Tue, 2 Jul 2019 20:23:30 +0000 (20:23 +0000)]
re PR preprocessor/90581 (provide an option to adjust the maximum depth of nested #include)
PR preprocessor/90581
Add a cpp option -fmax-include-depth to set the maximum depth of the nested #include.
From-SVN: r272948
Iain Sandoe [Tue, 2 Jul 2019 19:03:48 +0000 (19:03 +0000)]
[PATCH, Ada, Darwin, PPC] PPC Darwin has stack check probes.
On PPC, Darwin uses the same code as other parts of the port.
2019-07-02 Iain Sandoe <iain@sandoe.co.uk>
* libgnat/system-darwin-ppc.ads: Set Stack_Check_Probes True for
PPC Darwin.
From-SVN: r272947
Aaron Sawdey [Tue, 2 Jul 2019 18:51:23 +0000 (13:51 -0500)]
optabs.def (movmem_optab): Add movmem back for memmove().
2019-07-02 Aaron Sawdey <acsawdey@linux.ibm.com>
* optabs.def (movmem_optab): Add movmem back for memmove().
* doc/md.texi: Add description of movmem pattern for overlapping move.
From-SVN: r272946
Cherry Zhang [Tue, 2 Jul 2019 16:47:48 +0000 (16:47 +0000)]
compiler: use builtin memset for non-pointer memclr
For zeroing a range of memory that doesn't contain pointer, we
can use builtin memset directly.
Reviewed-on: https://go-review.googlesource.com/c/gofrontend/+/184438
* go-gcc.cc (Gcc_backend::Gcc_backend): Define __builtin_memset.
From-SVN: r272944
Uros Bizjak [Tue, 2 Jul 2019 15:48:36 +0000 (17:48 +0200)]
mmx.md (mmx_pack<s_trunsuffix>swb): Use TARGET_SSE2 && SSE_REGNO_P in split condition.
* config/i386/mmx.md (mmx_pack<s_trunsuffix>swb):
Use TARGET_SSE2 && SSE_REGNO_P in split condition.
(mmx_packssdw): Ditto.
(mmx_punpckhbw): Ditto.
(mmx_punpcklbw): Ditto.
(mmx_punpckhwd): Ditto.
(mmx_punpcklwd): Ditto.
(mmx_punpckhdq): Ditto.
(mmx_punpckldq): Ditto.
(*vec_dupv4hi): Ditto.
(*vec_dupv2si): Ditto.
(mmx_pmovmskb): Ditto.
* config/i386/sse.md (sse_cvtpi2ps): Use
TARGET_SSE2 && SSE_REG_P in split condition.
(ssse3_ph<plusminus_mnemonic>wv4hi3): Use
TARGET_SSSE3 && SSE_REGNO_P in split condition.
(ssse3_ph<plusminus_mnemonic>dv2si3): Ditto.
(ssse3_pshufbv8qi3): Ditto.
(ssse3_palignrdi): Ditto.
From-SVN: r272943
Andrew Stubbs [Tue, 2 Jul 2019 11:57:17 +0000 (11:57 +0000)]
Fix amdgcn regrename ICE.
2019-07-02 Andrew Stubbs <ams@codesourcery.com>
gcc/
* config/gcn/gcn.md (movdi_symbol_save_scc): Convert to define_insn
with inlined save and restore.
From-SVN: r272932
Jonathan Wakely [Tue, 2 Jul 2019 11:50:27 +0000 (12:50 +0100)]
Fix preprocessor checks for Clang builtins
Clang seems to define built-ins that start with "__builtin_" as
non-keywords, which means that we need to use __has_builtin to detect
them, not __is_identifier. The built-ins that don't start with
"__builtin_" are keywords, and can only be detected using
__is_identifier and not by __has_builtin.
* include/bits/c++config (_GLIBCXX_HAVE_BUILTIN_LAUNDER)
(_GLIBCXX_HAVE_BUILTIN_IS_CONSTANT_EVALUATED): Use __has_builtin
instead of __is_identifier to detect Clang support.
From-SVN: r272931
Eric Botcazou [Tue, 2 Jul 2019 11:10:59 +0000 (11:10 +0000)]
* cfgrtl.c (commit_edge_insertions): Rebuild jump labels chain.
From-SVN: r272930
Eric Botcazou [Tue, 2 Jul 2019 09:44:47 +0000 (09:44 +0000)]
cfgexpand.c (pass_expand::execute): Deal specially with instructions to be inserted on single successor edge of the...
* cfgexpand.c (pass_expand::execute): Deal specially with instructions
to be inserted on single successor edge of the entry block. Then call
commit_edge_insertions instead of inserting the instructions manually.
* cfgrtl.c (commit_edge_insertions): Do not verify flow info during
RTL expansion.
From-SVN: r272929
Richard Biener [Tue, 2 Jul 2019 09:35:12 +0000 (09:35 +0000)]
tree-core.h (enum tree_index): Add TI_CHREC_DONT_KNOW and TI_CHREC_KNOWN.
2019-07-02 Richard Biener <rguenther@suse.de>
* tree-core.h (enum tree_index): Add TI_CHREC_DONT_KNOW and
TI_CHREC_KNOWN.
* tree.h (chrec_not_analyzed_yet, chrec_dont_know, chrec_known):
Define here.
* tree.c (build_common_tree_nodes): Initialize them.
* tree-chrec.h (chrec_not_analyzed_yet, chrec_dont_know, chrec_known):
Make declarations comments.
* tree-scalar-evolution.c (chrec_not_analyzed_yet, chrec_dont_know,
chrec_known): Remove definitions.
(initialize_scalar_evolutions_analyzer): Remove.
(scev_initialize): Do not call initialize_scalar_evolutions_analyzer.
* tree-streamer.c (preload_common_nodes): Do not preload
TI_CHREC_DONT_KNOW or TI_CHREC_KNOWN.
From-SVN: r272928
Jan Hubicka [Tue, 2 Jul 2019 08:35:58 +0000 (10:35 +0200)]
tree-ssa-alias.c (aliasing_component_refs_p): Remove forgotten sanity check.
* tree-ssa-alias.c (aliasing_component_refs_p): Remove forgotten
sanity check.
From-SVN: r272927
Jan Hubicka [Tue, 2 Jul 2019 08:28:24 +0000 (10:28 +0200)]
tree-ssa-alias.c (nonoverlapping_component_refs_for_decl_p): Rename to ..
* tree-ssa-alias.c (nonoverlapping_component_refs_for_decl_p): Rename
to ..
(nonoverlapping_component_refs_since_match_p): ... this one;
handle also non-decl bases; return -1 if search gave up.
(alias_stats): Rename nonoverlapping_component_refs_of_decl_p_may_alias,
nonoverlapping_component_refs_of_decl_p_no_alias to
nonoverlapping_component_refs_since_match_p_may_alias,
nonoverlapping_component_refs_since_match_p_no_alias.
(dump_alias_stats): Update dumping.
(aliasing_matching_component_refs_p): Break out from ...;
dispatch to nonoverlapping_component_refs_for_decl_p
and nonoverlapping_component_refs_since_match_p.
(aliasing_component_refs_p): ... here; call
nonoverlapping_component_refs_p in scenarios where we can not
precisely determine base match.
(decl_refs_may_alias_p): Use
nonoverlapping_component_refs_since_match_p.
(indirect_ref_may_alias_decl_p): Do not call
nonoverlapping_component_refs_p.
(indirect_refs_may_alias_p): Likewise.
* gcc.dg/tree-ssa/alias-access-path-7.c: New testcase.
From-SVN: r272926
Jan Hubicka [Tue, 2 Jul 2019 08:26:16 +0000 (10:26 +0200)]
tree-inline.c (remap_gimple_stmt): Do not subtitute handled components to clobber of return value.
* tree-inline.c (remap_gimple_stmt): Do not subtitute handled components
to clobber of return value.
* g++.dg/lto/pr90990_0.C: New testcase.
From-SVN: r272925
Kyrylo Tkachov [Tue, 2 Jul 2019 08:24:54 +0000 (08:24 +0000)]
[arm/AArch64] Assume unhandled NEON types are neon_arith_basic types when scheduling for Cortex-A57
Some scheduling descriptions, like the Cortex-A57 one, are reused for multiple -mcpu options.
Sometimes those other -mcpu cores support more architecture features than the Armv8-A Cortex-A57.
For example, the Cortex-A75 and Cortex-A76 support Armv8.2-A as well as the Dot Product instructions.
These Dot Product instructions have the neon_dot and neon_dot_q scheduling type, but that type is not
handled in cortex-a57.md, since the Cortex-A57 itself doesn't need to care about these instructions.
But if we just ignore the neon_dot(_q) type at scheduling we get really terrible codegen when compiling
for -mcpu=cortex-a76, for example, because the scheduler just pools all the UDOT instructions at the end
of the basic block, since it doesn't assume anything about their behaviour.
This patch ameliorates the situation somewhat by telling the Cortex-A57 scheduling model to treat any
insn that doesn't get assigned a cortex_a57_neon_type but is actually a is_neon_type instruction as
a simple neon_arith_basic instruction. This allows us to treat post-Armv8-A SIMD instructions more sanely
without having to model each of them explicitly in cortex-a57.md.
* config/arm/cortex-a57.md (cortex_a57_neon_type): Use neon_arith_basic
for is_neon_type instructions that have not already been categorized.
From-SVN: r272924
Jan Hubicka [Tue, 2 Jul 2019 08:23:02 +0000 (10:23 +0200)]
lto-common.c (lto_register_canonical_types_for_odr_types): Copy CXX_ODR_P from the main variant.
* lto-common.c (lto_register_canonical_types_for_odr_types):
Copy CXX_ODR_P from the main variant.
From-SVN: r272923
Richard Biener [Tue, 2 Jul 2019 07:35:23 +0000 (07:35 +0000)]
re PR tree-optimization/58483 (missing optimization opportunity for const std::vector compared to std::array)
2019-07-02 Richard Biener <rguenther@suse.de>
PR tree-optimization/58483
* tree-ssa-scopedtables.c (avail_expr_hash): Use OEP_ADDRESS_OF
for MEM_REF base hashing.
(equal_mem_array_ref_p): Likewise for base comparison.
* gcc.dg/tree-ssa/ssa-dom-cse-8.c: New testcase.
From-SVN: r272922
Janne Blomqvist [Tue, 2 Jul 2019 05:54:31 +0000 (08:54 +0300)]
mklog/91048: Open ~/.mklog in string mode.
2019-07-02 Janne Blomqvist <jb@gcc.gnu.org>
PR other/91048
* mklog (read_user_info): Open ~/.mklog in string mode.
From-SVN: r272921
Jim Wilson [Tue, 2 Jul 2019 02:30:52 +0000 (02:30 +0000)]
Fix libstdc++ install-pdf support.
Generating pdf files requires everything that is required for the xml files
except the style sheets.
libstdc++-v3/
* configure.ac (BUILD_PDF): Also test for doxygen, dot, xsltproc,
and xmllint.
* configure: Regenerate.
From-SVN: r272920
Ian Lance Taylor [Tue, 2 Jul 2019 01:39:19 +0000 (01:39 +0000)]
compiler: refactoring in Export class to encapsulate type refs map
Convert the Export::type_refs map from a static object to a field
contained (indirectly, via an impl class) in Export itself, for better
encapsulation and to be able to reclaim its memory when exporting is
done. No change in compiler functionality.
Reviewed-on: https://go-review.googlesource.com/c/gofrontend/+/184170
From-SVN: r272919
GCC Administrator [Tue, 2 Jul 2019 00:16:22 +0000 (00:16 +0000)]
Daily bump.
From-SVN: r272916
Segher Boessenkool [Mon, 1 Jul 2019 21:58:47 +0000 (23:58 +0200)]
rs6000.md (signbit<mode>2_dm): Make this a parameterized name.
@signbit<mode>2_dm
* config/rs6000/rs6000.md (signbit<mode>2_dm): Make this a
parameterized name.
(signbit<mode>2): Use that name. Simplify.
From-SVN: r272912
Joern Rennecke [Mon, 1 Jul 2019 21:48:55 +0000 (21:48 +0000)]
re PR tree-optimization/66726 (missed optimization, factor conversion out of COND_EXPR)
PR middle-end/66726
* tree-ssa-phiopt.c (factor_out_conditional_conversion):
Tune heuristic from PR71016 to allow MIN / MAX.
* testsuite/gcc.dg/tree-ssa/pr66726-4.c: New testcase.
From-SVN: r272911
Uros Bizjak [Mon, 1 Jul 2019 19:04:05 +0000 (21:04 +0200)]
* config/i386/constraints.md: Remove stalled comment w.r.t. Yh constraint.
From-SVN: r272908
Segher Boessenkool [Mon, 1 Jul 2019 18:47:56 +0000 (20:47 +0200)]
rs6000.md (ieee_128bit_vsx_abs<mode>2): Make this a parameterized name.
@ieee_128bit_vsx_abs<mode>2
* config/rs6000/rs6000.md (ieee_128bit_vsx_abs<mode>2): Make this a
parameterized name.
(abs<mode>2): Use that name. Simplify.
From-SVN: r272907
Segher Boessenkool [Mon, 1 Jul 2019 18:47:05 +0000 (20:47 +0200)]
rs6000.md (ieee_128bit_vsx_neg<mode>2): Make this a parameterized name.
@ieee_128bit_vsx_neg<mode>2
* config/rs6000/rs6000.md (ieee_128bit_vsx_neg<mode>2): Make this a
parameterized name.
(neg<mode>2): Use that name. Simplify.
From-SVN: r272906
Segher Boessenkool [Mon, 1 Jul 2019 18:45:36 +0000 (20:45 +0200)]
rs6000.md (abs<mode>2_hw): Make this a parameterized name.
@abs<mode>2_hw
* config/rs6000/rs6000.md (abs<mode>2_hw): Make this a parameterized
name.
(abs<mode>2): Use that name. Simplify.
From-SVN: r272905
Segher Boessenkool [Mon, 1 Jul 2019 18:44:18 +0000 (20:44 +0200)]
rs6000.md (neg<mode>2_hw): Make this a parameterized name.
@neg<mode>2_hw
* config/rs6000/rs6000.md (neg<mode>2_hw): Make this a parameterized
name.
(neg<mode>2): Use that name. Simplify.
From-SVN: r272904
Segher Boessenkool [Mon, 1 Jul 2019 18:43:10 +0000 (20:43 +0200)]
rs6000.md (extenddf<mode>2): Make this a parameterized name.
@extenddf<mode>2
* config/rs6000/rs6000.md (extenddf<mode>2): Make this a parameterized
name.
(floatsi<mode>2): Use that name. Simplify.
From-SVN: r272903
Uros Bizjak [Mon, 1 Jul 2019 18:41:09 +0000 (20:41 +0200)]
i386.md ("isa" attribute): Add sse_noavx.
* config/i386/i386.md ("isa" attribute): Add sse_noavx.
("enabled" attribute): Handle sse_noavx isa attribute.
* config/i386/mmx.md (*vec_dupv2sf): Add "isa" attribute.
Use TARGET_SSE && SSE_REGNO_P in split condition.
(*vec_dupv2sf): Ditto.
From-SVN: r272902
Segher Boessenkool [Mon, 1 Jul 2019 18:40:40 +0000 (20:40 +0200)]
rs6000.md (extenddf<mode>2_fprs): Make this a parameterized name.
@extenddf<mode>2_{fprs,vsx}
* config/rs6000/rs6000.md (extenddf<mode>2_fprs): Make this a
parameterized name.
(extenddf<mode>2_vsx): Make this a parameterized name.
(extenddf<mode>2): Use those names. Simplify.
From-SVN: r272901
Segher Boessenkool [Mon, 1 Jul 2019 18:39:52 +0000 (20:39 +0200)]
rs6000.md (eh_set_lr_<mode>): Make this a parameterized name.
@eh_set_lr_<mode>
* config/rs6000/rs6000.md (eh_set_lr_<mode>): Make this a parameterized
name.
(eh_return): Use that name. Simplify.
From-SVN: r272900
Segher Boessenkool [Mon, 1 Jul 2019 18:39:13 +0000 (20:39 +0200)]
rs6000.md (ctr<mode>): Make this a parameterized name.
@ctr<mode>
* config/rs6000/rs6000.md (ctr<mode>): Make this a parameterized name.
(doloop_end): Use that name. Simplify.
From-SVN: r272899
Segher Boessenkool [Mon, 1 Jul 2019 18:38:21 +0000 (20:38 +0200)]
rs6000.md (indirect_jump<mode>_nospec): Make this a parameterized name.
@indirect_jump<mode>_nospec
* config/rs6000/rs6000.md (indirect_jump<mode>_nospec): Make this a
parameterized name.
(indirect_jump): Use that name. Simplify.
From-SVN: r272898
Segher Boessenkool [Mon, 1 Jul 2019 18:37:25 +0000 (20:37 +0200)]
rs6000.md (abs<mode>2_internal): Make this a parameterized name.
@abs<mode>2_internal
* config/rs6000/rs6000.md (abs<mode>2_internal): Make this a
parameterized name.
(abs<mode>2): Use that name. Simplify.
From-SVN: r272897
Segher Boessenkool [Mon, 1 Jul 2019 18:36:34 +0000 (20:36 +0200)]
rs6000.md (fix_trunc<mode>si2_fprs): Make this a parameterized name.
@fix_trunc<mode>si2_fprs
* config/rs6000/rs6000.md (fix_trunc<mode>si2_fprs): Make this a
parameterized name.
(fix_trunc<mode>si2): Use that name. Simplify.
From-SVN: r272896
Segher Boessenkool [Mon, 1 Jul 2019 18:35:23 +0000 (20:35 +0200)]
rs6000.md (neg<mode>2): Make this a parameterized name.
@neg<mode>2
* config/rs6000/rs6000.md (neg<mode>2): Make this a parameterized name.
(allocate_stack): Use that name. Simplify.
From-SVN: r272894
Martin Sebor [Mon, 1 Jul 2019 18:33:36 +0000 (18:33 +0000)]
PR middle-end/90923 - hash_map destroys elements without constructing them
gcc/ChangeLog:
PR middle-end/90923
* hash-map.h (hash_map::put): On insertion invoke element ctor.
(hash_map::get_or_insert): Same. Reformat comment.
* hash-set.h (hash_set::add): On insertion invoke element ctor.
* hash-map-tests.c (test_map_of_type_with_ctor_and_dtor): New.
* hash-set-tests.c (test_map_of_type_with_ctor_and_dtor): New.
* hash-table.h (hash_table::operator=): Prevent copy assignment.
(hash_table::hash_table (const hash_table&)): Use copy ctor
instead of assignment to copy elements.
From-SVN: r272893
Wilco Dijkstra [Mon, 1 Jul 2019 16:55:42 +0000 (16:55 +0000)]
re PR target/90963 (FAIL: gcc.c-torture/execute/built-in-setjmp.c execution test)
PR target/90963
* config/pa/pa.md (builtin_longjmp): Restore hard_frame_pointer_rtx
using saved frame pointer.
Co-Authored-By: John David Anglin <danglin@gcc.gnu.org>
From-SVN: r272891
Eric Botcazou [Mon, 1 Jul 2019 16:26:38 +0000 (16:26 +0000)]
re PR middle-end/64242 (Longjmp expansion incorrect)
PR middle-end/64242
* config/sparc/sparc.md (nonlocal_goto): Restore frame pointer last.
Add frame clobber and schedule blockage.
From-SVN: r272889
Sandra Loosemore [Mon, 1 Jul 2019 15:42:49 +0000 (11:42 -0400)]
invoke.texi (Link Options): Further editorial changes to -flinker-output docs.
2019-07-01 Sandra Loosemore <sandra@codesourcery.com>
gcc/
* doc/invoke.texi (Link Options): Further editorial changes to
-flinker-output docs.
From-SVN: r272887
Segher Boessenkool [Mon, 1 Jul 2019 15:15:41 +0000 (17:15 +0200)]
rs6000: Improve indexed addressing
The function rs6000_force_indexed_or_indirect_mem makes a memory
operand suitable for indexed (or indirect) addressing. If the memory
address isn't yet valid, it loads the whole thing into a register to
make it valid. That isn't optimal. This changes it to load an
address that is the sum of two things into two registers instead.
This results in lower latency code, and if inside loops, a constant
term can be moved outside the loop.
* config/rs6000/rs6000.c (rs6000_force_indexed_or_indirect_mem):
Load both operands of a PLUS into registers separately.
From-SVN: r272886
Andreas Krebbel [Mon, 1 Jul 2019 14:59:43 +0000 (14:59 +0000)]
Fix changelog entry.
From-SVN: r272885
Andreas Krebbel [Mon, 1 Jul 2019 14:56:41 +0000 (14:56 +0000)]
S/390: Fix vector shift count operand
We currently use subst definitions to handle the different variants of shift
count operands. Unfortunately, in the vector shift pattern the shift count
operand is used directly. Without it being adjusted for the 'subst' variants the
displacement value is omitted resulting in a wrong shift count being applied.
This patch needs to be applied to older branches as well.
gcc/ChangeLog:
2019-07-01 Andreas Krebbel <krebbel@linux.ibm.com>
* config/s390/vector.md:
gcc/testsuite/ChangeLog:
2019-07-01 Andreas Krebbel <krebbel@linux.ibm.com>
* gcc.target/s390/vector/vec-shift-2.c: New test.
From-SVN: r272884
Ed Schonberg [Mon, 1 Jul 2019 13:37:47 +0000 (13:37 +0000)]
[Ada] Spurious error on inst. of partially defaulted formal package
This patch removes a spurious error on an instantiation whose generic
unit has a formal package where some formal parameters are
box-initialiaed. Previously the code assumed that box-initialization
for a formal package applied to all its formal parameters.
2019-07-01 Ed Schonberg <schonberg@adacore.com>
gcc/ada/
* sem_ch12.adb (Is_Defaulted): New predicate in
Check_Formal_Package_Intance, to skip the conformance of checks
on parameters of a formal package that are defaulted,
gcc/testsuite/
* gnat.dg/generic_inst3.adb,
gnat.dg/generic_inst3_kafka_lib-topic.ads,
gnat.dg/generic_inst3_kafka_lib.ads,
gnat.dg/generic_inst3_markets.ads,
gnat.dg/generic_inst3_traits-encodables.ads,
gnat.dg/generic_inst3_traits.ads: New testcase.
From-SVN: r272883
Hristian Kirtchev [Mon, 1 Jul 2019 13:37:42 +0000 (13:37 +0000)]
[Ada] Minor reformatting
2019-07-01 Hristian Kirtchev <kirtchev@adacore.com>
gcc/ada/
* checks.adb, exp_ch9.adb, exp_unst.adb, sem_ch4.adb,
sem_prag.adb, sem_spark.adb: Minor reformatting.
From-SVN: r272882
Ed Schonberg [Mon, 1 Jul 2019 13:37:37 +0000 (13:37 +0000)]
[Ada] More permissive use of GNAT attribute Enum_Rep
This patch allows the prefix of the attribute Enum_Rep to be an
attribute referece (such as Enum_Type'First). A recent patch had
restricted the prefix to be an object of a discrete type, which is
incompatible with orevious usage.
2019-07-01 Ed Schonberg <schonberg@adacore.com>
gcc/ada/
* sem_attr.adb (Analyze_Attribute, case Enum_Rep): Allow prefix
of attribute to be an attribute reference of a discrete type.
gcc/testsuite/
* gnat.dg/enum_rep.adb, gnat.dg/enum_rep.ads: New testcase.
From-SVN: r272881
Eric Botcazou [Mon, 1 Jul 2019 13:37:31 +0000 (13:37 +0000)]
[Ada] Make No_Inline pragma effective for generic subprograms
2019-07-01 Eric Botcazou <ebotcazou@adacore.com>
gcc/ada/
* sem_ch12.adb (Analyze_Subprogram_Instantiation): Move up
handling of Has_Pragma_Inline_Always and deal with
Has_Pragma_No_Inline.
From-SVN: r272880
Ed Schonberg [Mon, 1 Jul 2019 13:37:26 +0000 (13:37 +0000)]
[Ada] Spurious error private subtype derivation
This patch fixes a spurious error on a derived type declaration whose
subtype indication is a subtype of a private type whose full view is a
constrained discriminated type.
2019-07-01 Ed Schonberg <schonberg@adacore.com>
gcc/ada/
* sem_ch3.adb (Build_Derived_Record_Type): If the parent type is
declared as a subtype of a private type with an inherited
discriminant constraint, its generated full base appears as a
record subtype, so we need to retrieve its oen base type so that
the inherited constraint can be applied to it.
gcc/testsuite/
* gnat.dg/derived_type6.adb, gnat.dg/derived_type6.ads: New
testcase.
From-SVN: r272879
Yannick Moy [Mon, 1 Jul 2019 13:37:21 +0000 (13:37 +0000)]
[Ada] SPARK support for pointers through ownership
SPARK RM 3.10 is the final version of the pointer ownership rules. Start
changing the implementation accordingly. Anonymous access types are not
fully supported yet.
There is no impact on compilation.
2019-07-01 Yannick Moy <moy@adacore.com>
gcc/ada/
* sem_spark.adb: Completely rework the algorithm for ownership
checking, as the rules in SPARK RM have changed a lot.
* sem_spark.ads: Update comments.
From-SVN: r272878
Dmitriy Anisimkov [Mon, 1 Jul 2019 13:37:16 +0000 (13:37 +0000)]
[Ada] GNAT.Sockets: refactor Has_Sockaddr_Len
Use a field offset computation trick to avoid maintaining a list of
platforms.
2019-07-01 Dmitriy Anisimkov <anisimko@adacore.com>
gcc/ada/
* gsocket.h (Has_Sockaddr_Len): Use the offset of sin_family offset in
the sockaddr_in structure to determine the existence of length field
before the sin_family.
From-SVN: r272877
Ed Schonberg [Mon, 1 Jul 2019 13:37:11 +0000 (13:37 +0000)]
[Ada] Crash on improper pragma Weak_External
This patch adds a guard on the use of pragma Weak_External. This pragma
affects link-time addresses of entities, and does not apply to types.
Previous to this patch the compiler would abort on a misuse of the
pragma.
2019-07-01 Ed Schonberg <schonberg@adacore.com>
gcc/ada/
* sem_prag.adb (Analyze_Pragma, case Weak_External): Pragma only
applies to entities with run-time addresses, not to types.
gcc/testsuite/
* gnat.dg/weak3.adb, gnat.dg/weak3.ads: New testcase.
From-SVN: r272876
Piotr Trojanek [Mon, 1 Jul 2019 13:37:06 +0000 (13:37 +0000)]
[Ada] Remove a SPARK rule about implicit Global
A rule about implicit Global contract for functions whose names overload
an abstract state was never implemented (and no user complained about
this). It is now removed, so references to other rules need to be
renumbered.
2019-07-01 Piotr Trojanek <trojanek@adacore.com>
gcc/ada/
* einfo.adb, sem_ch7.adb, sem_prag.adb, sem_util.adb: Update
references to the SPARK RM after the removal of Rule 7.1.4(5).
From-SVN: r272875
Piotr Trojanek [Mon, 1 Jul 2019 13:37:01 +0000 (13:37 +0000)]
[Ada] Cleanup references to LynuxWorks in docs and comments
Apparently the company behind LynxOS is now called Lynx Software
Technologies (formerly LynuxWorks).
Use the current name in user docs and the previous name in developer
comment (to hopefully reflect the company name at the time when the
patchset mentioned in the comment was released).
2019-07-01 Piotr Trojanek <trojanek@adacore.com>
gcc/ada/
* sysdep.c: Cleanup references to LynuxWorks in docs and
comments.
From-SVN: r272874
Ed Schonberg [Mon, 1 Jul 2019 13:36:56 +0000 (13:36 +0000)]
[Ada] Wrong code with -gnatVa on lock-free protected objects
This patch fixes the handling of validity checks on protected objects
that use the Lock-Free implementation when validity checks are enabled,
previous to this patch the compiler would report improperly that a
condition in a protected operation was always True (when comoipled with
-gnatwa) and would generate incorrect code fhat operation.
2019-07-01 Ed Schonberg <schonberg@adacore.com>
gcc/ada/
* checks.adb (Insert_Valid_Check): Do not apply validity check
to variable declared within a protected object that uses the
Lock_Free implementation, to prevent unwarranted constant
folding, because entities within such an object msut be treated
as volatile.
gcc/testsuite/
* gnat.dg/prot7.adb, gnat.dg/prot7.ads: New testcase.
From-SVN: r272873
Richard Biener [Mon, 1 Jul 2019 13:36:05 +0000 (13:36 +0000)]
gimple-parser.c (c_parser_gimple_postfix_expression): Handle _Literal (char *) &"foo" for address literals pointing to STRING_CSTs.
2019-07-01 Richard Biener <rguenther@suse.de>
c/
* gimple-parser.c (c_parser_gimple_postfix_expression): Handle
_Literal (char *) &"foo" for address literals pointing to
STRING_CSTs.
* gcc.dg/gimplefe-42.c: New testcase.
From-SVN: r272872
Eric Botcazou [Mon, 1 Jul 2019 13:36:04 +0000 (13:36 +0000)]
[Ada] Make No_Inline pragma effective for protected subprograms
2019-07-01 Eric Botcazou <ebotcazou@adacore.com>
gcc/ada/
* exp_ch9.adb (Check_Inlining): Deal with Has_Pragma_No_Inline.
From-SVN: r272871
Ed Schonberg [Mon, 1 Jul 2019 13:35:58 +0000 (13:35 +0000)]
[Ada] Unnesting: improve handling of private and incomplete types
2019-07-01 Ed Schonberg <schonberg@adacore.com>
gcc/ada/
* exp_unst.adb (Visit_Node, Check_Static_Type): Improve the
handling of private and incomplete types whose full view is an
access type, to detect additional uplevel references in dynamic
bounds. This is relevant to N_Free_Statement among others that
manipulate types whose full viww may be an access type.
From-SVN: r272870
Pat Rogers [Mon, 1 Jul 2019 13:35:53 +0000 (13:35 +0000)]
[Ada] Correct size in representation clauses documentation
2019-07-01 Pat Rogers <rogers@adacore.com>
gcc/ada/
* doc/gnat_rm/representation_clauses_and_pragmas.rst: Correct
size indicated for R as a component of an array.
* gnat_rm.texi: Regenerate.
From-SVN: r272869
Justin Squirek [Mon, 1 Jul 2019 13:35:48 +0000 (13:35 +0000)]
[Ada] Incorrect definition of Win32 compatible types
This patch corrects the definition of certain Win32 types.
2019-07-01 Justin Squirek <squirek@adacore.com>
gcc/ada/
* libgnat/s-win32.ads: Add definition for ULONG, modify
OVERLAPPED type, and add appropriate pragmas.
From-SVN: r272868
Bob Duff [Mon, 1 Jul 2019 13:35:43 +0000 (13:35 +0000)]
[Ada] gprbuild fails to find ghost ALI files
This patch fixes a bug where if a ghost unit is compiled with
ignored-ghost mode in a library project, then gprbuild will fail to find
the ALI file, because the compiler generates an empty object file, but
no ALI file.
2019-07-01 Bob Duff <duff@adacore.com>
gcc/ada/
* gnat1drv.adb (gnat1drv): Call Write_ALI if the main unit is
ignored-ghost.
From-SVN: r272867
Yannick Moy [Mon, 1 Jul 2019 13:35:38 +0000 (13:35 +0000)]
[Ada] Improve error message on mult/div between fixed-point and integer
Multiplication and division of a fixed-point type by an integer type is
only defined by default for type Integer. Clarify the error message to
explain that a conversion is needed in other cases.
Also change an error message to start with lowercase as it should be.
2019-07-01 Yannick Moy <moy@adacore.com>
gcc/ada/
* sem_ch4.adb (Operator_Check): Refine error message.
From-SVN: r272866
Piotr Trojanek [Mon, 1 Jul 2019 13:35:32 +0000 (13:35 +0000)]
[Ada] Revert "Global => null" on calendar routines that use timezones
Some routines from the Ada.Calendar package, i.e. Year, Month, Day,
Split and Time_Off, rely on OS-specific timezone databases that are kept
in files (e.g. /etc/localtime on Linux). In SPARK we want to model this
as a potential side-effect, so those routines can't have "Global =>
null".
2019-07-01 Piotr Trojanek <trojanek@adacore.com>
gcc/ada/
* libgnat/a-calend.ads: Revert "Global => null" contracts on
non-pure routines.
From-SVN: r272865
Piotr Trojanek [Mon, 1 Jul 2019 13:35:25 +0000 (13:35 +0000)]
[Ada] Fix "componant" typos in comments
2019-07-01 Piotr Trojanek <trojanek@adacore.com>
gcc/ada/
* exp_attr.adb, libgnat/g-graphs.ads: Fix typos in comments:
componant -> component.
From-SVN: r272864
Hristian Kirtchev [Mon, 1 Jul 2019 13:35:15 +0000 (13:35 +0000)]
[Ada] Clean up of GNAT.Graphs
------------
-- Source --
------------
-- operations.adb
with Ada.Text_IO; use Ada.Text_IO;
with GNAT; use GNAT;
with GNAT.Graphs; use GNAT.Graphs;
with GNAT.Sets; use GNAT.Sets;
procedure Operations is
type Vertex_Id is
(No_V, VA, VB, VC, VD, VE, VF, VG, VH, VX, VY, VZ);
No_Vertex_Id : constant Vertex_Id := No_V;
function Hash_Vertex (V : Vertex_Id) return Bucket_Range_Type;
type Edge_Id is
(No_E, E1, E2, E3, E4, E5, E6, E7, E8, E9, E10, E97, E98, E99);
No_Edge_Id : constant Edge_Id := No_E;
function Hash_Edge (E : Edge_Id) return Bucket_Range_Type;
package ES is new Membership_Sets
(Element_Type => Edge_Id,
"=" => "=",
Hash => Hash_Edge);
package DG is new Directed_Graphs
(Vertex_Id => Vertex_Id,
No_Vertex => No_Vertex_Id,
Hash_Vertex => Hash_Vertex,
Same_Vertex => "=",
Edge_Id => Edge_Id,
No_Edge => No_Edge_Id,
Hash_Edge => Hash_Edge,
Same_Edge => "=");
use DG;
package VS is new Membership_Sets
(Element_Type => Vertex_Id,
"=" => "=",
Hash => Hash_Vertex);
-----------------------
-- Local subprograms --
-----------------------
procedure Check_Belongs_To_Component
(R : String;
G : Directed_Graph;
V : Vertex_Id;
Exp_Comp : Component_Id);
-- Verify that vertex V of graph G belongs to component Exp_Comp. R is the
-- calling routine.
procedure Check_Belongs_To_Some_Component
(R : String;
G : Directed_Graph;
V : Vertex_Id);
-- Verify that vertex V of graph G belongs to some component. R is the
-- calling routine.
procedure Check_Destination_Vertex
(R : String;
G : Directed_Graph;
E : Edge_Id;
Exp_V : Vertex_Id);
-- Vertify that the destination vertex of edge E of grah G is Exp_V. R is
-- the calling routine.
procedure Check_Distinct_Components
(R : String;
Comp_1 : Component_Id;
Comp_2 : Component_Id);
-- Verify that components Comp_1 and Comp_2 are distinct (not the same)
procedure Check_Has_Component
(R : String;
G : Directed_Graph;
G_Name : String;
Comp : Component_Id);
-- Verify that graph G with name G_Name contains component Comp. R is the
-- calling routine.
procedure Check_Has_Edge
(R : String;
G : Directed_Graph;
E : Edge_Id);
-- Verify that graph G contains edge E. R is the calling routine.
procedure Check_Has_Vertex
(R : String;
G : Directed_Graph;
V : Vertex_Id);
-- Verify that graph G contains vertex V. R is the calling routine.
procedure Check_No_Component
(R : String;
G : Directed_Graph;
V : Vertex_Id);
-- Verify that vertex V does not belong to some component. R is the calling
-- routine.
procedure Check_No_Component
(R : String;
G : Directed_Graph;
G_Name : String;
Comp : Component_Id);
-- Verify that graph G with name G_Name does not contain component Comp. R
-- is the calling routine.
procedure Check_No_Edge
(R : String;
G : Directed_Graph;
E : Edge_Id);
-- Verify that graph G does not contain edge E. R is the calling routine.
procedure Check_No_Vertex
(R : String;
G : Directed_Graph;
V : Vertex_Id);
-- Verify that graph G does not contain vertex V. R is the calling routine.
procedure Check_Number_Of_Components
(R : String;
G : Directed_Graph;
Exp_Num : Natural);
-- Verify that graph G has exactly Exp_Num components. R is the calling
-- routine.
procedure Check_Number_Of_Edges
(R : String;
G : Directed_Graph;
Exp_Num : Natural);
-- Verify that graph G has exactly Exp_Num edges. R is the calling routine.
procedure Check_Number_Of_Vertices
(R : String;
G : Directed_Graph;
Exp_Num : Natural);
-- Verify that graph G has exactly Exp_Num vertices. R is the calling
-- routine.
procedure Check_Outgoing_Edge_Iterator
(R : String;
G : Directed_Graph;
V : Vertex_Id;
Set : ES.Membership_Set);
-- Verify that all outgoing edges of vertex V of graph G can be iterated
-- and appear in set Set. R is the calling routine.
procedure Check_Source_Vertex
(R : String;
G : Directed_Graph;
E : Edge_Id;
Exp_V : Vertex_Id);
-- Vertify that the source vertex of edge E of grah G is Exp_V. R is the
-- calling routine.
procedure Check_Vertex_Iterator
(R : String;
G : Directed_Graph;
Comp : Component_Id;
Set : VS.Membership_Set);
-- Verify that all vertices of component Comp of graph G can be iterated
-- and appear in set Set. R is the calling routine.
function Create_And_Populate return Directed_Graph;
-- Create a brand new graph (see body for the shape of the graph)
procedure Error (R : String; Msg : String);
-- Output an error message with text Msg within the context of routine R
procedure Test_Add_Edge;
-- Verify the semantics of routine Add_Edge
procedure Test_Add_Vertex;
-- Verify the semantics of routine Add_Vertex
procedure Test_All_Edge_Iterator;
-- Verify the semantics of All_Edge_Iterator
procedure Test_All_Vertex_Iterator;
-- Verify the semantics of All_Vertex_Iterator
procedure Test_Component;
-- Verify the semantics of routine Component
procedure Test_Component_Iterator;
-- Verify the semantics of Component_Iterator
procedure Test_Contains_Component;
-- Verify the semantics of routine Contains_Component
procedure Test_Contains_Edge;
-- Verify the semantics of routine Contains_Edge
procedure Test_Contains_Vertex;
-- Verify the semantics of routine Contains_Vertex
procedure Test_Delete_Edge;
-- Verify the semantics of routine Delete_Edge
procedure Test_Destination_Vertex;
-- Verify the semantics of routine Destination_Vertex
procedure Test_Find_Components;
-- Verify the semantics of routine Find_Components
procedure Test_Is_Empty;
-- Verify the semantics of routine Is_Empty
procedure Test_Number_Of_Components;
-- Verify the semantics of routine Number_Of_Components
procedure Test_Number_Of_Edges;
-- Verify the semantics of routine Number_Of_Edges
procedure Test_Number_Of_Vertices;
-- Verify the semantics of routine Number_Of_Vertices
procedure Test_Outgoing_Edge_Iterator;
-- Verify the semantics of Outgoing_Edge_Iterator
procedure Test_Present;
-- Verify the semantics of routine Present
procedure Test_Source_Vertex;
-- Verify the semantics of routine Source_Vertex
procedure Test_Vertex_Iterator;
-- Verify the semantics of Vertex_Iterator;
procedure Unexpected_Exception (R : String);
-- Output an error message concerning an unexpected exception within
-- routine R.
--------------------------------
-- Check_Belongs_To_Component --
--------------------------------
procedure Check_Belongs_To_Component
(R : String;
G : Directed_Graph;
V : Vertex_Id;
Exp_Comp : Component_Id)
is
Act_Comp : constant Component_Id := Component (G, V);
begin
if Act_Comp /= Exp_Comp then
Error (R, "inconsistent component for vertex " & V'Img);
Error (R, " expected: " & Exp_Comp'Img);
Error (R, " got : " & Act_Comp'Img);
end if;
end Check_Belongs_To_Component;
-------------------------------------
-- Check_Belongs_To_Some_Component --
-------------------------------------
procedure Check_Belongs_To_Some_Component
(R : String;
G : Directed_Graph;
V : Vertex_Id)
is
begin
if not Present (Component (G, V)) then
Error (R, "vertex " & V'Img & " does not belong to a component");
end if;
end Check_Belongs_To_Some_Component;
------------------------------
-- Check_Destination_Vertex --
------------------------------
procedure Check_Destination_Vertex
(R : String;
G : Directed_Graph;
E : Edge_Id;
Exp_V : Vertex_Id)
is
Act_V : constant Vertex_Id := Destination_Vertex (G, E);
begin
if Act_V /= Exp_V then
Error (R, "inconsistent destination vertex for edge " & E'Img);
Error (R, " expected: " & Exp_V'Img);
Error (R, " got : " & Act_V'Img);
end if;
end Check_Destination_Vertex;
-------------------------------
-- Check_Distinct_Components --
-------------------------------
procedure Check_Distinct_Components
(R : String;
Comp_1 : Component_Id;
Comp_2 : Component_Id)
is
begin
if Comp_1 = Comp_2 then
Error (R, "components are not distinct");
end if;
end Check_Distinct_Components;
-------------------------
-- Check_Has_Component --
-------------------------
procedure Check_Has_Component
(R : String;
G : Directed_Graph;
G_Name : String;
Comp : Component_Id)
is
begin
if not Contains_Component (G, Comp) then
Error (R, "graph " & G_Name & " lacks component");
end if;
end Check_Has_Component;
--------------------
-- Check_Has_Edge --
--------------------
procedure Check_Has_Edge
(R : String;
G : Directed_Graph;
E : Edge_Id)
is
begin
if not Contains_Edge (G, E) then
Error (R, "graph lacks edge " & E'Img);
end if;
end Check_Has_Edge;
----------------------
-- Check_Has_Vertex --
----------------------
procedure Check_Has_Vertex
(R : String;
G : Directed_Graph;
V : Vertex_Id)
is
begin
if not Contains_Vertex (G, V) then
Error (R, "graph lacks vertex " & V'Img);
end if;
end Check_Has_Vertex;
------------------------
-- Check_No_Component --
------------------------
procedure Check_No_Component
(R : String;
G : Directed_Graph;
V : Vertex_Id)
is
begin
if Present (Component (G, V)) then
Error (R, "vertex " & V'Img & " belongs to a component");
end if;
end Check_No_Component;
procedure Check_No_Component
(R : String;
G : Directed_Graph;
G_Name : String;
Comp : Component_Id)
is
begin
if Contains_Component (G, Comp) then
Error (R, "graph " & G_Name & " contains component");
end if;
end Check_No_Component;
-------------------
-- Check_No_Edge --
-------------------
procedure Check_No_Edge
(R : String;
G : Directed_Graph;
E : Edge_Id)
is
begin
if Contains_Edge (G, E) then
Error (R, "graph contains edge " & E'Img);
end if;
end Check_No_Edge;
---------------------
-- Check_No_Vertex --
---------------------
procedure Check_No_Vertex
(R : String;
G : Directed_Graph;
V : Vertex_Id)
is
begin
if Contains_Vertex (G, V) then
Error (R, "graph contains vertex " & V'Img);
end if;
end Check_No_Vertex;
--------------------------------
-- Check_Number_Of_Components --
--------------------------------
procedure Check_Number_Of_Components
(R : String;
G : Directed_Graph;
Exp_Num : Natural)
is
Act_Num : constant Natural := Number_Of_Components (G);
begin
if Act_Num /= Exp_Num then
Error (R, "inconsistent number of components");
Error (R, " expected: " & Exp_Num'Img);
Error (R, " got : " & Act_Num'Img);
end if;
end Check_Number_Of_Components;
---------------------------
-- Check_Number_Of_Edges --
---------------------------
procedure Check_Number_Of_Edges
(R : String;
G : Directed_Graph;
Exp_Num : Natural)
is
Act_Num : constant Natural := Number_Of_Edges (G);
begin
if Act_Num /= Exp_Num then
Error (R, "inconsistent number of edges");
Error (R, " expected: " & Exp_Num'Img);
Error (R, " got : " & Act_Num'Img);
end if;
end Check_Number_Of_Edges;
------------------------------
-- Check_Number_Of_Vertices --
------------------------------
procedure Check_Number_Of_Vertices
(R : String;
G : Directed_Graph;
Exp_Num : Natural)
is
Act_Num : constant Natural := Number_Of_Vertices (G);
begin
if Act_Num /= Exp_Num then
Error (R, "inconsistent number of vertices");
Error (R, " expected: " & Exp_Num'Img);
Error (R, " got : " & Act_Num'Img);
end if;
end Check_Number_Of_Vertices;
----------------------------------
-- Check_Outgoing_Edge_Iterator --
----------------------------------
procedure Check_Outgoing_Edge_Iterator
(R : String;
G : Directed_Graph;
V : Vertex_Id;
Set : ES.Membership_Set)
is
E : Edge_Id;
Out_E_Iter : Outgoing_Edge_Iterator;
begin
-- Iterate over all outgoing edges of vertex V while removing edges seen
-- from the set.
Out_E_Iter := Iterate_Outgoing_Edges (G, V);
while Has_Next (Out_E_Iter) loop
Next (Out_E_Iter, E);
if ES.Contains (Set, E) then
ES.Delete (Set, E);
else
Error (R, "outgoing edge " & E'Img & " is not iterated");
end if;
end loop;
-- At this point the set of edges should be empty
if not ES.Is_Empty (Set) then
Error (R, "not all outgoing edges were iterated");
end if;
end Check_Outgoing_Edge_Iterator;
-------------------------
-- Check_Source_Vertex --
-------------------------
procedure Check_Source_Vertex
(R : String;
G : Directed_Graph;
E : Edge_Id;
Exp_V : Vertex_Id)
is
Act_V : constant Vertex_Id := Source_Vertex (G, E);
begin
if Act_V /= Exp_V then
Error (R, "inconsistent source vertex");
Error (R, " expected: " & Exp_V'Img);
Error (R, " got : " & Act_V'Img);
end if;
end Check_Source_Vertex;
---------------------------
-- Check_Vertex_Iterator --
---------------------------
procedure Check_Vertex_Iterator
(R : String;
G : Directed_Graph;
Comp : Component_Id;
Set : VS.Membership_Set)
is
V : Vertex_Id;
V_Iter : Vertex_Iterator;
begin
-- Iterate over all vertices of component Comp while removing vertices
-- seen from the set.
V_Iter := Iterate_Vertices (G, Comp);
while Has_Next (V_Iter) loop
Next (V_Iter, V);
if VS.Contains (Set, V) then
VS.Delete (Set, V);
else
Error (R, "vertex " & V'Img & " is not iterated");
end if;
end loop;
-- At this point the set of vertices should be empty
if not VS.Is_Empty (Set) then
Error (R, "not all vertices were iterated");
end if;
end Check_Vertex_Iterator;
-------------------------
-- Create_And_Populate --
-------------------------
function Create_And_Populate return Directed_Graph is
G : constant Directed_Graph :=
Create (Initial_Vertices => Vertex_Id'Size,
Initial_Edges => Edge_Id'Size);
begin
-- 9 8 1 2
-- G <------ F <------ A ------> B -------> C
-- | ^ | | ^ ^
-- +------------------+ | +-------------------+
-- 10 | | 3
-- 4 | 5 |
-- v |
-- H D ---------+
-- | ^
-- | |
-- 6 | | 7
-- | |
-- v |
-- E
--
-- Components:
--
-- [A, F, G]
-- [B]
-- [C]
-- [D, E]
-- [H]
Add_Vertex (G, VA);
Add_Vertex (G, VB);
Add_Vertex (G, VC);
Add_Vertex (G, VD);
Add_Vertex (G, VE);
Add_Vertex (G, VF);
Add_Vertex (G, VG);
Add_Vertex (G, VH);
Add_Edge (G, E1, Source => VA, Destination => VB);
Add_Edge (G, E2, Source => VB, Destination => VC);
Add_Edge (G, E3, Source => VA, Destination => VC);
Add_Edge (G, E4, Source => VA, Destination => VD);
Add_Edge (G, E5, Source => VD, Destination => VB);
Add_Edge (G, E6, Source => VD, Destination => VE);
Add_Edge (G, E7, Source => VE, Destination => VD);
Add_Edge (G, E8, Source => VA, Destination => VF);
Add_Edge (G, E9, Source => VF, Destination => VG);
Add_Edge (G, E10, Source => VG, Destination => VA);
return G;
end Create_And_Populate;
-----------
-- Error --
-----------
procedure Error (R : String; Msg : String) is
begin
Put_Line ("ERROR: " & R & ": " & Msg);
end Error;
---------------
-- Hash_Edge --
---------------
function Hash_Edge (E : Edge_Id) return Bucket_Range_Type is
begin
return Bucket_Range_Type (Edge_Id'Pos (E));
end Hash_Edge;
-----------------
-- Hash_Vertex --
-----------------
function Hash_Vertex (V : Vertex_Id) return Bucket_Range_Type is
begin
return Bucket_Range_Type (Vertex_Id'Pos (V));
end Hash_Vertex;
-------------------
-- Test_Add_Edge --
-------------------
procedure Test_Add_Edge is
R : constant String := "Test_Add_Edge";
E : Edge_Id;
G : Directed_Graph := Create_And_Populate;
All_E_Iter : All_Edge_Iterator;
Out_E_Iter : Outgoing_Edge_Iterator;
begin
-- Try to add the same edge twice
begin
Add_Edge (G, E1, VB, VH);
Error (R, "duplicate edge not detected");
exception
when Duplicate_Edge => null;
when others => Unexpected_Exception (R);
end;
-- Try to add an edge with a bogus source
begin
Add_Edge (G, E97, Source => VX, Destination => VC);
Error (R, "missing vertex not detected");
exception
when Missing_Vertex => null;
when others => Unexpected_Exception (R);
end;
-- Try to add an edge with a bogus destination
begin
Add_Edge (G, E97, Source => VF, Destination => VY);
Error (R, "missing vertex not detected");
exception
when Missing_Vertex => null;
when others => Unexpected_Exception (R);
end;
-- Delete edge E1 between vertices VA and VB
begin
Delete_Edge (G, E1);
exception
when others => Unexpected_Exception (R);
end;
-- Try to re-add edge E1
begin
Add_Edge (G, E1, Source => VA, Destination => VB);
exception
when others => Unexpected_Exception (R);
end;
-- Lock all edges in the graph
All_E_Iter := Iterate_All_Edges (G);
-- Try to add an edge given that all edges are locked
begin
Add_Edge (G, E97, Source => VG, Destination => VH);
Error (R, "all edges not locked");
exception
when Iterated => null;
when others => Unexpected_Exception (R);
end;
-- Unlock all edges by iterating over them
while Has_Next (All_E_Iter) loop Next (All_E_Iter, E); end loop;
-- Lock all outgoing edges of vertex VD
Out_E_Iter := Iterate_Outgoing_Edges (G, VD);
-- Try to add an edge with source VD given that all edges of VD are
-- locked.
begin
Add_Edge (G, E97, Source => VD, Destination => VG);
Error (R, "outgoing edges of VD not locked");
exception
when Iterated => null;
when others => Unexpected_Exception (R);
end;
-- Unlock the edges of vertex VD by iterating over them
while Has_Next (Out_E_Iter) loop Next (Out_E_Iter, E); end loop;
Destroy (G);
end Test_Add_Edge;
---------------------
-- Test_Add_Vertex --
---------------------
procedure Test_Add_Vertex is
R : constant String := "Test_Add_Vertex";
G : Directed_Graph := Create_And_Populate;
V : Vertex_Id;
All_V_Iter : All_Vertex_Iterator;
begin
-- Try to add the same vertex twice
begin
Add_Vertex (G, VD);
Error (R, "duplicate vertex not detected");
exception
when Duplicate_Vertex => null;
when others => Unexpected_Exception (R);
end;
-- Lock all vertices in the graph
All_V_Iter := Iterate_All_Vertices (G);
-- Try to add a vertex given that all vertices are locked
begin
Add_Vertex (G, VZ);
Error (R, "all vertices not locked");
exception
when Iterated => null;
when others => Unexpected_Exception (R);
end;
-- Unlock all vertices by iterating over them
while Has_Next (All_V_Iter) loop Next (All_V_Iter, V); end loop;
Destroy (G);
end Test_Add_Vertex;
----------------------------
-- Test_All_Edge_Iterator --
----------------------------
procedure Test_All_Edge_Iterator is
R : constant String := "Test_All_Edge_Iterator";
E : Edge_Id;
G : Directed_Graph := Create_And_Populate;
All_E_Iter : All_Edge_Iterator;
All_Edges : ES.Membership_Set;
begin
-- Collect all expected edges in a set
All_Edges := ES.Create (Number_Of_Edges (G));
for Curr_E in E1 .. E10 loop
ES.Insert (All_Edges, Curr_E);
end loop;
-- Iterate over all edges while removing encountered edges from the set
All_E_Iter := Iterate_All_Edges (G);
while Has_Next (All_E_Iter) loop
Next (All_E_Iter, E);
if ES.Contains (All_Edges, E) then
ES.Delete (All_Edges, E);
else
Error (R, "edge " & E'Img & " is not iterated");
end if;
end loop;
-- At this point the set of edges should be empty
if not ES.Is_Empty (All_Edges) then
Error (R, "not all edges were iterated");
end if;
ES.Destroy (All_Edges);
Destroy (G);
end Test_All_Edge_Iterator;
------------------------------
-- Test_All_Vertex_Iterator --
------------------------------
procedure Test_All_Vertex_Iterator is
R : constant String := "Test_All_Vertex_Iterator";
G : Directed_Graph := Create_And_Populate;
V : Vertex_Id;
All_V_Iter : All_Vertex_Iterator;
All_Vertices : VS.Membership_Set;
begin
-- Collect all expected vertices in a set
All_Vertices := VS.Create (Number_Of_Vertices (G));
for Curr_V in VA .. VH loop
VS.Insert (All_Vertices, Curr_V);
end loop;
-- Iterate over all vertices while removing encountered vertices from
-- the set.
All_V_Iter := Iterate_All_Vertices (G);
while Has_Next (All_V_Iter) loop
Next (All_V_Iter, V);
if VS.Contains (All_Vertices, V) then
VS.Delete (All_Vertices, V);
else
Error (R, "vertex " & V'Img & " is not iterated");
end if;
end loop;
-- At this point the set of vertices should be empty
if not VS.Is_Empty (All_Vertices) then
Error (R, "not all vertices were iterated");
end if;
VS.Destroy (All_Vertices);
Destroy (G);
end Test_All_Vertex_Iterator;
--------------------
-- Test_Component --
--------------------
procedure Test_Component is
R : constant String := "Test_Component";
G : Directed_Graph := Create (Initial_Vertices => 3, Initial_Edges => 2);
begin
-- E1
-- ----->
-- VA VB VC
-- <-----
-- E2
--
-- Components:
--
-- [VA, VB]
-- [VC]
Add_Vertex (G, VA);
Add_Vertex (G, VB);
Add_Vertex (G, VC);
Add_Edge (G, E1, Source => VA, Destination => VB);
Add_Edge (G, E2, Source => VB, Destination => VA);
-- None of the vertices should belong to a component
Check_No_Component (R, G, VA);
Check_No_Component (R, G, VB);
Check_No_Component (R, G, VC);
-- Find the strongly connected components in the graph
Find_Components (G);
-- Vertices should belong to a component
Check_Belongs_To_Some_Component (R, G, VA);
Check_Belongs_To_Some_Component (R, G, VB);
Check_Belongs_To_Some_Component (R, G, VC);
Destroy (G);
end Test_Component;
-----------------------------
-- Test_Component_Iterator --
-----------------------------
procedure Test_Component_Iterator is
R : constant String := "Test_Component_Iterator";
G : Directed_Graph := Create_And_Populate;
Comp : Component_Id;
Comp_Count : Natural;
Comp_Iter : Component_Iterator;
begin
Find_Components (G);
Check_Number_Of_Components (R, G, 5);
Comp_Count := Number_Of_Components (G);
-- Iterate over all components while decrementing their number
Comp_Iter := Iterate_Components (G);
while Has_Next (Comp_Iter) loop
Next (Comp_Iter, Comp);
Comp_Count := Comp_Count - 1;
end loop;
-- At this point all components should have been accounted for
if Comp_Count /= 0 then
Error (R, "not all components were iterated");
end if;
Destroy (G);
end Test_Component_Iterator;
-----------------------------
-- Test_Contains_Component --
-----------------------------
procedure Test_Contains_Component is
R : constant String := "Test_Contains_Component";
G1 : Directed_Graph :=
Create (Initial_Vertices => 2, Initial_Edges => 2);
G2 : Directed_Graph :=
Create (Initial_Vertices => 2, Initial_Edges => 2);
begin
-- E1
-- ----->
-- VA VB
-- <-----
-- E2
--
-- Components:
--
-- [VA, VB]
Add_Vertex (G1, VA);
Add_Vertex (G1, VB);
Add_Edge (G1, E1, Source => VA, Destination => VB);
Add_Edge (G1, E2, Source => VB, Destination => VA);
-- E97
-- ----->
-- VX VY
-- <-----
-- E98
--
-- Components:
--
-- [VX, VY]
Add_Vertex (G2, VX);
Add_Vertex (G2, VY);
Add_Edge (G2, E97, Source => VX, Destination => VY);
Add_Edge (G2, E98, Source => VY, Destination => VX);
-- Find the strongly connected components in both graphs
Find_Components (G1);
Find_Components (G2);
-- Vertices should belong to a component
Check_Belongs_To_Some_Component (R, G1, VA);
Check_Belongs_To_Some_Component (R, G1, VB);
Check_Belongs_To_Some_Component (R, G2, VX);
Check_Belongs_To_Some_Component (R, G2, VY);
-- Verify that each graph contains the correct component
Check_Has_Component (R, G1, "G1", Component (G1, VA));
Check_Has_Component (R, G1, "G1", Component (G1, VB));
Check_Has_Component (R, G2, "G2", Component (G2, VX));
Check_Has_Component (R, G2, "G2", Component (G2, VY));
-- Verify that each graph does not contain components from the other
-- graph.
Check_No_Component (R, G1, "G1", Component (G2, VX));
Check_No_Component (R, G1, "G1", Component (G2, VY));
Check_No_Component (R, G2, "G2", Component (G1, VA));
Check_No_Component (R, G2, "G2", Component (G1, VB));
Destroy (G1);
Destroy (G2);
end Test_Contains_Component;
------------------------
-- Test_Contains_Edge --
------------------------
procedure Test_Contains_Edge is
R : constant String := "Test_Contains_Edge";
G : Directed_Graph := Create_And_Populate;
begin
-- Verify that all edges in the range E1 .. E10 exist
for Curr_E in E1 .. E10 loop
Check_Has_Edge (R, G, Curr_E);
end loop;
-- Verify that no extra edges are present
for Curr_E in E97 .. E99 loop
Check_No_Edge (R, G, Curr_E);
end loop;
-- Add new edges E97, E98, and E99
Add_Edge (G, E97, Source => VG, Destination => VF);
Add_Edge (G, E98, Source => VH, Destination => VE);
Add_Edge (G, E99, Source => VD, Destination => VC);
-- Verify that all edges in the range E1 .. E99 exist
for Curr_E in E1 .. E99 loop
Check_Has_Edge (R, G, Curr_E);
end loop;
-- Delete each edge that corresponds to an even position in Edge_Id
for Curr_E in E1 .. E99 loop
if Edge_Id'Pos (Curr_E) mod 2 = 0 then
Delete_Edge (G, Curr_E);
end if;
end loop;
-- Verify that all "even" edges are missing, and all "odd" edges are
-- present.
for Curr_E in E1 .. E99 loop
if Edge_Id'Pos (Curr_E) mod 2 = 0 then
Check_No_Edge (R, G, Curr_E);
else
Check_Has_Edge (R, G, Curr_E);
end if;
end loop;
Destroy (G);
end Test_Contains_Edge;
--------------------------
-- Test_Contains_Vertex --
--------------------------
procedure Test_Contains_Vertex is
R : constant String := "Test_Contains_Vertex";
G : Directed_Graph := Create_And_Populate;
begin
-- Verify that all vertices in the range VA .. VH exist
for Curr_V in VA .. VH loop
Check_Has_Vertex (R, G, Curr_V);
end loop;
-- Verify that no extra vertices are present
for Curr_V in VX .. VZ loop
Check_No_Vertex (R, G, Curr_V);
end loop;
-- Add new vertices VX, VY, and VZ
Add_Vertex (G, VX);
Add_Vertex (G, VY);
Add_Vertex (G, VZ);
-- Verify that all vertices in the range VA .. VZ exist
for Curr_V in VA .. VZ loop
Check_Has_Vertex (R, G, Curr_V);
end loop;
Destroy (G);
end Test_Contains_Vertex;
----------------------
-- Test_Delete_Edge --
----------------------
procedure Test_Delete_Edge is
R : constant String := "Test_Delete_Edge";
E : Edge_Id;
G : Directed_Graph := Create_And_Populate;
V : Vertex_Id;
All_E_Iter : All_Edge_Iterator;
All_V_Iter : All_Vertex_Iterator;
Out_E_Iter : Outgoing_Edge_Iterator;
begin
-- Try to delete a bogus edge
begin
Delete_Edge (G, E97);
Error (R, "missing vertex deleted");
exception
when Missing_Edge => null;
when others => Unexpected_Exception (R);
end;
-- Delete edge E1 between vertices VA and VB
begin
Delete_Edge (G, E1);
exception
when others => Unexpected_Exception (R);
end;
-- Verify that edge E1 is gone from all edges in the graph
All_E_Iter := Iterate_All_Edges (G);
while Has_Next (All_E_Iter) loop
Next (All_E_Iter, E);
if E = E1 then
Error (R, "edge " & E'Img & " not removed from all edges");
end if;
end loop;
-- Verify that edge E1 is gone from the outgoing edges of vertex VA
Out_E_Iter := Iterate_Outgoing_Edges (G, VA);
while Has_Next (Out_E_Iter) loop
Next (Out_E_Iter, E);
if E = E1 then
Error
(R, "edge " & E'Img & "not removed from outgoing edges of VA");
end if;
end loop;
-- Delete all edges in the range E2 .. E10
for Curr_E in E2 .. E10 loop
Delete_Edge (G, Curr_E);
end loop;
-- Verify that all edges are gone from the graph
All_E_Iter := Iterate_All_Edges (G);
while Has_Next (All_E_Iter) loop
Next (All_E_Iter, E);
Error (R, "edge " & E'Img & " not removed from all edges");
end loop;
-- Verify that all edges are gone from the respective source vertices
All_V_Iter := Iterate_All_Vertices (G);
while Has_Next (All_V_Iter) loop
Next (All_V_Iter, V);
Out_E_Iter := Iterate_Outgoing_Edges (G, V);
while Has_Next (Out_E_Iter) loop
Next (Out_E_Iter, E);
Error (R, "edge " & E'Img & " not removed from vertex " & V'Img);
end loop;
end loop;
Destroy (G);
end Test_Delete_Edge;
-----------------------------
-- Test_Destination_Vertex --
-----------------------------
procedure Test_Destination_Vertex is
R : constant String := "Test_Destination_Vertex";
G : Directed_Graph := Create_And_Populate;
begin
-- Verify the destination vertices of all edges in the graph
Check_Destination_Vertex (R, G, E1, VB);
Check_Destination_Vertex (R, G, E2, VC);
Check_Destination_Vertex (R, G, E3, VC);
Check_Destination_Vertex (R, G, E4, VD);
Check_Destination_Vertex (R, G, E5, VB);
Check_Destination_Vertex (R, G, E6, VE);
Check_Destination_Vertex (R, G, E7, VD);
Check_Destination_Vertex (R, G, E8, VF);
Check_Destination_Vertex (R, G, E9, VG);
Check_Destination_Vertex (R, G, E10, VA);
Destroy (G);
end Test_Destination_Vertex;
--------------------------
-- Test_Find_Components --
--------------------------
procedure Test_Find_Components is
R : constant String := "Test_Find_Components";
G : Directed_Graph := Create_And_Populate;
Comp_1 : Component_Id; -- [A, F, G]
Comp_2 : Component_Id; -- [B]
Comp_3 : Component_Id; -- [C]
Comp_4 : Component_Id; -- [D, E]
Comp_5 : Component_Id; -- [H]
begin
Find_Components (G);
-- Vertices should belong to a component
Check_Belongs_To_Some_Component (R, G, VA);
Check_Belongs_To_Some_Component (R, G, VB);
Check_Belongs_To_Some_Component (R, G, VC);
Check_Belongs_To_Some_Component (R, G, VD);
Check_Belongs_To_Some_Component (R, G, VH);
-- Extract the ids of the components from the first vertices in each
-- component.
Comp_1 := Component (G, VA);
Comp_2 := Component (G, VB);
Comp_3 := Component (G, VC);
Comp_4 := Component (G, VD);
Comp_5 := Component (G, VH);
-- Verify that the components are distinct
Check_Distinct_Components (R, Comp_1, Comp_2);
Check_Distinct_Components (R, Comp_1, Comp_3);
Check_Distinct_Components (R, Comp_1, Comp_4);
Check_Distinct_Components (R, Comp_1, Comp_5);
Check_Distinct_Components (R, Comp_2, Comp_3);
Check_Distinct_Components (R, Comp_2, Comp_4);
Check_Distinct_Components (R, Comp_2, Comp_5);
Check_Distinct_Components (R, Comp_3, Comp_4);
Check_Distinct_Components (R, Comp_3, Comp_5);
Check_Distinct_Components (R, Comp_4, Comp_5);
-- Verify that the remaining nodes belong to the proper component
Check_Belongs_To_Component (R, G, VF, Comp_1);
Check_Belongs_To_Component (R, G, VG, Comp_1);
Check_Belongs_To_Component (R, G, VE, Comp_4);
Destroy (G);
end Test_Find_Components;
-------------------
-- Test_Is_Empty --
-------------------
procedure Test_Is_Empty is
R : constant String := "Test_Is_Empty";
G : Directed_Graph := Create (Initial_Vertices => 3, Initial_Edges => 2);
begin
-- Verify that a graph without vertices and edges is empty
if not Is_Empty (G) then
Error (R, "graph is empty");
end if;
-- Add vertices
Add_Vertex (G, VA);
Add_Vertex (G, VB);
-- Verify that a graph with vertices and no edges is not empty
if Is_Empty (G) then
Error (R, "graph is not empty");
end if;
-- Add edges
Add_Edge (G, E1, Source => VA, Destination => VB);
-- Verify that a graph with vertices and edges is not empty
if Is_Empty (G) then
Error (R, "graph is not empty");
end if;
Destroy (G);
end Test_Is_Empty;
-------------------------------
-- Test_Number_Of_Components --
-------------------------------
procedure Test_Number_Of_Components is
R : constant String := "Test_Number_Of_Components";
G : Directed_Graph := Create (Initial_Vertices => 3, Initial_Edges => 2);
begin
-- Verify that an empty graph has exactly 0 components
Check_Number_Of_Components (R, G, 0);
-- E1
-- ----->
-- VA VB VC
-- <-----
-- E2
--
-- Components:
--
-- [VA, VB]
-- [VC]
Add_Vertex (G, VA);
Add_Vertex (G, VB);
Add_Vertex (G, VC);
Add_Edge (G, E1, Source => VA, Destination => VB);
Add_Edge (G, E2, Source => VB, Destination => VA);
-- Verify that the graph has exact 0 components even though it contains
-- vertices and edges.
Check_Number_Of_Components (R, G, 0);
Find_Components (G);
-- Verify that the graph has exactly 2 components
Check_Number_Of_Components (R, G, 2);
Destroy (G);
end Test_Number_Of_Components;
--------------------------
-- Test_Number_Of_Edges --
--------------------------
procedure Test_Number_Of_Edges is
R : constant String := "Test_Number_Of_Edges";
G : Directed_Graph := Create_And_Populate;
begin
-- Verify that the graph has exactly 10 edges
Check_Number_Of_Edges (R, G, 10);
-- Delete two edges
Delete_Edge (G, E1);
Delete_Edge (G, E2);
-- Verify that the graph has exactly 8 edges
Check_Number_Of_Edges (R, G, 8);
-- Delete the remaining edge
for Curr_E in E3 .. E10 loop
Delete_Edge (G, Curr_E);
end loop;
-- Verify that the graph has exactly 0 edges
Check_Number_Of_Edges (R, G, 0);
-- Add two edges
Add_Edge (G, E1, Source => VF, Destination => VA);
Add_Edge (G, E2, Source => VC, Destination => VH);
-- Verify that the graph has exactly 2 edges
Check_Number_Of_Edges (R, G, 2);
Destroy (G);
end Test_Number_Of_Edges;
-----------------------------
-- Test_Number_Of_Vertices --
-----------------------------
procedure Test_Number_Of_Vertices is
R : constant String := "Test_Number_Of_Vertices";
G : Directed_Graph :=
Create (Initial_Vertices => 4, Initial_Edges => 12);
begin
-- Verify that an empty graph has exactly 0 vertices
Check_Number_Of_Vertices (R, G, 0);
-- Add three vertices
Add_Vertex (G, VC);
Add_Vertex (G, VG);
Add_Vertex (G, VX);
-- Verify that the graph has exactly 3 vertices
Check_Number_Of_Vertices (R, G, 3);
-- Add one edge
Add_Edge (G, E8, Source => VX, Destination => VG);
-- Verify that the graph has exactly 3 vertices
Check_Number_Of_Vertices (R, G, 3);
Destroy (G);
end Test_Number_Of_Vertices;
---------------------------------
-- Test_Outgoing_Edge_Iterator --
---------------------------------
procedure Test_Outgoing_Edge_Iterator is
R : constant String := "Test_Outgoing_Edge_Iterator";
G : Directed_Graph := Create_And_Populate;
Set : ES.Membership_Set;
begin
Set := ES.Create (4);
ES.Insert (Set, E1);
ES.Insert (Set, E3);
ES.Insert (Set, E4);
ES.Insert (Set, E8);
Check_Outgoing_Edge_Iterator (R, G, VA, Set);
ES.Insert (Set, E2);
Check_Outgoing_Edge_Iterator (R, G, VB, Set);
Check_Outgoing_Edge_Iterator (R, G, VC, Set);
ES.Insert (Set, E5);
ES.Insert (Set, E6);
Check_Outgoing_Edge_Iterator (R, G, VD, Set);
ES.Insert (Set, E7);
Check_Outgoing_Edge_Iterator (R, G, VE, Set);
ES.Insert (Set, E9);
Check_Outgoing_Edge_Iterator (R, G, VF, Set);
ES.Insert (Set, E10);
Check_Outgoing_Edge_Iterator (R, G, VG, Set);
Check_Outgoing_Edge_Iterator (R, G, VH, Set);
ES.Destroy (Set);
Destroy (G);
end Test_Outgoing_Edge_Iterator;
------------------
-- Test_Present --
------------------
procedure Test_Present is
R : constant String := "Test_Present";
G : Directed_Graph := Nil;
begin
-- Verify that a non-existent graph is not present
if Present (G) then
Error (R, "graph is not present");
end if;
G := Create_And_Populate;
-- Verify that an existing graph is present
if not Present (G) then
Error (R, "graph is present");
end if;
Destroy (G);
-- Verify that a destroyed graph is not present
if Present (G) then
Error (R, "graph is not present");
end if;
end Test_Present;
------------------------
-- Test_Source_Vertex --
------------------------
procedure Test_Source_Vertex is
R : constant String := "Test_Source_Vertex";
G : Directed_Graph := Create_And_Populate;
begin
-- Verify the source vertices of all edges in the graph
Check_Source_Vertex (R, G, E1, VA);
Check_Source_Vertex (R, G, E2, VB);
Check_Source_Vertex (R, G, E3, VA);
Check_Source_Vertex (R, G, E4, VA);
Check_Source_Vertex (R, G, E5, VD);
Check_Source_Vertex (R, G, E6, VD);
Check_Source_Vertex (R, G, E7, VE);
Check_Source_Vertex (R, G, E8, VA);
Check_Source_Vertex (R, G, E9, VF);
Check_Source_Vertex (R, G, E10, VG);
Destroy (G);
end Test_Source_Vertex;
--------------------------
-- Test_Vertex_Iterator --
--------------------------
procedure Test_Vertex_Iterator is
R : constant String := "Test_Vertex_Iterator";
G : Directed_Graph := Create_And_Populate;
Set : VS.Membership_Set;
begin
Find_Components (G);
Set := VS.Create (3);
VS.Insert (Set, VA);
VS.Insert (Set, VF);
VS.Insert (Set, VG);
Check_Vertex_Iterator (R, G, Component (G, VA), Set);
VS.Insert (Set, VB);
Check_Vertex_Iterator (R, G, Component (G, VB), Set);
VS.Insert (Set, VC);
Check_Vertex_Iterator (R, G, Component (G, VC), Set);
VS.Insert (Set, VD);
VS.Insert (Set, VE);
Check_Vertex_Iterator (R, G, Component (G, VD), Set);
VS.Insert (Set, VH);
Check_Vertex_Iterator (R, G, Component (G, VH), Set);
VS.Destroy (Set);
Destroy (G);
end Test_Vertex_Iterator;
--------------------------
-- Unexpected_Exception --
--------------------------
procedure Unexpected_Exception (R : String) is
begin
Error (R, "unexpected exception");
end Unexpected_Exception;
-- Start of processing for Operations
begin
Test_Add_Edge;
Test_Add_Vertex;
Test_All_Edge_Iterator;
Test_All_Vertex_Iterator;
Test_Component;
Test_Component_Iterator;
Test_Contains_Component;
Test_Contains_Edge;
Test_Contains_Vertex;
Test_Delete_Edge;
Test_Destination_Vertex;
Test_Find_Components;
Test_Is_Empty;
Test_Number_Of_Components;
Test_Number_Of_Edges;
Test_Number_Of_Vertices;
Test_Outgoing_Edge_Iterator;
Test_Present;
Test_Source_Vertex;
Test_Vertex_Iterator;
end Operations;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q operations.adb -largs -lgmem
$ ./operations
$ gnatmem operations > leaks.txt
$ grep -c "non freed allocations" leaks.txt
0
2019-07-01 Hristian Kirtchev <kirtchev@adacore.com>
gcc/ada/
* libgnat/g-graphs.adb: Use type Directed_Graph rather than
Instance in various routines.
* libgnat/g-graphs.ads: Change type Instance to Directed_Graph.
Update various routines that mention the type.
From-SVN: r272863
Hristian Kirtchev [Mon, 1 Jul 2019 13:35:07 +0000 (13:35 +0000)]
[Ada] Clean up of GNAT.Sets
------------
-- Source --
------------
-- operations.adb
with Ada.Text_IO; use Ada.Text_IO;
with GNAT; use GNAT;
with GNAT.Sets; use GNAT.Sets;
procedure Operations is
function Hash (Key : Integer) return Bucket_Range_Type;
package Integer_Sets is new Membership_Sets
(Element_Type => Integer,
"=" => "=",
Hash => Hash);
use Integer_Sets;
procedure Check_Empty
(Caller : String;
S : Membership_Set;
Low_Elem : Integer;
High_Elem : Integer);
-- Ensure that none of the elements in the range Low_Elem .. High_Elem are
-- present in set S, and that the set's length is 0.
procedure Check_Locked_Mutations
(Caller : String;
S : in out Membership_Set);
-- Ensure that all mutation operations of set S are locked
procedure Check_Present
(Caller : String;
S : Membership_Set;
Low_Elem : Integer;
High_Elem : Integer);
-- Ensure that all elements in the range Low_Elem .. High_Elem are present
-- in set S.
procedure Check_Unlocked_Mutations
(Caller : String;
S : in out Membership_Set);
-- Ensure that all mutation operations of set S are unlocked
procedure Populate
(S : Membership_Set;
Low_Elem : Integer;
High_Elem : Integer);
-- Add elements in the range Low_Elem .. High_Elem in set S
procedure Test_Contains
(Low_Elem : Integer;
High_Elem : Integer;
Init_Size : Positive);
-- Verify that Contains properly identifies that elements in the range
-- Low_Elem .. High_Elem are within a set. Init_Size denotes the initial
-- size of the set.
procedure Test_Create;
-- Verify that all set operations fail on a non-created set
procedure Test_Delete
(Low_Elem : Integer;
High_Elem : Integer;
Init_Size : Positive);
-- Verify that Delete properly removes elements in the range Low_Elem ..
-- High_Elem from a set. Init_Size denotes the initial size of the set.
procedure Test_Is_Empty;
-- Verify that Is_Empty properly returns this status of a set
procedure Test_Iterate;
-- Verify that iterators properly manipulate mutation operations
procedure Test_Iterate_Empty;
-- Verify that iterators properly manipulate mutation operations of an
-- empty set.
procedure Test_Iterate_Forced
(Low_Elem : Integer;
High_Elem : Integer;
Init_Size : Positive);
-- Verify that an iterator that is forcefully advanced by Next properly
-- unlocks the mutation operations of a set. Init_Size denotes the initial
-- size of the set.
procedure Test_Size;
-- Verify that Size returns the correct size of a set
-----------------
-- Check_Empty --
-----------------
procedure Check_Empty
(Caller : String;
S : Membership_Set;
Low_Elem : Integer;
High_Elem : Integer)
is
Siz : constant Natural := Size (S);
begin
for Elem in Low_Elem .. High_Elem loop
if Contains (S, Elem) then
Put_Line ("ERROR: " & Caller & ": extra element" & Elem'Img);
end if;
end loop;
if Siz /= 0 then
Put_Line ("ERROR: " & Caller & ": wrong size");
Put_Line ("expected: 0");
Put_Line ("got :" & Siz'Img);
end if;
end Check_Empty;
----------------------------
-- Check_Locked_Mutations --
----------------------------
procedure Check_Locked_Mutations
(Caller : String;
S : in out Membership_Set)
is
begin
begin
Delete (S, 1);
Put_Line ("ERROR: " & Caller & ": Delete: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Delete: unexpected exception");
end;
begin
Destroy (S);
Put_Line ("ERROR: " & Caller & ": Destroy: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Destroy: unexpected exception");
end;
begin
Insert (S, 1);
Put_Line ("ERROR: " & Caller & ": Insert: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Insert: unexpected exception");
end;
end Check_Locked_Mutations;
-------------------
-- Check_Present --
-------------------
procedure Check_Present
(Caller : String;
S : Membership_Set;
Low_Elem : Integer;
High_Elem : Integer)
is
Elem : Integer;
Iter : Iterator;
begin
Iter := Iterate (S);
for Exp_Elem in Low_Elem .. High_Elem loop
Next (Iter, Elem);
if Elem /= Exp_Elem then
Put_Line ("ERROR: " & Caller & ": Check_Present: wrong element");
Put_Line ("expected:" & Exp_Elem'Img);
Put_Line ("got :" & Elem'Img);
end if;
end loop;
-- At this point all elements should have been accounted for. Check for
-- extra elements.
while Has_Next (Iter) loop
Next (Iter, Elem);
Put_Line
("ERROR: " & Caller & ": Check_Present: extra element" & Elem'Img);
end loop;
exception
when Iterator_Exhausted =>
Put_Line
("ERROR: "
& Caller
& "Check_Present: incorrect number of elements");
end Check_Present;
------------------------------
-- Check_Unlocked_Mutations --
------------------------------
procedure Check_Unlocked_Mutations
(Caller : String;
S : in out Membership_Set)
is
begin
Delete (S, 1);
Insert (S, 1);
end Check_Unlocked_Mutations;
----------
-- Hash --
----------
function Hash (Key : Integer) return Bucket_Range_Type is
begin
return Bucket_Range_Type (Key);
end Hash;
--------------
-- Populate --
--------------
procedure Populate
(S : Membership_Set;
Low_Elem : Integer;
High_Elem : Integer)
is
begin
for Elem in Low_Elem .. High_Elem loop
Insert (S, Elem);
end loop;
end Populate;
-------------------
-- Test_Contains --
-------------------
procedure Test_Contains
(Low_Elem : Integer;
High_Elem : Integer;
Init_Size : Positive)
is
Low_Bogus : constant Integer := Low_Elem - 1;
High_Bogus : constant Integer := High_Elem + 1;
S : Membership_Set := Create (Init_Size);
begin
Populate (S, Low_Elem, High_Elem);
-- Ensure that the elements are contained in the set
for Elem in Low_Elem .. High_Elem loop
if not Contains (S, Elem) then
Put_Line
("ERROR: Test_Contains: element" & Elem'Img & " not in set");
end if;
end loop;
-- Ensure that arbitrary elements which were not inserted in the set are
-- not contained in the set.
if Contains (S, Low_Bogus) then
Put_Line
("ERROR: Test_Contains: element" & Low_Bogus'Img & " in set");
end if;
if Contains (S, High_Bogus) then
Put_Line
("ERROR: Test_Contains: element" & High_Bogus'Img & " in set");
end if;
Destroy (S);
end Test_Contains;
-----------------
-- Test_Create --
-----------------
procedure Test_Create is
Count : Natural;
Flag : Boolean;
Iter : Iterator;
S : Membership_Set;
begin
-- Ensure that every routine defined in the API fails on a set which
-- has not been created yet.
begin
Flag := Contains (S, 1);
Put_Line ("ERROR: Test_Create: Contains: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Contains: unexpected exception");
end;
begin
Delete (S, 1);
Put_Line ("ERROR: Test_Create: Delete: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Delete: unexpected exception");
end;
begin
Insert (S, 1);
Put_Line ("ERROR: Test_Create: Insert: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Insert: unexpected exception");
end;
begin
Flag := Is_Empty (S);
Put_Line ("ERROR: Test_Create: Is_Empty: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Is_Empty: unexpected exception");
end;
begin
Iter := Iterate (S);
Put_Line ("ERROR: Test_Create: Iterate: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Iterate: unexpected exception");
end;
begin
Count := Size (S);
Put_Line ("ERROR: Test_Create: Size: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Size: unexpected exception");
end;
end Test_Create;
-----------------
-- Test_Delete --
-----------------
procedure Test_Delete
(Low_Elem : Integer;
High_Elem : Integer;
Init_Size : Positive)
is
Iter : Iterator;
S : Membership_Set := Create (Init_Size);
begin
Populate (S, Low_Elem, High_Elem);
-- Delete all even elements
for Elem in Low_Elem .. High_Elem loop
if Elem mod 2 = 0 then
Delete (S, Elem);
end if;
end loop;
-- Ensure that all remaining odd elements are present in the set
for Elem in Low_Elem .. High_Elem loop
if Elem mod 2 /= 0 and then not Contains (S, Elem) then
Put_Line ("ERROR: Test_Delete: missing element" & Elem'Img);
end if;
end loop;
-- Delete all odd elements
for Elem in Low_Elem .. High_Elem loop
if Elem mod 2 /= 0 then
Delete (S, Elem);
end if;
end loop;
-- At this point the set should be completely empty
Check_Empty
(Caller => "Test_Delete",
S => S,
Low_Elem => Low_Elem,
High_Elem => High_Elem);
Destroy (S);
end Test_Delete;
-------------------
-- Test_Is_Empty --
-------------------
procedure Test_Is_Empty is
S : Membership_Set := Create (8);
begin
if not Is_Empty (S) then
Put_Line ("ERROR: Test_Is_Empty: set is not empty");
end if;
Insert (S, 1);
if Is_Empty (S) then
Put_Line ("ERROR: Test_Is_Empty: set is empty");
end if;
Delete (S, 1);
if not Is_Empty (S) then
Put_Line ("ERROR: Test_Is_Empty: set is not empty");
end if;
Destroy (S);
end Test_Is_Empty;
------------------
-- Test_Iterate --
------------------
procedure Test_Iterate is
Elem : Integer;
Iter_1 : Iterator;
Iter_2 : Iterator;
S : Membership_Set := Create (5);
begin
Populate (S, 1, 5);
-- Obtain an iterator. This action must lock all mutation operations of
-- the set.
Iter_1 := Iterate (S);
-- Ensure that every mutation routine defined in the API fails on a set
-- with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate",
S => S);
-- Obtain another iterator
Iter_2 := Iterate (S);
-- Ensure that every mutation is still locked
Check_Locked_Mutations
(Caller => "Test_Iterate",
S => S);
-- Exhaust the first itertor
while Has_Next (Iter_1) loop
Next (Iter_1, Elem);
end loop;
-- Ensure that every mutation is still locked
Check_Locked_Mutations
(Caller => "Test_Iterate",
S => S);
-- Exhaust the second itertor
while Has_Next (Iter_2) loop
Next (Iter_2, Elem);
end loop;
-- Ensure that all mutation operations are once again callable
Check_Unlocked_Mutations
(Caller => "Test_Iterate",
S => S);
Destroy (S);
end Test_Iterate;
------------------------
-- Test_Iterate_Empty --
------------------------
procedure Test_Iterate_Empty is
Elem : Integer;
Iter : Iterator;
S : Membership_Set := Create (5);
begin
-- Obtain an iterator. This action must lock all mutation operations of
-- the set.
Iter := Iterate (S);
-- Ensure that every mutation routine defined in the API fails on a set
-- with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate_Empty",
S => S);
-- Attempt to iterate over the elements
while Has_Next (Iter) loop
Next (Iter, Elem);
Put_Line
("ERROR: Test_Iterate_Empty: element" & Elem'Img & " exists");
end loop;
-- Ensure that all mutation operations are once again callable
Check_Unlocked_Mutations
(Caller => "Test_Iterate_Empty",
S => S);
Destroy (S);
end Test_Iterate_Empty;
-------------------------
-- Test_Iterate_Forced --
-------------------------
procedure Test_Iterate_Forced
(Low_Elem : Integer;
High_Elem : Integer;
Init_Size : Positive)
is
Elem : Integer;
Iter : Iterator;
S : Membership_Set := Create (Init_Size);
begin
Populate (S, Low_Elem, High_Elem);
-- Obtain an iterator. This action must lock all mutation operations of
-- the set.
Iter := Iterate (S);
-- Ensure that every mutation routine defined in the API fails on a set
-- with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate_Forced",
S => S);
-- Forcibly advance the iterator until it raises an exception
begin
for Guard in Low_Elem .. High_Elem + 1 loop
Next (Iter, Elem);
end loop;
Put_Line
("ERROR: Test_Iterate_Forced: Iterator_Exhausted not raised");
exception
when Iterator_Exhausted =>
null;
when others =>
Put_Line ("ERROR: Test_Iterate_Forced: unexpected exception");
end;
-- Ensure that all mutation operations are once again callable
Check_Unlocked_Mutations
(Caller => "Test_Iterate_Forced",
S => S);
Destroy (S);
end Test_Iterate_Forced;
---------------
-- Test_Size --
---------------
procedure Test_Size is
S : Membership_Set := Create (6);
Siz : Natural;
begin
Siz := Size (S);
if Siz /= 0 then
Put_Line ("ERROR: Test_Size: wrong size");
Put_Line ("expected: 0");
Put_Line ("got :" & Siz'Img);
end if;
Populate (S, 1, 2);
Siz := Size (S);
if Siz /= 2 then
Put_Line ("ERROR: Test_Size: wrong size");
Put_Line ("expected: 2");
Put_Line ("got :" & Siz'Img);
end if;
Populate (S, 3, 6);
Siz := Size (S);
if Siz /= 6 then
Put_Line ("ERROR: Test_Size: wrong size");
Put_Line ("expected: 6");
Put_Line ("got :" & Siz'Img);
end if;
Destroy (S);
end Test_Size;
-- Start of processing for Operations
begin
Test_Contains
(Low_Elem => 1,
High_Elem => 5,
Init_Size => 5);
Test_Create;
Test_Delete
(Low_Elem => 1,
High_Elem => 10,
Init_Size => 10);
Test_Is_Empty;
Test_Iterate;
Test_Iterate_Empty;
Test_Iterate_Forced
(Low_Elem => 1,
High_Elem => 5,
Init_Size => 5);
Test_Size;
end Operations;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q operations.adb -largs -lgmem
$ ./operations
$ gnatmem operations > leaks.txt
$ grep -c "non freed allocations" leaks.txt
0
2019-07-01 Hristian Kirtchev <kirtchev@adacore.com>
gcc/ada/
* libgnat/g-sets.adb: Use type Membership_Set rathern than
Instance in various routines.
* libgnat/g-sets.ads: Change type Instance to Membership_Set.
Update various routines that mention the type.
gcc/testsuite/
* gnat.dg/sets1.adb: Update.
From-SVN: r272862
Hristian Kirtchev [Mon, 1 Jul 2019 13:35:01 +0000 (13:35 +0000)]
[Ada] Clean up of GNAT.Lists
------------
-- Source --
------------
-- operations.adb
with Ada.Text_IO; use Ada.Text_IO;
with GNAT; use GNAT;
with GNAT.Lists; use GNAT.Lists;
procedure Operations is
procedure Destroy (Val : in out Integer) is null;
package Integer_Lists is new Doubly_Linked_Lists
(Element_Type => Integer,
"=" => "=",
Destroy_Element => Destroy);
use Integer_Lists;
procedure Check_Empty
(Caller : String;
L : Doubly_Linked_List;
Low_Elem : Integer;
High_Elem : Integer);
-- Ensure that none of the elements in the range Low_Elem .. High_Elem are
-- present in list L, and that the list's length is 0.
procedure Check_Locked_Mutations
(Caller : String;
L : in out Doubly_Linked_List);
-- Ensure that all mutation operations of list L are locked
procedure Check_Present
(Caller : String;
L : Doubly_Linked_List;
Low_Elem : Integer;
High_Elem : Integer);
-- Ensure that all elements in the range Low_Elem .. High_Elem are present
-- in list L.
procedure Check_Unlocked_Mutations
(Caller : String;
L : in out Doubly_Linked_List);
-- Ensure that all mutation operations of list L are unlocked
procedure Populate_With_Append
(L : Doubly_Linked_List;
Low_Elem : Integer;
High_Elem : Integer);
-- Add elements in the range Low_Elem .. High_Elem in that order in list L
procedure Test_Append;
-- Verify that Append properly inserts at the tail of a list
procedure Test_Contains
(Low_Elem : Integer;
High_Elem : Integer);
-- Verify that Contains properly identifies that elements in the range
-- Low_Elem .. High_Elem are within a list.
procedure Test_Create;
-- Verify that all list operations fail on a non-created list
procedure Test_Delete
(Low_Elem : Integer;
High_Elem : Integer);
-- Verify that Delete properly removes elements in the range Low_Elem ..
-- High_Elem from a list.
procedure Test_Delete_First
(Low_Elem : Integer;
High_Elem : Integer);
-- Verify that Delete properly removes elements in the range Low_Elem ..
-- High_Elem from the head of a list.
procedure Test_Delete_Last
(Low_Elem : Integer;
High_Elem : Integer);
-- Verify that Delete properly removes elements in the range Low_Elem ..
-- High_Elem from the tail of a list.
procedure Test_First;
-- Verify that First properly returns the head of a list
procedure Test_Insert_After;
-- Verify that Insert_After properly adds an element after some other
-- element.
procedure Test_Insert_Before;
-- Vefity that Insert_Before properly adds an element before some other
-- element.
procedure Test_Is_Empty;
-- Verify that Is_Empty properly returns this status of a list
procedure Test_Iterate;
-- Verify that iterators properly manipulate mutation operations
procedure Test_Iterate_Empty;
-- Verify that iterators properly manipulate mutation operations of an
-- empty list.
procedure Test_Iterate_Forced
(Low_Elem : Integer;
High_Elem : Integer);
-- Verify that an iterator that is forcefully advanced by Next properly
-- unlocks the mutation operations of a list.
procedure Test_Last;
-- Verify that Last properly returns the tail of a list
procedure Test_Prepend;
-- Verify that Prepend properly inserts at the head of a list
procedure Test_Present;
-- Verify that Present properly detects a list
procedure Test_Replace;
-- Verify that Replace properly substitutes old elements with new ones
procedure Test_Size;
-- Verify that Size returns the correct size of a list
-----------------
-- Check_Empty --
-----------------
procedure Check_Empty
(Caller : String;
L : Doubly_Linked_List;
Low_Elem : Integer;
High_Elem : Integer)
is
Len : constant Natural := Size (L);
begin
for Elem in Low_Elem .. High_Elem loop
if Contains (L, Elem) then
Put_Line ("ERROR: " & Caller & ": extra element" & Elem'Img);
end if;
end loop;
if Len /= 0 then
Put_Line ("ERROR: " & Caller & ": wrong length");
Put_Line ("expected: 0");
Put_Line ("got :" & Len'Img);
end if;
end Check_Empty;
----------------------------
-- Check_Locked_Mutations --
----------------------------
procedure Check_Locked_Mutations
(Caller : String;
L : in out Doubly_Linked_List)
is
begin
begin
Append (L, 1);
Put_Line ("ERROR: " & Caller & ": Append: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Append: unexpected exception");
end;
begin
Delete (L, 1);
Put_Line ("ERROR: " & Caller & ": Delete: no exception raised");
exception
when List_Empty =>
null;
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Delete: unexpected exception");
end;
begin
Delete_First (L);
Put_Line ("ERROR: " & Caller & ": Delete_First: no exception raised");
exception
when List_Empty =>
null;
when Iterated =>
null;
when others =>
Put_Line
("ERROR: " & Caller & ": Delete_First: unexpected exception");
end;
begin
Delete_Last (L);
Put_Line ("ERROR: " & Caller & ": Delete_List: no exception raised");
exception
when List_Empty =>
null;
when Iterated =>
null;
when others =>
Put_Line
("ERROR: " & Caller & ": Delete_Last: unexpected exception");
end;
begin
Destroy (L);
Put_Line ("ERROR: " & Caller & ": Destroy: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Destroy: unexpected exception");
end;
begin
Insert_After (L, 1, 2);
Put_Line ("ERROR: " & Caller & ": Insert_After: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line
("ERROR: " & Caller & ": Insert_After: unexpected exception");
end;
begin
Insert_Before (L, 1, 2);
Put_Line
("ERROR: " & Caller & ": Insert_Before: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line
("ERROR: " & Caller & ": Insert_Before: unexpected exception");
end;
begin
Prepend (L, 1);
Put_Line ("ERROR: " & Caller & ": Prepend: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Prepend: unexpected exception");
end;
begin
Replace (L, 1, 2);
Put_Line ("ERROR: " & Caller & ": Replace: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Replace: unexpected exception");
end;
end Check_Locked_Mutations;
-------------------
-- Check_Present --
-------------------
procedure Check_Present
(Caller : String;
L : Doubly_Linked_List;
Low_Elem : Integer;
High_Elem : Integer)
is
Elem : Integer;
Iter : Iterator;
begin
Iter := Iterate (L);
for Exp_Elem in Low_Elem .. High_Elem loop
Next (Iter, Elem);
if Elem /= Exp_Elem then
Put_Line ("ERROR: " & Caller & ": Check_Present: wrong element");
Put_Line ("expected:" & Exp_Elem'Img);
Put_Line ("got :" & Elem'Img);
end if;
end loop;
-- At this point all elements should have been accounted for. Check for
-- extra elements.
while Has_Next (Iter) loop
Next (Iter, Elem);
Put_Line
("ERROR: " & Caller & ": Check_Present: extra element" & Elem'Img);
end loop;
exception
when Iterator_Exhausted =>
Put_Line
("ERROR: "
& Caller
& "Check_Present: incorrect number of elements");
end Check_Present;
------------------------------
-- Check_Unlocked_Mutations --
------------------------------
procedure Check_Unlocked_Mutations
(Caller : String;
L : in out Doubly_Linked_List)
is
begin
begin
Append (L, 1);
Append (L, 2);
Append (L, 3);
exception
when others =>
Put_Line ("ERROR: " & Caller & ": Append: unexpected exception");
end;
begin
Delete (L, 1);
exception
when others =>
Put_Line ("ERROR: " & Caller & ": Delete: unexpected exception");
end;
begin
Delete_First (L);
exception
when others =>
Put_Line
("ERROR: " & Caller & ": Delete_First: unexpected exception");
end;
begin
Delete_Last (L);
exception
when others =>
Put_Line
("ERROR: " & Caller & ": Delete_Last: unexpected exception");
end;
begin
Insert_After (L, 2, 3);
exception
when others =>
Put_Line
("ERROR: " & Caller & ": Insert_After: unexpected exception");
end;
begin
Insert_Before (L, 2, 1);
exception
when others =>
Put_Line
("ERROR: " & Caller & ": Insert_Before: unexpected exception");
end;
begin
Prepend (L, 0);
exception
when others =>
Put_Line ("ERROR: " & Caller & ": Prepend: unexpected exception");
end;
begin
Replace (L, 3, 4);
exception
when others =>
Put_Line ("ERROR: " & Caller & ": Replace: unexpected exception");
end;
end Check_Unlocked_Mutations;
--------------------------
-- Populate_With_Append --
--------------------------
procedure Populate_With_Append
(L : Doubly_Linked_List;
Low_Elem : Integer;
High_Elem : Integer)
is
begin
for Elem in Low_Elem .. High_Elem loop
Append (L, Elem);
end loop;
end Populate_With_Append;
-----------------
-- Test_Append --
-----------------
procedure Test_Append is
L : Doubly_Linked_List := Create;
begin
Append (L, 1);
Append (L, 2);
Append (L, 3);
Append (L, 4);
Append (L, 5);
Check_Present
(Caller => "Test_Append",
L => L,
Low_Elem => 1,
High_Elem => 5);
Destroy (L);
end Test_Append;
-------------------
-- Test_Contains --
-------------------
procedure Test_Contains
(Low_Elem : Integer;
High_Elem : Integer)
is
Low_Bogus : constant Integer := Low_Elem - 1;
High_Bogus : constant Integer := High_Elem + 1;
L : Doubly_Linked_List := Create;
begin
Populate_With_Append (L, Low_Elem, High_Elem);
-- Ensure that the elements are contained in the list
for Elem in Low_Elem .. High_Elem loop
if not Contains (L, Elem) then
Put_Line
("ERROR: Test_Contains: element" & Elem'Img & " not in list");
end if;
end loop;
-- Ensure that arbitrary elements which were not inserted in the list
-- are not contained in the list.
if Contains (L, Low_Bogus) then
Put_Line
("ERROR: Test_Contains: element" & Low_Bogus'Img & " in list");
end if;
if Contains (L, High_Bogus) then
Put_Line
("ERROR: Test_Contains: element" & High_Bogus'Img & " in list");
end if;
Destroy (L);
end Test_Contains;
-----------------
-- Test_Create --
-----------------
procedure Test_Create is
Count : Natural;
Flag : Boolean;
Iter : Iterator;
L : Doubly_Linked_List;
Val : Integer;
begin
-- Ensure that every routine defined in the API fails on a list which
-- has not been created yet.
begin
Append (L, 1);
Put_Line ("ERROR: Test_Create: Append: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Append: unexpected exception");
end;
begin
Flag := Contains (L, 1);
Put_Line ("ERROR: Test_Create: Contains: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Contains: unexpected exception");
end;
begin
Delete (L, 1);
Put_Line ("ERROR: Test_Create: Delete: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Delete: unexpected exception");
end;
begin
Delete_First (L);
Put_Line ("ERROR: Test_Create: Delete_First: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line
("ERROR: Test_Create: Delete_First: unexpected exception");
end;
begin
Delete_Last (L);
Put_Line ("ERROR: Test_Create: Delete_Last: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Delete_Last: unexpected exception");
end;
begin
Val := First (L);
Put_Line ("ERROR: Test_Create: First: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: First: unexpected exception");
end;
begin
Insert_After (L, 1, 2);
Put_Line ("ERROR: Test_Create: Insert_After: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line
("ERROR: Test_Create: Insert_After: unexpected exception");
end;
begin
Insert_Before (L, 1, 2);
Put_Line ("ERROR: Test_Create: Insert_Before: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line
("ERROR: Test_Create: Insert_Before: unexpected exception");
end;
begin
Flag := Is_Empty (L);
Put_Line ("ERROR: Test_Create: Is_Empty: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Is_Empty: unexpected exception");
end;
begin
Iter := Iterate (L);
Put_Line ("ERROR: Test_Create: Iterate: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Iterate: unexpected exception");
end;
begin
Val := Last (L);
Put_Line ("ERROR: Test_Create: Last: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Last: unexpected exception");
end;
begin
Prepend (L, 1);
Put_Line ("ERROR: Test_Create: Prepend: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Prepend: unexpected exception");
end;
begin
Replace (L, 1, 2);
Put_Line ("ERROR: Test_Create: Replace: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Replace: unexpected exception");
end;
begin
Count := Size (L);
Put_Line ("ERROR: Test_Create: Size: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Size: unexpected exception");
end;
end Test_Create;
-----------------
-- Test_Delete --
-----------------
procedure Test_Delete
(Low_Elem : Integer;
High_Elem : Integer)
is
L : Doubly_Linked_List := Create;
begin
Populate_With_Append (L, Low_Elem, High_Elem);
-- Delete the first element, which is technically the head
Delete (L, Low_Elem);
-- Ensure that all remaining elements except for the head are present in
-- the list.
Check_Present
(Caller => "Test_Delete",
L => L,
Low_Elem => Low_Elem + 1,
High_Elem => High_Elem);
-- Delete the last element, which is technically the tail
Delete (L, High_Elem);
-- Ensure that all remaining elements except for the head and tail are
-- present in the list.
Check_Present
(Caller => "Test_Delete",
L => L,
Low_Elem => Low_Elem + 1,
High_Elem => High_Elem - 1);
-- Delete all even elements
for Elem in Low_Elem + 1 .. High_Elem - 1 loop
if Elem mod 2 = 0 then
Delete (L, Elem);
end if;
end loop;
-- Ensure that all remaining elements except the head, tail, and even
-- elements are present in the list.
for Elem in Low_Elem + 1 .. High_Elem - 1 loop
if Elem mod 2 /= 0 and then not Contains (L, Elem) then
Put_Line ("ERROR: Test_Delete: missing element" & Elem'Img);
end if;
end loop;
-- Delete all odd elements
for Elem in Low_Elem + 1 .. High_Elem - 1 loop
if Elem mod 2 /= 0 then
Delete (L, Elem);
end if;
end loop;
-- At this point the list should be completely empty
Check_Empty
(Caller => "Test_Delete",
L => L,
Low_Elem => Low_Elem,
High_Elem => High_Elem);
-- Try to delete an element. This operation should raise List_Empty.
begin
Delete (L, Low_Elem);
Put_Line ("ERROR: Test_Delete: List_Empty not raised");
exception
when List_Empty =>
null;
when others =>
Put_Line ("ERROR: Test_Delete: unexpected exception");
end;
Destroy (L);
end Test_Delete;
-----------------------
-- Test_Delete_First --
-----------------------
procedure Test_Delete_First
(Low_Elem : Integer;
High_Elem : Integer)
is
L : Doubly_Linked_List := Create;
begin
Populate_With_Append (L, Low_Elem, High_Elem);
-- Delete the head of the list, and verify that the remaining elements
-- are still present in the list.
for Elem in Low_Elem .. High_Elem loop
Delete_First (L);
Check_Present
(Caller => "Test_Delete_First",
L => L,
Low_Elem => Elem + 1,
High_Elem => High_Elem);
end loop;
-- At this point the list should be completely empty
Check_Empty
(Caller => "Test_Delete_First",
L => L,
Low_Elem => Low_Elem,
High_Elem => High_Elem);
-- Try to delete an element. This operation should raise List_Empty.
begin
Delete_First (L);
Put_Line ("ERROR: Test_Delete_First: List_Empty not raised");
exception
when List_Empty =>
null;
when others =>
Put_Line ("ERROR: Test_Delete_First: unexpected exception");
end;
Destroy (L);
end Test_Delete_First;
----------------------
-- Test_Delete_Last --
----------------------
procedure Test_Delete_Last
(Low_Elem : Integer;
High_Elem : Integer)
is
L : Doubly_Linked_List := Create;
begin
Populate_With_Append (L, Low_Elem, High_Elem);
-- Delete the tail of the list, and verify that the remaining elements
-- are still present in the list.
for Elem in reverse Low_Elem .. High_Elem loop
Delete_Last (L);
Check_Present
(Caller => "Test_Delete_Last",
L => L,
Low_Elem => Low_Elem,
High_Elem => Elem - 1);
end loop;
-- At this point the list should be completely empty
Check_Empty
(Caller => "Test_Delete_Last",
L => L,
Low_Elem => Low_Elem,
High_Elem => High_Elem);
-- Try to delete an element. This operation should raise List_Empty.
begin
Delete_Last (L);
Put_Line ("ERROR: Test_Delete_Last: List_Empty not raised");
exception
when List_Empty =>
null;
when others =>
Put_Line ("ERROR: Test_Delete_First: unexpected exception");
end;
Destroy (L);
end Test_Delete_Last;
----------------
-- Test_First --
----------------
procedure Test_First is
Elem : Integer;
L : Doubly_Linked_List := Create;
begin
-- Try to obtain the head. This operation should raise List_Empty.
begin
Elem := First (L);
Put_Line ("ERROR: Test_First: List_Empty not raised");
exception
when List_Empty =>
null;
when others =>
Put_Line ("ERROR: Test_First: unexpected exception");
end;
Populate_With_Append (L, 1, 2);
-- Obtain the head
Elem := First (L);
if Elem /= 1 then
Put_Line ("ERROR: Test_First: wrong element");
Put_Line ("expected: 1");
Put_Line ("got :" & Elem'Img);
end if;
Destroy (L);
end Test_First;
-----------------------
-- Test_Insert_After --
-----------------------
procedure Test_Insert_After is
L : Doubly_Linked_List := Create;
begin
-- Try to insert after a non-inserted element, in an empty list
Insert_After (L, 1, 2);
-- At this point the list should be completely empty
Check_Empty
(Caller => "Test_Insert_After",
L => L,
Low_Elem => 0,
High_Elem => -1);
Append (L, 1); -- 1
Insert_After (L, 1, 3); -- 1, 3
Insert_After (L, 1, 2); -- 1, 2, 3
Insert_After (L, 3, 4); -- 1, 2, 3, 4
-- Try to insert after a non-inserted element, in a full list
Insert_After (L, 10, 11);
Check_Present
(Caller => "Test_Insert_After",
L => L,
Low_Elem => 1,
High_Elem => 4);
Destroy (L);
end Test_Insert_After;
------------------------
-- Test_Insert_Before --
------------------------
procedure Test_Insert_Before is
L : Doubly_Linked_List := Create;
begin
-- Try to insert before a non-inserted element, in an empty list
Insert_Before (L, 1, 2);
-- At this point the list should be completely empty
Check_Empty
(Caller => "Test_Insert_Before",
L => L,
Low_Elem => 0,
High_Elem => -1);
Append (L, 4); -- 4
Insert_Before (L, 4, 2); -- 2, 4
Insert_Before (L, 2, 1); -- 1, 2, 4
Insert_Before (L, 4, 3); -- 1, 2, 3, 4
-- Try to insert before a non-inserted element, in a full list
Insert_Before (L, 10, 11);
Check_Present
(Caller => "Test_Insert_Before",
L => L,
Low_Elem => 1,
High_Elem => 4);
Destroy (L);
end Test_Insert_Before;
-------------------
-- Test_Is_Empty --
-------------------
procedure Test_Is_Empty is
L : Doubly_Linked_List := Create;
begin
if not Is_Empty (L) then
Put_Line ("ERROR: Test_Is_Empty: list is not empty");
end if;
Append (L, 1);
if Is_Empty (L) then
Put_Line ("ERROR: Test_Is_Empty: list is empty");
end if;
Delete_First (L);
if not Is_Empty (L) then
Put_Line ("ERROR: Test_Is_Empty: list is not empty");
end if;
Destroy (L);
end Test_Is_Empty;
------------------
-- Test_Iterate --
------------------
procedure Test_Iterate is
Elem : Integer;
Iter_1 : Iterator;
Iter_2 : Iterator;
L : Doubly_Linked_List := Create;
begin
Populate_With_Append (L, 1, 5);
-- Obtain an iterator. This action must lock all mutation operations of
-- the list.
Iter_1 := Iterate (L);
-- Ensure that every mutation routine defined in the API fails on a list
-- with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate",
L => L);
-- Obtain another iterator
Iter_2 := Iterate (L);
-- Ensure that every mutation is still locked
Check_Locked_Mutations
(Caller => "Test_Iterate",
L => L);
-- Exhaust the first itertor
while Has_Next (Iter_1) loop
Next (Iter_1, Elem);
end loop;
-- Ensure that every mutation is still locked
Check_Locked_Mutations
(Caller => "Test_Iterate",
L => L);
-- Exhaust the second itertor
while Has_Next (Iter_2) loop
Next (Iter_2, Elem);
end loop;
-- Ensure that all mutation operations are once again callable
Check_Unlocked_Mutations
(Caller => "Test_Iterate",
L => L);
Destroy (L);
end Test_Iterate;
------------------------
-- Test_Iterate_Empty --
------------------------
procedure Test_Iterate_Empty is
Elem : Integer;
Iter : Iterator;
L : Doubly_Linked_List := Create;
begin
-- Obtain an iterator. This action must lock all mutation operations of
-- the list.
Iter := Iterate (L);
-- Ensure that every mutation routine defined in the API fails on a list
-- with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate_Empty",
L => L);
-- Attempt to iterate over the elements
while Has_Next (Iter) loop
Next (Iter, Elem);
Put_Line
("ERROR: Test_Iterate_Empty: element" & Elem'Img & " exists");
end loop;
-- Ensure that all mutation operations are once again callable
Check_Unlocked_Mutations
(Caller => "Test_Iterate_Empty",
L => L);
Destroy (L);
end Test_Iterate_Empty;
-------------------------
-- Test_Iterate_Forced --
-------------------------
procedure Test_Iterate_Forced
(Low_Elem : Integer;
High_Elem : Integer)
is
Elem : Integer;
Iter : Iterator;
L : Doubly_Linked_List := Create;
begin
Populate_With_Append (L, Low_Elem, High_Elem);
-- Obtain an iterator. This action must lock all mutation operations of
-- the list.
Iter := Iterate (L);
-- Ensure that every mutation routine defined in the API fails on a list
-- with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate_Forced",
L => L);
-- Forcibly advance the iterator until it raises an exception
begin
for Guard in Low_Elem .. High_Elem + 1 loop
Next (Iter, Elem);
end loop;
Put_Line
("ERROR: Test_Iterate_Forced: Iterator_Exhausted not raised");
exception
when Iterator_Exhausted =>
null;
when others =>
Put_Line ("ERROR: Test_Iterate_Forced: unexpected exception");
end;
-- Ensure that all mutation operations are once again callable
Check_Unlocked_Mutations
(Caller => "Test_Iterate_Forced",
L => L);
Destroy (L);
end Test_Iterate_Forced;
---------------
-- Test_Last --
---------------
procedure Test_Last is
Elem : Integer;
L : Doubly_Linked_List := Create;
begin
-- Try to obtain the tail. This operation should raise List_Empty.
begin
Elem := First (L);
Put_Line ("ERROR: Test_Last: List_Empty not raised");
exception
when List_Empty =>
null;
when others =>
Put_Line ("ERROR: Test_Last: unexpected exception");
end;
Populate_With_Append (L, 1, 2);
-- Obtain the tail
Elem := Last (L);
if Elem /= 2 then
Put_Line ("ERROR: Test_Last: wrong element");
Put_Line ("expected: 2");
Put_Line ("got :" & Elem'Img);
end if;
Destroy (L);
end Test_Last;
------------------
-- Test_Prepend --
------------------
procedure Test_Prepend is
L : Doubly_Linked_List := Create;
begin
Prepend (L, 5);
Prepend (L, 4);
Prepend (L, 3);
Prepend (L, 2);
Prepend (L, 1);
Check_Present
(Caller => "Test_Prepend",
L => L,
Low_Elem => 1,
High_Elem => 5);
Destroy (L);
end Test_Prepend;
------------------
-- Test_Present --
------------------
procedure Test_Present is
L : Doubly_Linked_List;
begin
if Present (L) then
Put_Line ("ERROR: Test_Present: list does not exist");
end if;
L := Create;
if not Present (L) then
Put_Line ("ERROR: Test_Present: list exists");
end if;
Destroy (L);
end Test_Present;
------------------
-- Test_Replace --
------------------
procedure Test_Replace is
L : Doubly_Linked_List := Create;
begin
Populate_With_Append (L, 1, 5);
Replace (L, 3, 8);
Replace (L, 1, 6);
Replace (L, 4, 9);
Replace (L, 5, 10);
Replace (L, 2, 7);
Replace (L, 11, 12);
Check_Present
(Caller => "Test_Replace",
L => L,
Low_Elem => 6,
High_Elem => 10);
Destroy (L);
end Test_Replace;
---------------
-- Test_Size --
---------------
procedure Test_Size is
L : Doubly_Linked_List := Create;
S : Natural;
begin
S := Size (L);
if S /= 0 then
Put_Line ("ERROR: Test_Size: wrong size");
Put_Line ("expected: 0");
Put_Line ("got :" & S'Img);
end if;
Populate_With_Append (L, 1, 2);
S := Size (L);
if S /= 2 then
Put_Line ("ERROR: Test_Size: wrong size");
Put_Line ("expected: 2");
Put_Line ("got :" & S'Img);
end if;
Populate_With_Append (L, 3, 6);
S := Size (L);
if S /= 6 then
Put_Line ("ERROR: Test_Size: wrong size");
Put_Line ("expected: 6");
Put_Line ("got :" & S'Img);
end if;
Destroy (L);
end Test_Size;
-- Start of processing for Operations
begin
Test_Append;
Test_Contains
(Low_Elem => 1,
High_Elem => 5);
Test_Create;
Test_Delete
(Low_Elem => 1,
High_Elem => 10);
Test_Delete_First
(Low_Elem => 1,
High_Elem => 5);
Test_Delete_Last
(Low_Elem => 1,
High_Elem => 5);
Test_First;
Test_Insert_After;
Test_Insert_Before;
Test_Is_Empty;
Test_Iterate;
Test_Iterate_Empty;
Test_Iterate_Forced
(Low_Elem => 1,
High_Elem => 5);
Test_Last;
Test_Prepend;
Test_Present;
Test_Replace;
Test_Size;
end Operations;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q operations.adb -largs -lgmem
$ ./operations
$ gnatmem operations > leaks.txt
$ grep -c "non freed allocations" leaks.txt
0
2019-07-01 Hristian Kirtchev <kirtchev@adacore.com>
gcc/ada/
* libgnat/g-lists.adb: Use type Doubly_Linked_List rather than
Instance in various routines.
* libgnat/g-lists.ads: Change type Instance to
Doubly_Linked_List. Update various routines that mention the
type.
gcc/testsuite/
* gnat.dg/linkedlist.adb: Update.
From-SVN: r272861
Hristian Kirtchev [Mon, 1 Jul 2019 13:34:55 +0000 (13:34 +0000)]
[Ada] Clean up of GNAT.Dynamic_HTables
------------
-- Source --
------------
-- operations.adb
with Ada.Text_IO; use Ada.Text_IO;
with GNAT; use GNAT;
with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
procedure Operations is
procedure Destroy (Val : in out Integer) is null;
function Hash (Key : Integer) return Bucket_Range_Type;
package DHT is new Dynamic_Hash_Tables
(Key_Type => Integer,
Value_Type => Integer,
No_Value => 0,
Expansion_Threshold => 1.3,
Expansion_Factor => 2,
Compression_Threshold => 0.3,
Compression_Factor => 2,
"=" => "=",
Destroy_Value => Destroy,
Hash => Hash);
use DHT;
function Create_And_Populate
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Positive) return Dynamic_Hash_Table;
-- Create a hash table with initial size Init_Size and populate it with
-- key-value pairs where both keys and values are in the range Low_Key
-- .. High_Key.
procedure Check_Empty
(Caller : String;
T : Dynamic_Hash_Table;
Low_Key : Integer;
High_Key : Integer);
-- Ensure that
--
-- * The key-value pairs count of hash table T is 0.
-- * All values for the keys in range Low_Key .. High_Key are 0.
procedure Check_Keys
(Caller : String;
Iter : in out Iterator;
Low_Key : Integer;
High_Key : Integer);
-- Ensure that iterator Iter visits every key in the range Low_Key ..
-- High_Key exactly once.
procedure Check_Locked_Mutations
(Caller : String;
T : in out Dynamic_Hash_Table);
-- Ensure that all mutation operations of hash table T are locked
procedure Check_Size
(Caller : String;
T : Dynamic_Hash_Table;
Exp_Count : Natural);
-- Ensure that the count of key-value pairs of hash table T matches
-- expected count Exp_Count. Emit an error if this is not the case.
procedure Test_Create (Init_Size : Positive);
-- Verify that all dynamic hash table operations fail on a non-created
-- table of size Init_Size.
procedure Test_Delete_Get_Put_Size
(Low_Key : Integer;
High_Key : Integer;
Exp_Count : Natural;
Init_Size : Positive);
-- Verify that
--
-- * Put properly inserts values in the hash table.
-- * Get properly retrieves all values inserted in the table.
-- * Delete properly deletes values.
-- * The size of the hash table properly reflects the number of key-value
-- pairs.
--
-- Low_Key and High_Key denote the range of keys to be inserted, retrieved,
-- and deleted. Exp_Count is the expected count of key-value pairs n the
-- hash table. Init_Size denotes the initial size of the table.
procedure Test_Iterate
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Positive);
-- Verify that iterators
--
-- * Properly visit each key exactly once.
-- * Mutation operations are properly locked and unlocked during
-- iteration.
--
-- Low_Key and High_Key denote the range of keys to be inserted, retrieved,
-- and deleted. Init_Size denotes the initial size of the table.
procedure Test_Iterate_Empty (Init_Size : Positive);
-- Verify that an iterator over an empty hash table
--
-- * Does not visit any key
-- * Mutation operations are properly locked and unlocked during
-- iteration.
--
-- Init_Size denotes the initial size of the table.
procedure Test_Iterate_Forced
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Positive);
-- Verify that an iterator that is forcefully advanced by just Next
--
-- * Properly visit each key exactly once.
-- * Mutation operations are properly locked and unlocked during
-- iteration.
--
-- Low_Key and High_Key denote the range of keys to be inserted, retrieved,
-- and deleted. Init_Size denotes the initial size of the table.
procedure Test_Replace
(Low_Val : Integer;
High_Val : Integer;
Init_Size : Positive);
-- Verify that Put properly updates the value of a particular key. Low_Val
-- and High_Val denote the range of values to be updated. Init_Size denotes
-- the initial size of the table.
procedure Test_Reset
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Positive);
-- Verify that Reset properly destroy and recreats a hash table. Low_Key
-- and High_Key denote the range of keys to be inserted in the hash table.
-- Init_Size denotes the initial size of the table.
-------------------------
-- Create_And_Populate --
-------------------------
function Create_And_Populate
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Positive) return Dynamic_Hash_Table
is
T : Dynamic_Hash_Table;
begin
T := Create (Init_Size);
for Key in Low_Key .. High_Key loop
Put (T, Key, Key);
end loop;
return T;
end Create_And_Populate;
-----------------
-- Check_Empty --
-----------------
procedure Check_Empty
(Caller : String;
T : Dynamic_Hash_Table;
Low_Key : Integer;
High_Key : Integer)
is
Val : Integer;
begin
Check_Size
(Caller => Caller,
T => T,
Exp_Count => 0);
for Key in Low_Key .. High_Key loop
Val := Get (T, Key);
if Val /= 0 then
Put_Line ("ERROR: " & Caller & ": wrong value");
Put_Line ("expected: 0");
Put_Line ("got :" & Val'Img);
end if;
end loop;
end Check_Empty;
----------------
-- Check_Keys --
----------------
procedure Check_Keys
(Caller : String;
Iter : in out Iterator;
Low_Key : Integer;
High_Key : Integer)
is
type Bit_Vector is array (Low_Key .. High_Key) of Boolean;
pragma Pack (Bit_Vector);
Count : Natural;
Key : Integer;
Seen : Bit_Vector := (others => False);
begin
-- Compute the number of outstanding keys that have to be iterated on
Count := High_Key - Low_Key + 1;
while Has_Next (Iter) loop
Next (Iter, Key);
if Seen (Key) then
Put_Line
("ERROR: " & Caller & ": Check_Keys: duplicate key" & Key'Img);
else
Seen (Key) := True;
Count := Count - 1;
end if;
end loop;
-- In the end, all keys must have been iterated on
if Count /= 0 then
for Key in Seen'Range loop
if not Seen (Key) then
Put_Line
("ERROR: " & Caller & ": Check_Keys: missing key" & Key'Img);
end if;
end loop;
end if;
end Check_Keys;
----------------------------
-- Check_Locked_Mutations --
----------------------------
procedure Check_Locked_Mutations
(Caller : String;
T : in out Dynamic_Hash_Table)
is
begin
begin
Delete (T, 1);
Put_Line ("ERROR: " & Caller & ": Delete: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Delete: unexpected exception");
end;
begin
Destroy (T);
Put_Line ("ERROR: " & Caller & ": Destroy: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Destroy: unexpected exception");
end;
begin
Put (T, 1, 1);
Put_Line ("ERROR: " & Caller & ": Put: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Put: unexpected exception");
end;
begin
Reset (T);
Put_Line ("ERROR: " & Caller & ": Reset: no exception raised");
exception
when Iterated =>
null;
when others =>
Put_Line ("ERROR: " & Caller & ": Reset: unexpected exception");
end;
end Check_Locked_Mutations;
----------------
-- Check_Size --
----------------
procedure Check_Size
(Caller : String;
T : Dynamic_Hash_Table;
Exp_Count : Natural)
is
Count : constant Natural := Size (T);
begin
if Count /= Exp_Count then
Put_Line ("ERROR: " & Caller & ": Size: wrong value");
Put_Line ("expected:" & Exp_Count'Img);
Put_Line ("got :" & Count'Img);
end if;
end Check_Size;
----------
-- Hash --
----------
function Hash (Key : Integer) return Bucket_Range_Type is
begin
return Bucket_Range_Type (Key);
end Hash;
-----------------
-- Test_Create --
-----------------
procedure Test_Create (Init_Size : Positive) is
Count : Natural;
Iter : Iterator;
T : Dynamic_Hash_Table;
Val : Integer;
begin
-- Ensure that every routine defined in the API fails on a hash table
-- which has not been created yet.
begin
Delete (T, 1);
Put_Line ("ERROR: Test_Create: Delete: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Delete: unexpected exception");
end;
begin
Destroy (T);
Put_Line ("ERROR: Test_Create: Destroy: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Destroy: unexpected exception");
end;
begin
Val := Get (T, 1);
Put_Line ("ERROR: Test_Create: Get: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Get: unexpected exception");
end;
begin
Iter := Iterate (T);
Put_Line ("ERROR: Test_Create: Iterate: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Iterate: unexpected exception");
end;
begin
Put (T, 1, 1);
Put_Line ("ERROR: Test_Create: Put: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Put: unexpected exception");
end;
begin
Reset (T);
Put_Line ("ERROR: Test_Create: Reset: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Reset: unexpected exception");
end;
begin
Count := Size (T);
Put_Line ("ERROR: Test_Create: Size: no exception raised");
exception
when Not_Created =>
null;
when others =>
Put_Line ("ERROR: Test_Create: Size: unexpected exception");
end;
-- Test create
T := Create (Init_Size);
-- Clean up the hash table to prevent memory leaks
Destroy (T);
end Test_Create;
------------------------------
-- Test_Delete_Get_Put_Size --
------------------------------
procedure Test_Delete_Get_Put_Size
(Low_Key : Integer;
High_Key : Integer;
Exp_Count : Natural;
Init_Size : Positive)
is
Exp_Val : Integer;
T : Dynamic_Hash_Table;
Val : Integer;
begin
T := Create_And_Populate (Low_Key, High_Key, Init_Size);
-- Ensure that its size matches an expected value
Check_Size
(Caller => "Test_Delete_Get_Put_Size",
T => T,
Exp_Count => Exp_Count);
-- Ensure that every value for the range of keys exists
for Key in Low_Key .. High_Key loop
Val := Get (T, Key);
if Val /= Key then
Put_Line ("ERROR: Test_Delete_Get_Put_Size: Get: wrong value");
Put_Line ("expected:" & Key'Img);
Put_Line ("got :" & Val'Img);
end if;
end loop;
-- Delete values whose keys are divisible by 10
for Key in Low_Key .. High_Key loop
if Key mod 10 = 0 then
Delete (T, Key);
end if;
end loop;
-- Ensure that all values whose keys were not deleted still exist
for Key in Low_Key .. High_Key loop
if Key mod 10 = 0 then
Exp_Val := 0;
else
Exp_Val := Key;
end if;
Val := Get (T, Key);
if Val /= Exp_Val then
Put_Line ("ERROR: Test_Delete_Get_Put_Size: Get: wrong value");
Put_Line ("expected:" & Exp_Val'Img);
Put_Line ("got :" & Val'Img);
end if;
end loop;
-- Delete all values
for Key in Low_Key .. High_Key loop
Delete (T, Key);
end loop;
-- Ensure that the hash table is empty
Check_Empty
(Caller => "Test_Delete_Get_Put_Size",
T => T,
Low_Key => Low_Key,
High_Key => High_Key);
-- Clean up the hash table to prevent memory leaks
Destroy (T);
end Test_Delete_Get_Put_Size;
------------------
-- Test_Iterate --
------------------
procedure Test_Iterate
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Positive)
is
Iter_1 : Iterator;
Iter_2 : Iterator;
T : Dynamic_Hash_Table;
begin
T := Create_And_Populate (Low_Key, High_Key, Init_Size);
-- Obtain an iterator. This action must lock all mutation operations of
-- the hash table.
Iter_1 := Iterate (T);
-- Ensure that every mutation routine defined in the API fails on a hash
-- table with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate",
T => T);
-- Obtain another iterator
Iter_2 := Iterate (T);
-- Ensure that every mutation is still locked
Check_Locked_Mutations
(Caller => "Test_Iterate",
T => T);
-- Ensure that all keys are iterable. Note that this does not unlock the
-- mutation operations of the hash table because Iter_2 is not exhausted
-- yet.
Check_Keys
(Caller => "Test_Iterate",
Iter => Iter_1,
Low_Key => Low_Key,
High_Key => High_Key);
Check_Locked_Mutations
(Caller => "Test_Iterate",
T => T);
-- Ensure that all keys are iterable. This action unlocks all mutation
-- operations of the hash table because all outstanding iterators have
-- been exhausted.
Check_Keys
(Caller => "Test_Iterate",
Iter => Iter_2,
Low_Key => Low_Key,
High_Key => High_Key);
-- Ensure that all mutation operations are once again callable
Delete (T, Low_Key);
Put (T, Low_Key, Low_Key);
Reset (T);
-- Clean up the hash table to prevent memory leaks
Destroy (T);
end Test_Iterate;
------------------------
-- Test_Iterate_Empty --
------------------------
procedure Test_Iterate_Empty (Init_Size : Positive) is
Iter : Iterator;
Key : Integer;
T : Dynamic_Hash_Table;
begin
T := Create_And_Populate (0, -1, Init_Size);
-- Obtain an iterator. This action must lock all mutation operations of
-- the hash table.
Iter := Iterate (T);
-- Ensure that every mutation routine defined in the API fails on a hash
-- table with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate_Empty",
T => T);
-- Attempt to iterate over the keys
while Has_Next (Iter) loop
Next (Iter, Key);
Put_Line ("ERROR: Test_Iterate_Empty: key" & Key'Img & " exists");
end loop;
-- Ensure that all mutation operations are once again callable
Delete (T, 1);
Put (T, 1, 1);
Reset (T);
-- Clean up the hash table to prevent memory leaks
Destroy (T);
end Test_Iterate_Empty;
-------------------------
-- Test_Iterate_Forced --
-------------------------
procedure Test_Iterate_Forced
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Positive)
is
Iter : Iterator;
Key : Integer;
T : Dynamic_Hash_Table;
begin
T := Create_And_Populate (Low_Key, High_Key, Init_Size);
-- Obtain an iterator. This action must lock all mutation operations of
-- the hash table.
Iter := Iterate (T);
-- Ensure that every mutation routine defined in the API fails on a hash
-- table with at least one outstanding iterator.
Check_Locked_Mutations
(Caller => "Test_Iterate_Forced",
T => T);
-- Forcibly advance the iterator until it raises an exception
begin
for Guard in Low_Key .. High_Key + 1 loop
Next (Iter, Key);
end loop;
Put_Line
("ERROR: Test_Iterate_Forced: Iterator_Exhausted not raised");
exception
when Iterator_Exhausted =>
null;
when others =>
Put_Line ("ERROR: Test_Iterate_Forced: unexpected exception");
end;
-- Ensure that all mutation operations are once again callable
Delete (T, Low_Key);
Put (T, Low_Key, Low_Key);
Reset (T);
-- Clean up the hash table to prevent memory leaks
Destroy (T);
end Test_Iterate_Forced;
------------------
-- Test_Replace --
------------------
procedure Test_Replace
(Low_Val : Integer;
High_Val : Integer;
Init_Size : Positive)
is
Key : constant Integer := 1;
T : Dynamic_Hash_Table;
Val : Integer;
begin
T := Create (Init_Size);
-- Ensure the Put properly updates values with the same key
for Exp_Val in Low_Val .. High_Val loop
Put (T, Key, Exp_Val);
Val := Get (T, Key);
if Val /= Exp_Val then
Put_Line ("ERROR: Test_Replace: Get: wrong value");
Put_Line ("expected:" & Exp_Val'Img);
Put_Line ("got :" & Val'Img);
end if;
end loop;
-- Clean up the hash table to prevent memory leaks
Destroy (T);
end Test_Replace;
----------------
-- Test_Reset --
----------------
procedure Test_Reset
(Low_Key : Integer;
High_Key : Integer;
Init_Size : Positive)
is
T : Dynamic_Hash_Table;
begin
T := Create_And_Populate (Low_Key, High_Key, Init_Size);
-- Reset the contents of the hash table
Reset (T);
-- Ensure that the hash table is empty
Check_Empty
(Caller => "Test_Reset",
T => T,
Low_Key => Low_Key,
High_Key => High_Key);
-- Clean up the hash table to prevent memory leaks
Destroy (T);
end Test_Reset;
-- Start of processing for Operations
begin
Test_Create (Init_Size => 1);
Test_Create (Init_Size => 100);
Test_Delete_Get_Put_Size
(Low_Key => 1,
High_Key => 1,
Exp_Count => 1,
Init_Size => 1);
Test_Delete_Get_Put_Size
(Low_Key => 1,
High_Key => 1000,
Exp_Count => 1000,
Init_Size => 32);
Test_Iterate
(Low_Key => 1,
High_Key => 32,
Init_Size => 32);
Test_Iterate_Empty (Init_Size => 32);
Test_Iterate_Forced
(Low_Key => 1,
High_Key => 32,
Init_Size => 32);
Test_Replace
(Low_Val => 1,
High_Val => 10,
Init_Size => 32);
Test_Reset
(Low_Key => 1,
High_Key => 1000,
Init_Size => 100);
end Operations;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q operations.adb -largs -lgmem
$ ./operations
$ gnatmem operations > leaks.txt
$ grep -c "non freed allocations" leaks.txt
0
2019-07-01 Hristian Kirtchev <kirtchev@adacore.com>
gcc/ada/
* libgnat/g-dynhta.adb: Use type Dynamic_Hash_Table rather than
Instance in various routines.
* libgnat/g-dynhta.ads: Change type Instance to
Dynamic_Hash_Table. Update various routines that mention the
type.
gcc/testsuite/
* gnat.dg/dynhash.adb, gnat.dg/dynhash1.adb: Update.
From-SVN: r272860
projects / gcc.git / log