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;
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
* 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.
[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.
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.
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.
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.
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.
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.
* 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.
* 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.
[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;
$ 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.
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.
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.
* 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.
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.
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.
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.
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.
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.
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.
[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.
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.
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.
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.
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.
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.
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>
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.
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.
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.
[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.
* 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.
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.
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).
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.
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.
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.
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.
[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.
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.
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.
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
-- 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;
* 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.
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
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;
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;
-- 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;
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
* 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.
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
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;
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;
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;
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;
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
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;
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;
* 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.
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.
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;
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);
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;
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
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;
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_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.
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
* 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.
Javier Miranda [Mon, 1 Jul 2019 13:34:45 +0000 (13:34 +0000)]
[Ada] Disable expansion of 'Min/'Max of floating point types
2019-07-01 Javier Miranda <miranda@adacore.com>
gcc/ada/
* exp_attr.adb (Expand_Min_Max_Attribute): Disable expansion of
'Min/'Max on integer, enumeration, fixed point and floating
point types since the CCG backend now provides in file
standard.h routines to support it.
package VS is new Membership_Set
(Element_Type => Vertex_Id,
"=" => "=",
Hash => Hash_Vertex);
-----------------------
-- Local subprograms --
-----------------------
procedure Check_Belongs_To_Component
(R : String;
G : Instance;
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 : Instance;
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 : Instance;
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 : Instance;
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 : Instance;
E : Edge_Id);
-- Verify that graph G contains edge E. R is the calling routine.
procedure Check_Has_Vertex
(R : String;
G : Instance;
V : Vertex_Id);
-- Verify that graph G contains vertex V. R is the calling routine.
procedure Check_No_Component
(R : String;
G : Instance;
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 : Instance;
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 : Instance;
E : Edge_Id);
-- Verify that graph G does not contain edge E. R is the calling routine.
procedure Check_No_Vertex
(R : String;
G : Instance;
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 : Instance;
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 : Instance;
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 : Instance;
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 : Instance;
V : Vertex_Id;
Set : ES.Instance);
-- 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 : Instance;
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 : Instance;
Comp : Component_Id;
Set : VS.Instance);
-- 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 Instance;
-- 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.
procedure Check_Belongs_To_Some_Component
(R : String;
G : Instance;
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;
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;
procedure Check_Has_Component
(R : String;
G : Instance;
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;
procedure Check_Has_Edge
(R : String;
G : Instance;
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;
procedure Check_Has_Vertex
(R : String;
G : Instance;
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;
procedure Check_No_Component
(R : String;
G : Instance;
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 : Instance;
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;
procedure Check_No_Edge
(R : String;
G : Instance;
E : Edge_Id)
is
begin
if Contains_Edge (G, E) then
Error (R, "graph contains edge " & E'Img);
end if;
end Check_No_Edge;
procedure Check_No_Vertex
(R : String;
G : Instance;
V : Vertex_Id)
is
begin
if Contains_Vertex (G, V) then
Error (R, "graph contains vertex " & V'Img);
end if;
end Check_No_Vertex;
procedure Check_Number_Of_Components
(R : String;
G : Instance;
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;
procedure Check_Number_Of_Edges
(R : String;
G : Instance;
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;
procedure Check_Number_Of_Vertices
(R : String;
G : Instance;
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;
-- 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;
* impunit.adb: Add GNAT.Graphs to list Non_Imp_File_Names_95.
* Makefile.rtl, gcc-interface/Make-lang.in: Register unit
GNAT.Graphs.
* libgnat/g-dynhta.adb: Various minor cleanups (use Present
rather than direct comparisons).
(Delete): Reimplement to use Delete_Node.
(Delete_Node): New routine.
(Destroy_Bucket): Invoke the provided destructor.
(Present): New routines.
* libgnat/g-dynhta.ads: Add new generic formal Destroy_Value.
Use better names for the components of iterators.
* libgnat/g-graphs.adb, libgnat/g-graphs.ads: New unit.
* libgnat/g-lists.adb: Various minor cleanups (use Present
rather than direct comparisons).
(Delete_Node): Invoke the provided destructor.
(Present): New routine.
* libgnat/g-lists.ads: Add new generic formal Destroy_Element.
Use better names for the components of iterators.
(Present): New routine.
* libgnat/g-sets.adb, libgnat/g-sets.ads (Destroy, Preset,
Reset): New routines.
Ed Schonberg [Mon, 1 Jul 2019 13:34:30 +0000 (13:34 +0000)]
[Ada] Compiler abort on use of Invalid_Value on numeric positive subtype
Invalid_Value in most cases uses a predefined numeric value from a
built-in table, but if the type does not include zero in its range, the
literal 0 is used instead. In that case the value (produced by a call to
Get_Simple_Init_Val) must be resolved for proper type information.
The following must compile quietly:
gnatmake -q main
----
with Problems; use Problems;
with Text_IO; use Text_IO;
function P1 return Integer;
function P2 return Long_Integer;
-- Max. number of prime factors a number can have is log_2 N
-- For N = 600851475143, this is ~ 40
-- type P3_Factors is array (1 .. 40) of Long_Integer;
function P3 return Long_Integer;
type P4_Palindrome is range 100*100 .. 999*999;
function P4 return P4_Palindrome;
end Problems;
----
package body Problems is
function P1 return Integer is separate;
function P2 return Long_Integer is separate;
function P3 return Long_Integer is separate;
function P4 return P4_Palindrome is separate;
end Problems;
----
separate(Problems)
function P1 return Integer is
Sum : Integer range 0 .. 500_500 := 0;
begin
for I in Integer range 1 .. 1000 - 1 loop
if I mod 3 = 0 or I mod 5 = 0 then
Sum := Sum + I;
end if;
end loop;
return Sum;
end P1;
--
separate(Problems)
function P2 return Long_Integer is
subtype Total is Long_Integer range 0 .. 8_000002e6 ;
subtype Elem is Total range 0 .. 4e7 ;
Sum : Total := 0;
a, b, c : Elem;
begin
a := 1;
b := 2;
loop
if b mod 2 = 0 then
Sum := Sum + b;
end if;
c := b;
b := a + b;
a := c;
exit when b >= 4e6;
end loop;
return Sum;
end P2;
--
with Text_IO; use Text_IO;
with Ada.Numerics.Elementary_Functions; use Ada.Numerics.Elementary_Functions;
separate(Problems)
function P3 return Long_Integer is
while Dividend > 1 loop
Quotient := Dividend / Factor;
if Dividend mod Factor = 0 then
GPF := Factor;
Dividend := Quotient;
else
if Factor >= Quotient then
GPF := Dividend;
exit;
end if;
Factor := Factor + 1;
end if;
end loop;
return GPF;
end P3;
----
with Text_IO; use Text_IO;
separate(Problems)
function P4 return P4_Palindrome is
type TripleDigit is range 100 .. 999;
a, b: TripleDigit := TripleDigit'First;
function Is_Palindrome (X : in P4_Palindrome) return Boolean is
type Int_Digit is range 0 .. 9;
type Int_Digits is array (1 .. 6) of Int_Digit;
type Digit_Extractor is range 0 .. P4_Palindrome'Last;
Y : Digit_Extractor := Digit_Extractor (X);
X_Digits : Int_Digits;
begin
for I in reverse X_Digits'Range loop
X_Digits (I) := Int_Digit (Y mod 10);
Y := Y / 10;
end loop;
return
(X_Digits (1) = X_Digits (6) and X_Digits (2) = X_Digits (5) and
X_Digits (3) = X_Digits (4)) or
(X_Digits (2) = X_Digits (6) and X_Digits (3) = X_Digits (5) and
X_Digits(1) = 0);
end Is_Palindrome;
begin
for a in TripleDigit'Range loop
for b in TripleDigit'Range loop
c := P4_Palindrome (a * b);
if Is_Palindrome (c) then
if Max_Palindrome'Valid or else c > Max_Palindrome then
Max_Palindrome := c;
end if;
end if;
end loop;
end loop;
return Max_Palindrome;
end;
2019-07-01 Ed Schonberg <schonberg@adacore.com>
gcc/ada/
* exp_attr.adb (Expand_Attribute_Reference, case Invalid_Value):
Resolve result of call to Get_Simple_Init_Val, which may be a
conversion of a literal.
[Ada] Crash due to missing freeze nodes in transient scope
The following patch updates the freezing of expressions to insert the
generated freeze nodes prior to the expression that produced them when
the context is a transient scope within a type initialization procedure.
This ensures that the nodes are properly interleaved with respect to the
constructs that generated them.
* freeze.adb (Freeze_Expression): Remove the horrible useless
name hiding of N. Insert the freeze nodes generated by the
expression prior to the expression when the nearest enclosing
scope is transient.
gcc/testsuite/
* gnat.dg/freezing1.adb, gnat.dg/freezing1.ads,
gnat.dg/freezing1_pack.adb, gnat.dg/freezing1_pack.ads: New
testcase.
projects / thirdparty / gcc.git / log
