- 01 Jul, 2019 40 commits
-
-
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
Segher Boessenkool committed -
From-SVN: r272885
Andreas Krebbel committed -
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
Andreas Krebbel committed -
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
Ed Schonberg committed -
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
Hristian Kirtchev committed -
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
Ed Schonberg committed -
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
Eric Botcazou committed -
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
Ed Schonberg committed -
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
Yannick Moy committed -
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
Dmitriy Anisimkov committed -
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
Ed Schonberg committed -
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 committed -
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
Piotr Trojanek committed -
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
Ed Schonberg committed -
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
Richard Biener committed -
2019-07-01 Eric Botcazou <ebotcazou@adacore.com> gcc/ada/ * exp_ch9.adb (Check_Inlining): Deal with Has_Pragma_No_Inline. From-SVN: r272871
Eric Botcazou committed -
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
Ed Schonberg committed -
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
Pat Rogers committed -
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
Justin Squirek committed -
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
Bob Duff committed -
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
Yannick Moy committed -
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 committed -
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
Piotr Trojanek committed -
------------ -- 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: r272863Hristian Kirtchev committed -
------------ -- 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: r272862Hristian Kirtchev committed -
------------ -- 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: r272861Hristian Kirtchev committed -
------------ -- 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: r272860Hristian Kirtchev committed -
2019-07-01 Hristian Kirtchev <kirtchev@adacore.com> gcc/ada/ * exp_attr.adb, exp_ch7.adb, exp_unst.adb, sem_ch3.adb, sem_util.adb, uintp.adb, uintp.ads: Minor reformatting. From-SVN: r272859
Hristian Kirtchev committed -
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. From-SVN: r272858
Javier Miranda committed -
This patch introduces new unit GNAT.Graphs which currently provides a directed graph abstraction. ------------ -- 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_Set (Element_Type => Edge_Id, "=" => "=", Hash => Hash_Edge); package DG is new Directed_Graph (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_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. -------------------------------- -- Check_Belongs_To_Component -- -------------------------------- procedure Check_Belongs_To_Component (R : String; G : Instance; 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 : 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; ------------------------------ -- Check_Destination_Vertex -- ------------------------------ procedure Check_Destination_Vertex (R : String; G : Instance; 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 : 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; -------------------- -- Check_Has_Edge -- -------------------- 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; ---------------------- -- Check_Has_Vertex -- ---------------------- 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; ------------------------ -- Check_No_Component -- ------------------------ 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; ------------------- -- Check_No_Edge -- ------------------- 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; --------------------- -- Check_No_Vertex -- --------------------- 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; -------------------------------- -- Check_Number_Of_Components -- -------------------------------- 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; --------------------------- -- Check_Number_Of_Edges -- --------------------------- 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; ------------------------------ -- Check_Number_Of_Vertices -- ------------------------------ 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; ---------------------------------- -- Check_Outgoing_Edge_Iterator -- ---------------------------------- procedure Check_Outgoing_Edge_Iterator (R : String; G : Instance; V : Vertex_Id; Set : ES.Instance) 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 : Instance; 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 : Instance; Comp : Component_Id; Set : VS.Instance) 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 Instance is G : constant Instance := 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 : Instance := 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 : Instance := 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 : Instance := Create_And_Populate; All_E_Iter : All_Edge_Iterator; All_Edges : ES.Instance; 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 : Instance := Create_And_Populate; V : Vertex_Id; All_V_Iter : All_Vertex_Iterator; All_Vertices : VS.Instance; 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 : Instance := 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 : Instance := 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 : Instance := Create (Initial_Vertices => 2, Initial_Edges => 2); G2 : Instance := 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 : Instance := 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 : Instance := 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 : Instance := 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 : Instance := 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 : Instance := 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 : Instance := 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 : Instance := 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 : Instance := 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 : Instance := 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 : Instance := Create_And_Populate; Set : ES.Instance; 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 : Instance := 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 : Instance := 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 : Instance := Create_And_Populate; Set : VS.Instance; 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/ * 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. From-SVN: r272857Hristian Kirtchev committed -
2019-07-01 Dmitriy Anisimkov <anisimko@adacore.com> gcc/ada/ * libgnat/g-sothco.adb (Get_Address): Fix the case when AF_INET6 is not defined. From-SVN: r272856
Dmitriy Anisimkov committed -
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; procedure Main is begin Put_Line ("P1: " & P1'Image); Put_Line ("P2: " & P2'Image); Put_Line ("P3: " & P3'Image); Put_Line ("P4: " & P4'Image); end Main; -- package Problems is 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 -- Greatest prime factor GPF : Long_Integer := 1; Dividend : Long_Integer := 600851475143; Factor : Long_Integer := 2; Quotient : Long_Integer; begin 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; c : P4_Palindrome; Max_Palindrome : P4_Palindrome := P4_Palindrome'Invalid_Value; 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. From-SVN: r272855Ed Schonberg committed -
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. 2019-07-01 Hristian Kirtchev <kirtchev@adacore.com> gcc/ada/ * 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. From-SVN: r272854
Hristian Kirtchev committed -
2019-07-01 Pierre-Marie de Rodat <derodat@adacore.com> gcc/ada/ * doc/gnat_ugn/building_executable_programs_with_gnat.rst: Fix formatting issues in the -gnatR section. * gnat_ugn.texi: Regenerate. From-SVN: r272853
Pierre-Marie de Rodat committed -
PR lto/91028 PR lto/90720 * g++.dg/lto/alias-1_0.C: Add loop to make inlining happen with -fno-use-linker-plugin * g++.dg/lto/alias-2_0.C: Likewise. From-SVN: r272852
Jan Hubicka committed -
make_early_clobber_and_input_conflicts records allocno conflicts between inputs and earlyclobber outputs. It (rightly) avoids doing this for inputs that are explicitly allowed to match the output due to matching constraints. The problem is that whether this matching is allowed varies between alternatives. At the moment the code avoids adding a clobber if *any* enabled alternative allows the match, even if some other operand makes that alternative impossible. The specific instance of this for SVE is that some alternatives allow matched earlyclobbers when a third operand X is constant zero. We should avoid adding conflicts when X really is constant zero, but should ignore the match if X is nonzero or nonconstant. ira_setup_alts can already filter these alternatives out for us, so all we need to do is use it in process_bb_node_lives. The preferred_alternatives variable is only used for this earlyclobber detection, so no other check should be affected. With the previous patch to check the reject weight in ira_setup_alts, this has the effect of ignoring expensive alternatives if we have other valid alternatives with zero cost. It seems reasonable to base the heuristic on only the alternatives that we'd actually like to use, but if this ends up being too aggressive, we could instead make the new reject behaviour conditional and only use it for add_insn_allocno_copies. 2019-07-01 Richard Sandiford <richard.sandiford@arm.com> gcc/ * ira-lives.c (process_bb_node_lives): Use ira_setup_alts. From-SVN: r272851
Richard Sandiford committed -
ira_get_dup_out_num punted on operands that are matched to earlyclobber outputs: /* It is better ignore an alternative with early clobber. */ else if (*str == '&') goto fail; But I'm not sure why this is the right thing to do. At this stage we've established that *all* alternatives of interest require the input to match the output, so (a) the earlyclobber can only affect other operands and (b) not tying the registers is bound to introduce a move The code was part of the initial commit and so isn't obviously related to a specific testcase. Also, I can imagine LRA makes a much better job of this situation than reload did. (Certainly SVE uses matched earlyclobbers extensively and I haven't seen any problems.) In case this turns out to regress something important: the main case that matters for SVE is the one in which all alternatives are earlyclobber. 2019-07-01 Richard Sandiford <richard.sandiford@arm.com> gcc/ * ira.c (ira_get_dup_out_num): Don't punt for earlyclobbers. Use recog_data to test for an output operand. From-SVN: r272850
Richard Sandiford committed -
SVE has a prefix instruction (MOVPRFX) that acts as a move but is designed to be easily fusible with the following instruction. The SVE port therefore has lots of patterns with constraints of the form: A: operand 0: =w,?w ... operand n: 0, w where the first alternative is a single instruction and the second alternative uses MOVPRFX. Ideally we want operand n to be allocated to the same register as operand 0 in this case. add_insn_allocno_copies is the main IRA routine that deals with tied operands. It is (rightly) very conservative, and only handles cases in which we're confident about saving a full move. So for a pattern like: B: operand 0: =w,w ... operand n: 0,w we don't (and shouldn't) assume that tying operands 0 and n would save the cost of a move. But in A, the second alternative has a ? marker, which makes it more expensive than the first alternative by a full reload. So I think for copy elision we should ignore the untied operand n in the second alternative of A. One approach would be to add '*' markers to each pattern and make ira_get_dup_out_num honour them. But I think the rule applies on first principles, so marking with '*' shouldn't be necessary. This patch instead makes ira_get_dup_out_num ignore expensive alternatives if there are other alternatives that match exactly. The cheapest way of doing that seemed to be to take expensive alternatives out of consideration in ira_setup_alts, which provides a bitmask of alternatives and has all the information available. add_insn_allocno_copies is the only current user of ira_setup_alts, so no other code should be affected. If all available alternatives are disparaged or need a reload, there's not much we can do to cut them down at this stage, since it's hard to predict which operands will be reloaded and which registers will need to be spilled. An interesting case is patterns like this msp430 one: ;; Alternatives 2 and 3 are to handle cases generated by reload. (define_insn "subqi3" [(set (match_operand:QI 0 "nonimmediate_operand" "=rYs, rm, &?r, ?&r") (minus:QI (match_operand:QI 1 "general_operand" "0, 0, !r, !i") (match_operand:QI 2 "general_operand" " riYs, rmi, rmi, r")))] "" "@ SUB.B\t%2, %0 SUB%X0.B\t%2, %0 MOV%X0.B\t%1, %0 { SUB%X0.B\t%2, %0 MOV%X0.B\t%1, %0 { SUB%X0.B\t%2, %0" ) Here alternative 3 is significantly more expensive then alternative 0 (reject costs 0 and 606 respectively). But if operand 1 is an integer constant, we'll still use alternative 3 if operand 2 is an allocated register. On the other hand, if operand 1 is an integer constant but operand 2 is spilled to memory, we'll move the constant into a register and use the first alternative. So in this case, if operand 1 is a register, we should consider only the first two alternatives and thus try to tie operand 1 to operand 0 (which we didn't do previously). If operand 1 is a constant integer, we should consider at least alternatives 0, 1 and 3. We could exclude alternative 2, but I don't have any evidence that that's useful. 2019-07-01 Richard Sandiford <richard.sandiford@arm.com> gcc/ * ira.c (ira_setup_alts): If any valid alternatives have zero cost, exclude any others that are disparaged or that are bound to need a reload or spill. (ira_get_dup_out_num): Expand comment. From-SVN: r272849Richard Sandiford committed -
ira_setup_alts has its own code to calculate the start of the constraint string for each operand/alternative combination, but preprocess_constraints now provides that information in (almost) constant time for non-asm instructions. Using it here should speed up the common case at the cost of potentially slowing down the handling of asm statements. The real reason for doing this is that a later patch wants to use more of the operand_alternative information. 2019-07-01 Richard Sandiford <richard.sandiford@arm.com> gcc/ * ira.c (ira_setup_alts): Use preprocess_constraints to get the constraint string for each operand/alternative combo. Only handle '%' at the start of constraint strings, and look for it outside the main loop. From-SVN: r272848
Richard Sandiford committed -
add_insn_allocno_copies and its subroutines used HARD_REG_SET to represent a bitmask of alternatives. There's not really any connection between the number of registers and the maximum number of alternatives, so this patch uses alternative_mask instead (which wasn't around when this code was added). This is just a minor clean-up making way for later patches. 2019-07-01 Richard Sandiford <richard.sandiford@arm.com> gcc/ * ira-int.h (ira_setup_alts, ira_get_dup_out_num): Use alternative_mask instead of HARD_REG_SET to represent a bitmask of alternatives. * ira.c (ira_setup_alts, ira_get_dup_out_num): Likewise. * ira-conflicts.c (add_insn_allocno_copies): Likewise. From-SVN: r272847
Richard Sandiford committed
-
