├── .gitattributes ├── .gitignore ├── .gitreview ├── LICENSE ├── Makefile ├── README.md ├── REQUIREMENTS.txt ├── TODO ├── doc ├── Makefile ├── conf.py ├── conventions.rst ├── design_considerations.rst ├── elements.rst ├── graph_algorithms.rst ├── graphs.rst ├── index.rst ├── intro.rst ├── lists.rst ├── making_of.rst ├── maps.rst └── vectors.rst ├── root.gpr ├── src ├── containers.gpr ├── containers_shared.gpr ├── conts-adaptors.ads ├── conts-algorithms-spark.adb ├── conts-algorithms-spark.ads ├── conts-algorithms.adb ├── conts-algorithms.ads ├── conts-cursors.ads ├── conts-elements-arrays.adb ├── conts-elements-arrays.ads ├── conts-elements-definite.ads ├── conts-elements-indefinite.adb ├── conts-elements-indefinite.ads ├── conts-elements-indefinite_spark.adb ├── conts-elements-indefinite_spark.ads ├── conts-elements-null_elements.ads ├── conts-elements.ads ├── conts-functional-base.adb ├── conts-functional-base.ads ├── conts-functional-maps.adb ├── conts-functional-maps.ads ├── conts-functional-sequences.adb ├── conts-functional-sequences.ads ├── conts-functional-sets.adb ├── conts-functional-sets.ads ├── conts-functional.ads ├── conts-graphs-adjacency_list.adb ├── conts-graphs-adjacency_list.ads ├── conts-graphs-components.adb ├── conts-graphs-components.ads ├── conts-graphs-dfs.adb ├── conts-graphs-dfs.ads ├── conts-graphs.ads ├── conts-lists-definite_bounded.ads ├── conts-lists-definite_unbounded.ads ├── conts-lists-generics.ads ├── conts-lists-impl.adb ├── conts-lists-impl.ads ├── conts-lists-indefinite_unbounded.ads ├── conts-lists-indefinite_unbounded_spark.adb ├── conts-lists-indefinite_unbounded_spark.ads ├── conts-lists-storage-bounded.adb ├── conts-lists-storage-bounded.ads ├── conts-lists-storage-bounded_definite.adb ├── conts-lists-storage-bounded_definite.ads ├── conts-lists-storage-unbounded.adb ├── conts-lists-storage-unbounded.ads ├── conts-lists-storage-unbounded_spark.adb ├── conts-lists-storage-unbounded_spark.ads ├── conts-lists-storage.ads ├── conts-lists-strings.ads ├── conts-lists.ads ├── conts-maps-def_def_unbounded.ads ├── conts-maps-generics.ads ├── conts-maps-impl.adb ├── conts-maps-impl.ads ├── conts-maps-indef_def_unbounded.ads ├── conts-maps-indef_indef_unbounded.ads ├── conts-maps-indef_indef_unbounded_spark.adb ├── conts-maps-indef_indef_unbounded_spark.ads ├── conts-maps.adb ├── conts-maps.ads ├── conts-properties-indexed.adb ├── conts-properties-indexed.ads ├── conts-properties-spark.ads ├── conts-properties.ads ├── conts-vectors-definite_bounded.ads ├── conts-vectors-definite_unbounded.ads ├── conts-vectors-generics.ads ├── conts-vectors-impl.adb ├── conts-vectors-impl.ads ├── conts-vectors-indefinite_unbounded.ads ├── conts-vectors-indefinite_unbounded_spark.adb ├── conts-vectors-indefinite_unbounded_spark.ads ├── conts-vectors-storage-bounded.adb ├── conts-vectors-storage-bounded.ads ├── conts-vectors-storage-bounded_definite.adb ├── conts-vectors-storage-bounded_definite.ads ├── conts-vectors-storage-unbounded.adb ├── conts-vectors-storage-unbounded.ads ├── conts-vectors-storage.ads ├── conts-vectors.ads ├── conts.adb └── conts.ads └── tests ├── algo_equals ├── main.adb └── test.yaml ├── algo_shuffle ├── main.adb └── test.yaml ├── algo_sort ├── main.adb └── test.yaml ├── lists_definite_bounded ├── main.adb ├── support.adb ├── support.ads ├── test.out └── test.yaml ├── lists_definite_limited_bounded ├── main.adb └── test.yaml ├── lists_definite_unbounded ├── main.adb └── test.yaml ├── lists_indefinite_unbounded ├── main.adb └── test.yaml ├── lists_indefinite_unbounded_spark ├── main.adb └── test.yaml ├── maps ├── main.adb ├── test.out └── test.yaml ├── perfs ├── angular.min.js ├── creport.cc ├── creport.h ├── custom_graph.adb ├── custom_graph.ads ├── generate_test.py ├── gnat.adc ├── graph1_support.adb ├── graph1_support.ads ├── graph_cpp.cc ├── index.html ├── main.adb ├── memory.adb ├── memory.ads ├── perf_support.adb ├── perf_support.ads ├── qgen.adb ├── qgen.ads ├── report.adb ├── report.ads ├── s-memory.adb ├── support.cc ├── support.js ├── test.out ├── test.yaml └── tests_perfs.gpr ├── post ├── lists.adb ├── main.adb ├── maps.adb ├── test.yaml └── vectors.adb ├── random ├── main.adb └── test.yaml ├── run-test ├── scc ├── main.adb ├── test.out └── test.yaml ├── shared ├── asserts.adb └── asserts.ads ├── spark ├── formal_hashed_sets.ads ├── formal_hashed_sets_impl.ads ├── formal_ordered_sets.ads ├── formal_ordered_sets_impl.ads ├── test.out ├── test.yaml ├── use_lists.adb ├── use_lists.ads ├── use_maps.adb ├── use_maps.ads ├── use_ordered_sets.adb ├── use_ordered_sets.ads ├── use_sets.adb ├── use_sets.ads ├── use_vectors.adb └── use_vectors.ads ├── support.py ├── testsuite.py ├── vectors_definite_bounded ├── main.adb ├── support.adb ├── support.ads ├── test.out └── test.yaml ├── vectors_definite_unbounded ├── main.adb └── test.yaml ├── vectors_indefinite_unbounded ├── main.adb └── test.yaml └── vectors_indefinite_unbounded_spark ├── main.adb └── test.yaml /.gitattributes: -------------------------------------------------------------------------------- 1 | tests/spark/* no-precommit-check 2 | 3 | tests/perfs/generate_test.py no-precommit-check 4 | tests/perfs/angular.min.js no-precommit-check 5 | doc/conf.py no-precommit-check 6 | COPYING* no-precommit-check 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | obj/ 2 | lib/ 3 | *.pyc 4 | .*.swp 5 | 6 | doc/build/ 7 | 8 | tests/perfs/generated/ 9 | tests/perfs/data.js 10 | tests/out 11 | -------------------------------------------------------------------------------- /.gitreview: -------------------------------------------------------------------------------- 1 | [gerrit] 2 | host = git.adacore.com 3 | project = ada-traits-containers 4 | defaultbranch = master 5 | defaultremote = origin 6 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | BUILD=Production 2 | 3 | # Installation directory 4 | PREFIX= 5 | 6 | # In our automatic nightly builds, we want to consider the source 7 | # directory as read-only, and build in another directory. 8 | ifeq (${SOURCE_DIR},) 9 | GPR_CONTS=src/containers.gpr 10 | GPR_ROOT=root.gpr 11 | SOURCE_DIR=$(shell pwd) 12 | RBD= 13 | else 14 | GPR_CONTS=$(SOURCE_DIR)/src/containers.gpr 15 | GPR_ROOT=${SOURCE_DIR}/root.gpr 16 | RBD=--relocate-build-tree 17 | endif 18 | 19 | # The project path, when compiling tests 20 | PPATH=GPR_PROJECT_PATH="${SOURCE_DIR}/src:${GPR_PROJECT_PATH}" 21 | 22 | # Add support for passing extra switches to gprbuild, like -d 23 | GPRBUILD_OPTIONS= 24 | 25 | GPRBUILD=gprbuild ${RBD} -p -m -j0 ${GPRBUILD_OPTIONS} 26 | GPRINSTALL=gprinstall ${RBD} -p -m ${GPRBUILD_OPTIONS} \ 27 | --install-name='containers' \ 28 | --project-subdir=lib/gnat 29 | 30 | 31 | all: 32 | ${GPRBUILD} -P${GPR_CONTS} -XBUILD=${BUILD} 33 | 34 | install: 35 | ${GPRINSTALL} -P${GPR_CONTS} --prefix=${PREFIX} 36 | 37 | # Run all tests, except manual ones 38 | test: 39 | cd tests; ${PPATH} python ./testsuite.py -j0 --enable-color 40 | 41 | # Run all tests with valgrind 42 | test_with_valgrind: 43 | cd tests; ${PPATH} python ./testsuite.py -j0 --enable-color --valgrind 44 | 45 | # Verify memory leaks in tests 46 | test_with_leaks: 47 | cd tests; ${PPATH} python ./testsuite.py -j0 --enable-color --leaks 48 | 49 | # Run manual tests 50 | perfs: 51 | ${GPRBUILD} -P${GPR_CONTS} -XBUILD=Production 52 | cd tests; ${PPATH} python ./testsuite.py -j0 --enable-color $@ 53 | spark: 54 | ${GPRBUILD} -P${GPR_CONTS} -XBUILD=Debug 55 | cd tests; ${PPATH} python ./testsuite.py -j0 --enable-color $@ 56 | 57 | # Create all project files, for use with GPS 58 | projects: 59 | cd tests; python ./testsuite.py -c 60 | 61 | clean: 62 | ${PPATH} gprclean -P${GPR_ROOT} -XBUILD=Debug -r -q 63 | ${PPATH} gprclean -P${GPR_ROOT} -XBUILD=Production -r -q 64 | -rm -f tests/*/auto_*.gpr 65 | -rm -rf tests/*/obj/ 66 | 67 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # Generic Ada Library for Algorithms and Containers 3 | 4 | ## Goals 5 | 6 | This library is another containers library for Ada. Although it 7 | provides containers that do not exist in the standard Ada 8 | runtime (graphs for instance), it is more interesting for the 9 | flexibility it proposes: 10 | 11 | - [X] Bounded/Unbounded containers and even more variants suitable 12 | for use with the SPARK language. 13 | 14 | - [X] Finite/Indefinite elements, and even more specialized 15 | variants optimized for specific types 16 | 17 | - [X] Pre and Post conditions, compatible with SPARK, so that some 18 | variants of the containers can be used for proof. 19 | 20 | - [X] Highly efficient; the user has full control over memory 21 | allocations, checks, locks, ... 22 | 23 | All this flexibility is done via the intensive use of generic 24 | packages, themselves used to instantiate other generic packages. 25 | 26 | Check the [documentation](doc/making_of.rst) for more details on the 27 | design of the API, and its current usage. 28 | 29 | ## Compiling 30 | 31 | The library itself is pure Ada code, and only requires a working 32 | Ada compiler to be available in your environment. 33 | 34 | This library comes with a testsuite which measures the performance 35 | of the various variants of the containers, and compares them with 36 | C++ equivalent (or near equivalents). This testsuite generates a 37 | nice interactive HTML file. 38 | 39 | Compiling and running the testsuite requires that you also have a 40 | C++ compiler in your environment. In addition, you must install the 41 | Boost Graph Library (http://www.boost.org). 42 | 43 | You must also download and install the 44 | [GNAT Components Collection](http://libre.adacore.com). 45 | 46 | Finally, in order to run the testsuite, you need to install GNATpython and 47 | PyYAML in your Python2 environment. You can install both with the following 48 | command: 49 | 50 | ```sh 51 | pip install -r REQUIREMENTS.txt 52 | ``` 53 | 54 | Once this is done, modify the [shared.gpr](src/shared.gpr) file. 55 | Set the variable ```Boost_Include''' to point to the install prefix 56 | for Boost: 57 | 58 | ``` 59 | Boost_Include := ("-I/usr/include"); 60 | ``` 61 | 62 | Finally, compile and run the test with 63 | 64 | ``` 65 | make all perfs 66 | ``` 67 | 68 | and finally open the file [tests/perfs/index.html](index.html) 69 | in a browser to view the performance comparison. 70 | 71 | ## Editing with GNAT Programming Studio 72 | 73 | To edit with GPS, including the tests, you must first run: 74 | 75 | make projects 76 | 77 | Then you can edit by launching GPS from the top directory, which will 78 | automatically load the aggregate project 'root.gpr' 79 | -------------------------------------------------------------------------------- /REQUIREMENTS.txt: -------------------------------------------------------------------------------- 1 | -e git+https://github.com/Nikokrock/gnatpython.git#egg=gnatpython 2 | PyYAML==3.12 3 | -------------------------------------------------------------------------------- /doc/conventions.rst: -------------------------------------------------------------------------------- 1 | Naming and Coding Conventions 2 | ============================= 3 | 4 | .. highlight:: ada 5 | 6 | This section describes some of the conventions and namings used throughout this 7 | library. As much as possible, all containers follow these conventions for 8 | consistency. 9 | 10 | ``Traits`` 11 | 12 | This suffix is added to package names that only have formal parameters, 13 | but provide no new capability on their own. They are used to encapsulate 14 | multiple related pieces of information, so that other packages can take a 15 | single instance of such a traits package, instead of a very large set of 16 | parameters. Although they require extra instantiations in the application 17 | code, they simplify the overall API. 18 | 19 | examples: ``Conts.Elements.Traits``, 20 | ``Conts.Cursors.Constant_Forward_Traits`` 21 | 22 | ``_Type`` 23 | 24 | This suffix is used for formal type parameters of generic packages. This 25 | follows the convention already used by the standard Ada container 26 | packages. In addition, we provide renamings for these parameters inside 27 | the generic packages, as in:: 28 | 29 | generic 30 | type Element_Type (<>) is limited private; 31 | package Traits is 32 | subtype Element is Element_Type; 33 | end Traits; 34 | 35 | The renamings are necessary because of the visibility defined by the 36 | standard. Basically, the compiler hides the declaration of 37 | ``Element_Type`` when it is known statically and there are therefore 38 | other ways to access it. For instance, in the following code, the 39 | declaration of ``A`` is illegal:: 40 | 41 | with Cursors; 42 | package body Pkg is 43 | package Int is new Traits (Integer); 44 | 45 | A : Int.Element_Type; -- Illegal 46 | B : Int.Element; 47 | begin 48 | null; 49 | end Pkg; 50 | 51 | For this reason, the subtype declaration ensures that the formal type is 52 | always illegal. In general, the code should use the subtype rather than 53 | the formal type. See also the Ada Reference Manual (12.7 10/2) for 54 | more information. 55 | 56 | Inlining 57 | 58 | A lot of the subprograms in this library are inlined. This is of course 59 | for performance reasons, since even through a generic instance, the 60 | compiler is able to completely bypass the cost of calling the subprogram. 61 | This results in very significant speed up when iterating over large 62 | containers. This is also an improvement when a function returns an 63 | unconstrained type (like the various ``Identity`` functions that just 64 | return their parameter). 65 | 66 | Expression functions 67 | 68 | In addition to being marked inline, a number of functions are written as 69 | expression functinos. When this function needs to access the private part 70 | of a package, we generally have a public spec, marked inline, and then in 71 | the private part the expression function itself. 72 | 73 | There doesn't seem to be a benefit, performance-wise, but this keeps the 74 | code slightly shorter so has been adopted as a convention. 75 | 76 | .. _tagged_and_controlled_types: 77 | 78 | Tagged and controlled types 79 | 80 | All containers provided in this package are implemented as tagged types. 81 | One of the reasons to do so is to be able to use the dot notation to call 82 | primitive operations (as in ``Vec.Append`` for instance. 83 | 84 | The more important reason is that most applications will want those 85 | containers to be controlled types, so that memory is automatically 86 | released when the container is no longer used. 87 | 88 | Containers are not systematically controlled though, since this is not 89 | supported for the SPARK language. In such a case, the containers will 90 | instead extend the ``Conts.Limited_Base``, which makes them limited 91 | types. 92 | -------------------------------------------------------------------------------- /doc/graph_algorithms.rst: -------------------------------------------------------------------------------- 1 | Graph algorithms 2 | ================ 3 | -------------------------------------------------------------------------------- /doc/graphs.rst: -------------------------------------------------------------------------------- 1 | `Graph` data type 2 | ================== 3 | -------------------------------------------------------------------------------- /doc/index.rst: -------------------------------------------------------------------------------- 1 | .. Generic Ada Library for Algorithms and Containers (GALAC) documentation master file, created by 2 | sphinx-quickstart on Mon Jan 18 13:53:46 2016. 3 | You can adapt this file completely to your liking, but it should at least 4 | contain the root `toctree` directive. 5 | 6 | Generic Ada Library for Algorithms and Containers 7 | ================================================= 8 | 9 | Contents: 10 | 11 | .. toctree:: 12 | :maxdepth: 2 13 | 14 | intro 15 | making_of 16 | conventions 17 | elements 18 | vectors 19 | lists 20 | maps 21 | graphs 22 | graph_algorithms 23 | design_considerations 24 | 25 | 26 | 27 | Indices and tables 28 | ================== 29 | 30 | * :ref:`genindex` 31 | * :ref:`modindex` 32 | * :ref:`search` 33 | 34 | -------------------------------------------------------------------------------- /doc/intro.rst: -------------------------------------------------------------------------------- 1 | Introduction 2 | ============ 3 | 4 | This library provides a number of data types and algorithms. 5 | 6 | These algorithms, however, work with potentially any data type, not just 7 | the specific implementations provided in this package. For instance, you 8 | do not have to use any of the provided `Graph` data structures to use 9 | an algorithm like `Depth First Search`. Instead, via the careful use of 10 | generics, these algorithms can be applied to any other data structure. 11 | 12 | The first part of this documentation will explain the design and concepts 13 | of this library. Later chapters then take a look at each of the data 14 | structures and algorithms. Finally, some considerations on the use of 15 | generics in Ada will be explained. 16 | -------------------------------------------------------------------------------- /doc/lists.rst: -------------------------------------------------------------------------------- 1 | `List` data type 2 | ================ 3 | 4 | 5 | Bounded lists 6 | ------------- 7 | 8 | A bounded list is a list with a known maximal number of elements. The 9 | list can be shorter, but can never contain more elements than that 10 | maximum size. 11 | 12 | The tradeoff for this restriction is that the list does not need to 13 | perform any memory allocation for the list's nodes, which might be 14 | faster and fit in tight memory constraints. 15 | -------------------------------------------------------------------------------- /doc/maps.rst: -------------------------------------------------------------------------------- 1 | .. highlight:: ada 2 | 3 | `Map` data type 4 | =============== 5 | 6 | A map is an association between two elements (the key and the value). 7 | Knowing the key (most often a `String`) gives fast (near constant 8 | time) access to the corresponding value. 9 | 10 | ... to be completed 11 | 12 | Iteration 13 | --------- 14 | 15 | There exist several ways to iterate on maps, depending on what piece 16 | of information you need to retrieve. 17 | 18 | If you want to retrieve all the keys stored in the map (from which 19 | you can then retrieve the values), you can use:: 20 | 21 | declare 22 | M : Map; 23 | begin 24 | for Key of M loop 25 | ... M.Get (Key) -- to access the value 26 | end loop; 27 | end; 28 | 29 | Although retrieving an element from the key is very fast, it is 30 | still a bit slower than to have a more direct access to it. For this, 31 | you could use cursors instead:: 32 | 33 | declare 34 | M : Map; 35 | C : Cursor := Map.First; 36 | begin 37 | while Map.Has_Element (C) loop 38 | ... M.Key (C) -- to retrieve the key 39 | ... M.Element (C) -- to access the value 40 | Map.Next (C); 41 | end loop; 42 | end; 43 | 44 | or the simpler:: 45 | 46 | declare 47 | M : Map; 48 | begin 49 | for C in M loop 50 | ... M.Key (C) -- to retrieve the key 51 | ... M.Element (C) -- to access the value 52 | end loop; 53 | end; 54 | 55 | These loops are significantly faster than the previous for-of loop when 56 | retrieving the values (but not faster if you are only interested in the 57 | keys). 58 | 59 | Note that the for-of loop differs from that of the standard Ada containers, 60 | in that it returns the keys stored in the map, not its elements. This is 61 | because once you have the key, it is easy and relatively fast to get the 62 | value. However, with the standard Ada containers, once you have the value 63 | there is no convenient way to retrieve the corresponding key. 64 | 65 | -------------------------------------------------------------------------------- /root.gpr: -------------------------------------------------------------------------------- 1 | aggregate project Root is 2 | 3 | for Project_files use ("src/containers.gpr", "tests/**/*.gpr"); 4 | for Project_Path use ("src/"); 5 | for Object_Dir use "src/obj"; 6 | 7 | package Ide is 8 | for Xref_Database use "src/obj/gnatinspect.db"; 9 | end Ide; 10 | 11 | end Root; 12 | -------------------------------------------------------------------------------- /src/containers.gpr: -------------------------------------------------------------------------------- 1 | with "containers_shared"; 2 | library project Containers is 3 | for Object_Dir use "obj/" & Containers_Shared.Mode; 4 | for Source_Dirs use ("."); 5 | 6 | for Library_Name use "containers"; 7 | for Library_Dir use "lib"; 8 | for Library_Kind use Containers_Shared.Library_Kind; 9 | 10 | package Naming renames Containers_Shared.Naming; 11 | package Builder renames Containers_Shared.Builder; 12 | package Compiler renames Containers_Shared.Compiler; 13 | package Binder renames Containers_Shared.Binder; 14 | end Containers; 15 | -------------------------------------------------------------------------------- /src/containers_shared.gpr: -------------------------------------------------------------------------------- 1 | abstract project Containers_Shared is 2 | Version := "0.1"; 3 | 4 | type Build_Mode is ("Production", "Debug"); 5 | Mode : Build_Mode := external ("BUILD", "Production"); 6 | 7 | type Library_Kind_Type is ("relocatable", "static"); 8 | Library_Kind : Library_Kind_Type := external ("LIBRARY_TYPE", "static"); 9 | 10 | package Naming is 11 | for Implementation_Suffix ("C++") use ".cc"; 12 | for Implementation_Suffix ("Python") use ".py"; 13 | end Naming; 14 | 15 | package Builder is 16 | for Switches ("Ada") use ("-j0", "-m"); 17 | end Builder; 18 | 19 | package Compiler is 20 | for Driver ("Python") use ""; 21 | 22 | Common_Ada_Switches := 23 | ("-gnaty", "-gnatwu", "-gnat12", "-g", 24 | 25 | -- Remove unusued subprograms 26 | "-fdata-sections", "-ffunction-sections" 27 | 28 | -- Link time optimization 29 | -- "-flto" 30 | ); 31 | 32 | case Mode is 33 | when "Production" => 34 | for Switches ("Ada") use Common_Ada_Switches & 35 | ("-O3", "-gnatp", "-gnatn" 36 | 37 | -- Disable overflow checks 38 | , "-gnato0" 39 | 40 | -- Warnings when a subprogram cannot be inlined. This needs 41 | -- to be checked regularly, but raises a few warnings for 42 | -- some subprograms created by GNAT (*_IP) in gnatcoll. 43 | -- , "-Winline" 44 | 45 | -- See generated assembly 46 | -- , "-save-temps" 47 | ); 48 | for Switches ("C++") use ("-O3", "-finline", "-std=c++11"); 49 | 50 | when "Debug" => 51 | for Switches ("Ada") use Common_Ada_Switches 52 | & ("-O0", "-gnata" 53 | 54 | -- Add extra checks for stack 55 | -- , "-fstack-check" 56 | ); 57 | for Switches ("C++") use ("-std=c++11", "-O0", "-g"); 58 | end case; 59 | end Compiler; 60 | 61 | package Binder is 62 | for Switches ("Ada") use ("-E", "-g"); 63 | end Binder; 64 | 65 | package Linker is 66 | for Switches ("Ada") use ( 67 | -- Remove unused subprograms 68 | -- "-Wl,-dead_strip" -- OSX 69 | -- "-Wl,--gc-sections" -- linux 70 | 71 | -- "-Wl,--print-gc-sections" 72 | -- "-Wl,-flto" 73 | ); 74 | end Linker; 75 | end Containers_Shared; 76 | -------------------------------------------------------------------------------- /src/conts-algorithms-spark.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | 9 | package body Conts.Algorithms.SPARK is 10 | 11 | ---------- 12 | -- Find -- 13 | ---------- 14 | 15 | function Find 16 | (Self : Cursors.Container; 17 | E : Getters.Element) 18 | return Cursors.Cursor 19 | with SPARK_Mode => Off 20 | is 21 | function Find_Impl is 22 | new Conts.Algorithms.Find (Cursors, Getters, "="); 23 | begin 24 | return Find_Impl (Self, E); 25 | end Find; 26 | 27 | -------------- 28 | -- Contains -- 29 | -------------- 30 | 31 | function Contains 32 | (Self : Cursors.Container; 33 | E : Getters.Element) 34 | return Boolean 35 | with SPARK_Mode => Off 36 | is 37 | function Contains_Impl is 38 | new Conts.Algorithms.Contains (Cursors, Getters, "="); 39 | begin 40 | return Contains_Impl (Self, E); 41 | end Contains; 42 | 43 | ------------ 44 | -- Equals -- 45 | ------------ 46 | 47 | function Equals (Left, Right : Cursors.Container) return Boolean 48 | with SPARK_Mode => Off 49 | is 50 | function Equals_Impl is 51 | new Conts.Algorithms.Equals (Cursors, Getters, "="); 52 | begin 53 | return Equals_Impl (Left, Right); 54 | end Equals; 55 | 56 | end Conts.Algorithms.SPARK; 57 | -------------------------------------------------------------------------------- /src/conts-algorithms-spark.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- This package provides wrappers around SPARK compatible algorithms of 8 | -- Conts.Algorithms providing postconditions. 9 | -- They should be instanciated with appropriate models 10 | -- of the container. More precisely, for every container Self, the 11 | -- result of Content.Model (Self) must be such that Content.Get (Content.Model 12 | -- (Self), Content.First + I) is always the element returned by 13 | -- Getters.Get (Self, C) on the cursor C obtained by applying Cursors.Next 14 | -- I times on Cursors.First (Self). 15 | -- These algorithms have a body with SPARK_Mode => Off so they must be 16 | -- instantiated at library level inside SPARK code. 17 | 18 | pragma Ada_2012; 19 | with Conts.Cursors; 20 | with Conts.Properties; 21 | with Conts.Properties.SPARK; 22 | 23 | package Conts.Algorithms.SPARK is 24 | 25 | ---------- 26 | -- Find -- 27 | ---------- 28 | 29 | generic 30 | with package Cursors is new Conts.Cursors.Forward_Cursors (<>); 31 | with package Getters is new Conts.Properties.Read_Only_Maps 32 | (Map_Type => Cursors.Container, 33 | Key_Type => Cursors.Cursor, 34 | others => <>); 35 | with function "=" (K1, K2 : Getters.Element) return Boolean is <>; 36 | with package Content is new Conts.Properties.SPARK.Content_Models 37 | (Map_Type => Getters.Map, 38 | Element_Type => Getters.Element_Type, 39 | others => <>); 40 | function Find 41 | (Self : Cursors.Container; 42 | E : Getters.Element) 43 | return Cursors.Cursor 44 | with SPARK_Mode, 45 | Global => null, 46 | Contract_Cases => 47 | ((for all I in Content.First .. Content.Last (Content.Model (Self)) => 48 | Content.Get (Content.Model (Self), I) /= E) => 49 | Cursors."=" (Find'Result, Cursors.No_Element), 50 | others => Cursors.Has_Element (Self, Find'Result) 51 | and then Getters.Get (Self, Find'Result) = E); 52 | 53 | -------------- 54 | -- Contains -- 55 | -------------- 56 | 57 | generic 58 | with package Cursors is new Conts.Cursors.Forward_Cursors (<>); 59 | with package Getters is new Conts.Properties.Read_Only_Maps 60 | (Map_Type => Cursors.Container, 61 | Key_Type => Cursors.Cursor, 62 | others => <>); 63 | with function "=" (K1, K2 : Getters.Element) return Boolean is <>; 64 | with package Content is new Conts.Properties.SPARK.Content_Models 65 | (Map_Type => Getters.Map, 66 | Element_Type => Getters.Element_Type, 67 | others => <>); 68 | function Contains 69 | (Self : Cursors.Container; 70 | E : Getters.Element) 71 | return Boolean 72 | with SPARK_Mode, 73 | Global => null, 74 | Post => Contains'Result = 75 | (for some I in Content.First .. Content.Last (Content.Model (Self)) => 76 | Content.Get (Content.Model (Self), I) = E); 77 | 78 | ------------ 79 | -- Equals -- 80 | ------------ 81 | 82 | generic 83 | with package Cursors is new Conts.Cursors.Random_Access_Cursors (<>); 84 | with package Getters is new Conts.Properties.Read_Only_Maps 85 | (Map_Type => Cursors.Container, 86 | Key_Type => Cursors.Index_Type, 87 | others => <>); 88 | with function "=" (K1, K2 : Getters.Element) return Boolean is <>; 89 | with package Content is new Conts.Properties.SPARK.Content_Models 90 | (Map_Type => Getters.Map, 91 | Element_Type => Getters.Element_Type, 92 | others => <>); 93 | function Equals (Left, Right : Cursors.Container) return Boolean 94 | with SPARK_Mode, 95 | Global => null, 96 | Post => Equals'Result = 97 | (Content."=" (Content.Last (Content.Model (Left)), 98 | Content.Last (Content.Model (Right))) 99 | and then 100 | (for all I in Content.First .. Content.Last (Content.Model (Left)) => 101 | Content.Get (Content.Model (Left), I) = 102 | Content.Get (Content.Model (Right), I))); 103 | 104 | end Conts.Algorithms.SPARK; 105 | -------------------------------------------------------------------------------- /src/conts-elements-arrays.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | with Ada.Unchecked_Conversion; 8 | with Ada.Unchecked_Deallocation; 9 | with System; 10 | 11 | package body Conts.Elements.Arrays is 12 | 13 | package body Fat_Pointers is 14 | type C_Fat_Pointer is record 15 | Data, Bounds : System.Address; 16 | end record; 17 | 18 | type Array_Access is access all Array_Type; 19 | pragma No_Strict_Aliasing (Array_Access); 20 | 21 | pragma Warnings (Off); -- strict aliasing 22 | function To_FP is new Ada.Unchecked_Conversion 23 | (C_Fat_Pointer, Array_Access); 24 | pragma Warnings (On); -- strict aliasing 25 | 26 | procedure Set (FP : in out Fat_Pointer; A : Array_Type) is 27 | begin 28 | FP.Data (1 .. A'Length) := A; 29 | FP.Bounds := (1, A'Length); 30 | end Set; 31 | 32 | function Get 33 | (FP : not null access constant Fat_Pointer) return Constant_Ref_Type 34 | is 35 | F : constant C_Fat_Pointer := (FP.Data'Address, FP.Bounds'Address); 36 | AC : constant Array_Access := To_FP (F); 37 | begin 38 | return Constant_Ref_Type'(Element => AC); 39 | end Get; 40 | end Fat_Pointers; 41 | 42 | package body Impl is 43 | procedure Unchecked_Free is new Ada.Unchecked_Deallocation 44 | (Array_Type, Array_Access); 45 | 46 | --------------- 47 | -- To_Stored -- 48 | --------------- 49 | 50 | function To_Stored (A : Array_Type) return Stored_Array is 51 | begin 52 | if A'Length <= Short_Size then 53 | return S : Stored_Array (Short_Array) do 54 | Fat_Pointers.Set (S.Short, A); 55 | end return; 56 | else 57 | return S : Stored_Array (Long_Array) do 58 | S.Long := new Array_Type'(A); 59 | end return; 60 | end if; 61 | end To_Stored; 62 | 63 | ------------ 64 | -- To_Ref -- 65 | ------------ 66 | 67 | function To_Ref (S : Stored_Array) return Constant_Ref_Type is 68 | begin 69 | if S.Kind = Short_Array then 70 | return Fat_Pointers.Get (S.Short'Access); 71 | else 72 | return Constant_Ref_Type'(Element => S.Long); 73 | end if; 74 | end To_Ref; 75 | 76 | ---------- 77 | -- Copy -- 78 | ---------- 79 | 80 | function Copy (S : Stored_Array) return Stored_Array is 81 | begin 82 | case S.Kind is 83 | when Short_Array => 84 | return S; 85 | when Long_Array => 86 | return R : Stored_Array (Long_Array) do 87 | R.Long := new Array_Type'(S.Long.all); 88 | end return; 89 | end case; 90 | end Copy; 91 | 92 | ------------- 93 | -- Release -- 94 | ------------- 95 | 96 | procedure Release (S : in out Stored_Array) is 97 | begin 98 | if S.Kind = Long_Array then 99 | Unchecked_Free (S.Long); 100 | end if; 101 | end Release; 102 | end Impl; 103 | 104 | end Conts.Elements.Arrays; 105 | -------------------------------------------------------------------------------- /src/conts-elements-definite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- This unit provides a specialization of the element traits, for use with 8 | -- definite elements, i.e. elements whose size is known at compile time. 9 | -- Such elements do not need an extra level of indirection via pointers to 10 | -- be stored in a container. 11 | 12 | pragma Ada_2012; 13 | 14 | generic 15 | type Element_Type is private; 16 | -- Must be a copyable type (as defined in conts-elements.ads), and 17 | -- therefore not a pointer type. In such a case, use 18 | -- conts-elements-indefinite.ads instead, and let it do the allocations 19 | -- itself. 20 | 21 | with procedure Free (E : in out Element_Type) is null; 22 | -- Free is called when the element is no longer used (removed from 23 | -- its container for instance). Most of the time this will do 24 | -- nothing, but this procedure is useful if the Element_Type is an 25 | -- access type that you want to deallocate. 26 | 27 | Movable : Boolean := True; -- should be False for controlled types 28 | 29 | package Conts.Elements.Definite with SPARK_Mode is 30 | 31 | function Identity (E : Element_Type) return Element_Type is (E) with Inline; 32 | 33 | package Traits is new Conts.Elements.Traits 34 | (Element_Type => Element_Type, 35 | Stored_Type => Element_Type, 36 | Returned_Type => Element_Type, 37 | Constant_Returned_Type => Element_Type, 38 | Copyable => True, 39 | Movable => Movable, 40 | Release => Free, 41 | To_Stored => Identity, 42 | To_Returned => Identity, 43 | To_Constant_Returned => Identity, 44 | To_Element => Identity, 45 | Copy => Identity); 46 | 47 | end Conts.Elements.Definite; 48 | -------------------------------------------------------------------------------- /src/conts-elements-indefinite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Ada.Unchecked_Deallocation; 9 | 10 | package body Conts.Elements.Indefinite is 11 | 12 | procedure Unchecked_Free is new Ada.Unchecked_Deallocation 13 | (Element_Type, Element_Access); 14 | 15 | ------------- 16 | -- Release -- 17 | ------------- 18 | 19 | procedure Release (E : in out Element_Access) is 20 | begin 21 | if E /= null then 22 | Free (E.all); 23 | Unchecked_Free (E); 24 | end if; 25 | end Release; 26 | 27 | end Conts.Elements.Indefinite; 28 | -------------------------------------------------------------------------------- /src/conts-elements-indefinite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- This package provides a specialization of the Element_Traits package for 8 | -- use with indefinite type (i.e. their size might not be known at compile 9 | -- time). 10 | -- Such elements are returned as reference types, so containers will not 11 | -- return the element itself. This is in general more efficient and safer, 12 | -- and avoids copying potentially large elements. 13 | 14 | pragma Ada_2012; 15 | 16 | generic 17 | type Element_Type (<>) is private; 18 | 19 | with procedure Free (E : in out Element_Type) is null; 20 | -- This procedure is called when the element is removed from its 21 | -- container. 22 | 23 | with package Pool is new Conts.Pools (<>); 24 | 25 | package Conts.Elements.Indefinite is 26 | 27 | type Element_Access is access all Element_Type; 28 | for Element_Access'Storage_Pool use Pool.Pool; 29 | 30 | type Constant_Reference_Type 31 | (Element : not null access constant Element_Type) 32 | is null record with Implicit_Dereference => Element; 33 | -- ??? Would be nice if we could make this constrained by 34 | -- providing a default value for the discriminant, but this is 35 | -- illegal. 36 | 37 | type Reference_Type (Element : not null access Element_Type) 38 | is null record with Implicit_Dereference => Element; 39 | 40 | function To_Element_Access (E : Element_Type) return Element_Access 41 | is (new Element_Type'(E)) with Inline; 42 | function To_Constant_Ref (E : Element_Access) return Constant_Reference_Type 43 | is (Constant_Reference_Type'(Element => E)) with Inline; 44 | function To_Element (E : Constant_Reference_Type) return Element_Type 45 | is (E.Element.all) with Inline; 46 | function To_Ref (E : Element_Access) return Reference_Type 47 | is (Reference_Type'(Element => E)) with Inline; 48 | function To_Element (E : Reference_Type) return Element_Type 49 | is (E.Element.all) with Inline; 50 | function Copy (E : Element_Access) return Element_Access 51 | is (new Element_Type'(E.all)) with Inline; 52 | procedure Release (E : in out Element_Access) with Inline; 53 | 54 | package Traits is new Conts.Elements.Traits 55 | (Element_Type => Element_Type, 56 | Stored_Type => Element_Access, 57 | Returned_Type => Reference_Type, 58 | Constant_Returned_Type => Constant_Reference_Type, 59 | To_Stored => To_Element_Access, 60 | To_Returned => To_Ref, 61 | To_Constant_Returned => To_Constant_Ref, 62 | To_Element => To_Element, 63 | Copy => Copy, 64 | Release => Release, 65 | Copyable => False, -- would create aliases 66 | Movable => True); 67 | 68 | end Conts.Elements.Indefinite; 69 | -------------------------------------------------------------------------------- /src/conts-elements-indefinite_spark.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Ada.Unchecked_Deallocation; 9 | 10 | package body Conts.Elements.Indefinite_SPARK with SPARK_Mode => Off is 11 | 12 | package body Impl with SPARK_Mode => Off is 13 | procedure Unchecked_Free is new Ada.Unchecked_Deallocation 14 | (Element_Type, Element_Access); 15 | 16 | ---------- 17 | -- Free -- 18 | ---------- 19 | 20 | procedure Free (X : in out Element_Access) is 21 | begin 22 | Unchecked_Free (X); 23 | end Free; 24 | 25 | end Impl; 26 | 27 | end Conts.Elements.Indefinite_SPARK; 28 | -------------------------------------------------------------------------------- /src/conts-elements-indefinite_spark.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- An implementation of the elements traits compatible with SPARK. 8 | -- This package hides the access types. 9 | -- Reference types are not possible with SPARK, so this package always 10 | -- return a copy of the element (as opposed to what's done in 11 | -- conts-elements-indefinite.ads) 12 | 13 | pragma Ada_2012; 14 | 15 | generic 16 | type Element_Type (<>) is private; 17 | 18 | with package Pool is new Conts.Pools (<>); 19 | -- The storage pool used for Elements. 20 | 21 | package Conts.Elements.Indefinite_SPARK with SPARK_Mode => On is 22 | 23 | package Impl with SPARK_Mode => On is 24 | type Element_Access is private; 25 | 26 | subtype Constant_Reference_Type is Element_Type; 27 | -- References are not allowed in SPARK, use the element directly instead 28 | 29 | function To_Element_Access (E : Element_Type) return Element_Access 30 | with Inline, 31 | Global => null, 32 | Post => To_Constant_Reference_Type (To_Element_Access'Result) = E; 33 | 34 | function To_Constant_Reference_Type 35 | (E : Element_Access) return Constant_Reference_Type 36 | with Inline, 37 | Global => null; 38 | 39 | function To_Element (E : Constant_Reference_Type) return Element_Type is 40 | (E) 41 | with Inline, 42 | Global => null; 43 | 44 | function Copy (E : Element_Access) return Element_Access 45 | with Inline, 46 | Global => null; 47 | 48 | procedure Free (X : in out Element_Access) with Global => null; 49 | 50 | private 51 | pragma SPARK_Mode (Off); 52 | 53 | type Element_Access is access all Element_Type; 54 | 55 | for Element_Access'Storage_Pool use Pool.Pool; 56 | 57 | function To_Element_Access (E : Element_Type) return Element_Access 58 | is (new Element_Type'(E)); 59 | 60 | function To_Element_Type (E : Element_Access) return Element_Type 61 | is (E.all); 62 | 63 | function Copy (E : Element_Access) return Element_Access 64 | is (new Element_Type'(E.all)); 65 | 66 | function To_Constant_Reference_Type 67 | (E : Element_Access) return Constant_Reference_Type 68 | is (E.all); 69 | end Impl; 70 | 71 | package Traits is new Conts.Elements.Traits 72 | (Element_Type => Element_Type, 73 | Stored_Type => Impl.Element_Access, 74 | Returned_Type => Impl.Constant_Reference_Type, 75 | Constant_Returned_Type => Impl.Constant_Reference_Type, 76 | To_Stored => Impl.To_Element_Access, 77 | To_Returned => Impl.To_Constant_Reference_Type, 78 | To_Constant_Returned => Impl.To_Constant_Reference_Type, 79 | To_Element => Impl.To_Element, 80 | Copy => Impl.Copy, 81 | Copyable => False, 82 | Movable => False, 83 | Release => Impl.Free); 84 | 85 | end Conts.Elements.Indefinite_SPARK; 86 | -------------------------------------------------------------------------------- /src/conts-elements-null_elements.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- A special kind of elements that store nothing. 8 | -- This is only useful to instantiate some containers, for instance a graph, 9 | -- when no extra information needs to be added to the vertices. 10 | 11 | pragma Ada_2012; 12 | 13 | package Conts.Elements.Null_Elements is 14 | 15 | type Null_Element is null record; 16 | 17 | No_Element : constant Null_Element := (others => <>); 18 | 19 | function Identity (E : Null_Element) return Null_Element is (E) with Inline; 20 | package Traits is new Conts.Elements.Traits 21 | (Element_Type => Null_Element, 22 | Stored_Type => Null_Element, 23 | Returned_Type => Null_Element, 24 | Constant_Returned_Type => Null_Element, 25 | Copyable => True, 26 | Movable => True, 27 | To_Stored => Identity, 28 | To_Returned => Identity, 29 | To_Constant_Returned => Identity, 30 | To_Element => Identity, 31 | Copy => Identity); 32 | 33 | end Conts.Elements.Null_Elements; 34 | -------------------------------------------------------------------------------- /src/conts-elements.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- This package describes the types of elements stored in a container. We 8 | -- want to handle both constrained and unconstrained elements, which is done 9 | -- by providing subprograms to convert from one type to the other (presumably, 10 | -- but not limited to, using access types) 11 | 12 | pragma Ada_2012; 13 | 14 | package Conts.Elements with SPARK_Mode is 15 | 16 | generic 17 | type Element_Type (<>) is private; 18 | -- The element type visible to the user (in parameter to Append for 19 | -- instance). 20 | 21 | type Stored_Type is private; 22 | -- The type of elements stored internally. This must be unconstrained. 23 | 24 | type Returned_Type (<>) is private; 25 | -- The type of elements returned by getters. Various possibilities exit: 26 | -- you could return an Element_Type (which might be big and thus slow), 27 | -- a Stored_Type (which might be an access type, and thus unsafe), or a 28 | -- Reference type as introduced by Ada 2012. Other variations are of 29 | -- course possible. 30 | 31 | type Constant_Returned_Type (<>) is private; 32 | -- The type of elements returned by getters. As opposed to 33 | -- Returned_Type, this one guarantees that the type cannot be modified 34 | -- via this value (so it can't be a direct pointer, not a reference_type 35 | -- for which the discriminant is not "constant"). This is used in 36 | -- particular for the Constant_Indexing aspect. 37 | 38 | with function To_Stored (E : Element_Type) return Stored_Type; 39 | with function To_Returned (E : Stored_Type) return Returned_Type; 40 | with function To_Constant_Returned 41 | (E : Stored_Type) return Constant_Returned_Type; 42 | with function To_Element 43 | (E : Constant_Returned_Type) return Element_Type; 44 | -- Converting between the types 45 | 46 | with procedure Release (E : in out Stored_Type) is null; 47 | -- Called whenever an element is removed from the container. 48 | -- Memory can be freed at this point, and other resources can be closed. 49 | 50 | with function Copy (E : Stored_Type) return Stored_Type; 51 | 52 | Copyable : Boolean := False; 53 | -- True when a stored_type variable can be copied (duplicated) in 54 | -- memory using the standard Ada operations (assigning an array 55 | -- for instance), including Adjust and Finalize call when 56 | -- applicable. 57 | -- False when an explicit Copy operation needs to be performed. This 58 | -- is safer in general, but less efficient. 59 | -- It should be set to False when Stored_Type is an access type, 60 | -- since copying would create an alias and it would be impossible to 61 | -- know who the owner of the element is and when to free it. 62 | 63 | Movable : Boolean := True; 64 | -- If True, a stored_Element can be moved in memory (as part of a 65 | -- realloc call for instance), bypassing Adjust and Finalize calls 66 | -- on controlled types. 67 | -- 68 | -- This is very similar to Copyable, but no aliasing issue occurs, so 69 | -- this should be safe for access types. 70 | -- When an element is not Movable, a copy is made (via Copy), and the 71 | -- original element is deleted. 72 | 73 | package Traits is 74 | subtype Element is Element_Type; 75 | subtype Stored is Stored_Type; 76 | subtype Returned is Returned_Type; 77 | subtype Constant_Returned is Constant_Returned_Type; 78 | 79 | function To_Elem (E : Constant_Returned_Type) return Element_Type 80 | renames To_Element; 81 | 82 | function Identity (E : Returned_Type) return Returned_Type is (E); 83 | -- Convenience function 84 | 85 | end Traits; 86 | 87 | end Conts.Elements; 88 | -------------------------------------------------------------------------------- /src/conts-functional-base.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- Functional containers are neither controlled nor limited. This is safe as 8 | -- no primitives is provided to modify them. 9 | -- Memory allocated inside functional containers is never reclaimed. 10 | 11 | pragma Ada_2012; 12 | with Conts; use Conts; 13 | 14 | private generic 15 | type Index_Type is (<>); 16 | -- To avoid Constraint_Error being raised at runtime, Index_Type'Base 17 | -- should have at least one more element at the left than Index_Type. 18 | 19 | type Element_Type (<>) is private; 20 | with function "=" (Left, Right : Element_Type) return Boolean is <>; 21 | package Conts.Functional.Base with SPARK_Mode => Off is 22 | 23 | pragma Assertion_Policy 24 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 25 | 26 | subtype Extended_Index is Index_Type'Base range 27 | Index_Type'Pred (Index_Type'First) .. Index_Type'Last; 28 | 29 | type Container is private; 30 | 31 | function "=" (C1, C2 : Container) return Boolean; 32 | -- Return True if C1 and C2 contain the same elements at the same position 33 | 34 | function Length (C : Container) return Count_Type; 35 | -- Number of elements stored in C. 36 | 37 | function Get (C : Container; I : Index_Type) return Element_Type; 38 | -- Access to the element at index I in C. 39 | 40 | function Set (C : Container; I : Index_Type; E : Element_Type) 41 | return Container; 42 | -- Return a new container which is equal to C except for the element at 43 | -- index I which is set to E. 44 | 45 | function Add (C : Container; E : Element_Type) return Container; 46 | -- Return a new container which is C appended with E. 47 | 48 | function Find (C : Container; E : Element_Type) return Extended_Index; 49 | -- Return the first index for which the element stored in C is I. 50 | -- If there are no such indexes, return Extended_Index'First. 51 | 52 | -------------------- 53 | -- Set Operations -- 54 | -------------------- 55 | 56 | function "<=" (C1, C2 : Container) return Boolean; 57 | -- Return True if every element of C1 is in C2 58 | 59 | function Num_Overlaps (C1, C2 : Container) return Count_Type; 60 | -- Return the number of elements that are both in 61 | 62 | function Union (C1, C2 : Container) return Container; 63 | -- Return a container which is C1 plus all the elements of C2 that are not 64 | -- in C1. 65 | 66 | function Intersection (C1, C2 : Container) return Container; 67 | -- Return a container which is C1 minus all the elements that are also in 68 | -- C2. 69 | 70 | private 71 | type Element_Access is access all Element_Type; 72 | type Element_Array is 73 | array (Positive_Count_Type range <>) of Element_Access; 74 | type Element_Array_Access is not null access 75 | Element_Array; 76 | Empty_Element_Array_Access : constant Element_Array_Access := 77 | new Element_Array'(1 .. 0 => null); 78 | 79 | type Container is record 80 | Elements : Element_Array_Access := Empty_Element_Array_Access; 81 | end record; 82 | end Conts.Functional.Base; 83 | -------------------------------------------------------------------------------- /src/conts-functional-maps.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | package body Conts.Functional.Maps with SPARK_Mode => Off is 9 | use Key_Containers; 10 | use Element_Containers; 11 | 12 | pragma Assertion_Policy 13 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 14 | 15 | --------- 16 | -- "=" -- 17 | --------- 18 | 19 | function "=" (M1, M2 : Map) return Boolean is 20 | (M1.Keys <= M2.Keys and M2 <= M1); 21 | 22 | ---------- 23 | -- "<=" -- 24 | ---------- 25 | 26 | function "<=" (M1, M2 : Map) return Boolean is 27 | I2 : Count_Type; 28 | begin 29 | for I1 in 1 .. Length (M1.Keys) loop 30 | I2 := Find (M2.Keys, Get (M1.Keys, I1)); 31 | if I2 = 0 32 | or else Get (M2.Elements, I2) /= Get (M1.Elements, I1) 33 | then 34 | return False; 35 | end if; 36 | end loop; 37 | return True; 38 | end "<="; 39 | 40 | --------- 41 | -- Add -- 42 | --------- 43 | 44 | function Add (M : Map; K : Key_Type; E : Element_Type) return Map is 45 | (Keys => Add (M.Keys, K), 46 | Elements => Add (M.Elements, E)); 47 | 48 | --------- 49 | -- Get -- 50 | --------- 51 | 52 | function Get (M : Map; K : Key_Type) return Element_Type is 53 | (Get (M.Elements, Find (M.Keys, K))); 54 | 55 | ------------ 56 | -- Is_Add -- 57 | ------------ 58 | 59 | function Is_Add 60 | (M : Map; K : Key_Type; E : Element_Type; Result : Map) return Boolean 61 | is 62 | (not Mem (M, K) 63 | and then Mem (Result, K) and then Get (Result, K) = E 64 | and then (for all K of M => Mem (Result, K) 65 | and then Get (Result, K) = Get (M, K)) 66 | and then (for all KK of Result => KK = K or Mem (M, KK))); 67 | 68 | -------------- 69 | -- Is_Empty -- 70 | -------------- 71 | 72 | function Is_Empty (M : Map) return Boolean is 73 | (Length (M.Keys) = 0); 74 | 75 | ------------ 76 | -- Is_Set -- 77 | ------------ 78 | 79 | function Is_Set 80 | (M : Map; K : Key_Type; E : Element_Type; Result : Map) return Boolean 81 | is 82 | (Mem (M, K) 83 | and then Mem (Result, K) 84 | and then Get (Result, K) = E 85 | and then (for all KK of M => Mem (Result, KK) 86 | and then 87 | (if K /= KK 88 | then Get (Result, KK) = Get (M, KK))) 89 | and then (for all K of Result => Mem (M, K))); 90 | 91 | ------------ 92 | -- Length -- 93 | ------------ 94 | 95 | function Length (M : Map) return Count_Type is (Length (M.Elements)); 96 | 97 | --------- 98 | -- Mem -- 99 | --------- 100 | 101 | function Mem (M : Map; K : Key_Type) return Boolean is 102 | (Find (M.Keys, K) > 0); 103 | 104 | --------- 105 | -- Set -- 106 | --------- 107 | 108 | function Set (M : Map; K : Key_Type; E : Element_Type) return Map is 109 | (Keys => M.Keys, Elements => Set (M.Elements, Find (M.Keys, K), E)); 110 | end Conts.Functional.Maps; 111 | -------------------------------------------------------------------------------- /src/conts-functional-sequences.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | package body Conts.Functional.Sequences with SPARK_Mode => Off is 9 | use Containers; 10 | 11 | pragma Assertion_Policy 12 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 13 | 14 | --------- 15 | -- "=" -- 16 | --------- 17 | 18 | function "=" (S1, S2 : Sequence) return Boolean is 19 | (S1.Content = S2.Content); 20 | 21 | --------- 22 | -- Add -- 23 | --------- 24 | 25 | function Add (S : Sequence; E : Element_Type) return Sequence is 26 | (Content => Add (S.Content, E)); 27 | 28 | --------- 29 | -- Get -- 30 | --------- 31 | 32 | function Get (S : Sequence; N : Extended_Index) return Element_Type is 33 | (Get (S.Content, N)); 34 | 35 | ------------ 36 | -- Is_Add -- 37 | ------------ 38 | 39 | function Is_Add 40 | (S : Sequence; E : Element_Type; Result : Sequence) return Boolean is 41 | (Length (Result) = Length (S) + 1 42 | and then Get (Result, Index_Type'Val 43 | ((Index_Type'Pos (Index_Type'First) - 1) + 44 | Length (Result))) = E 45 | and then 46 | (for all M in Index_Type'First .. 47 | (Index_Type'Val 48 | ((Index_Type'Pos (Index_Type'First) - 1) + Length (S))) => 49 | Get (Result, M) = Get (S, M))); 50 | 51 | ------------ 52 | -- Is_Set -- 53 | ------------ 54 | 55 | function Is_Set 56 | (S : Sequence; N : Index_Type; E : Element_Type; Result : Sequence) 57 | return Boolean is 58 | (N in Index_Type'First .. 59 | (Index_Type'Val 60 | ((Index_Type'Pos (Index_Type'First) - 1) + Length (S))) 61 | and then Length (Result) = Length (S) 62 | and then Get (Result, N) = E 63 | and then 64 | (for all M in Index_Type'First .. 65 | (Index_Type'Val 66 | ((Index_Type'Pos (Index_Type'First) - 1) + Length (S))) => 67 | (if M /= N then Get (Result, M) = Get (S, M)))); 68 | 69 | ---------- 70 | -- Last -- 71 | ---------- 72 | 73 | function Last (S : Sequence) return Extended_Index is 74 | (Index_Type'Val ((Index_Type'Pos (Index_Type'First) - 1) + Length (S))); 75 | 76 | ------------ 77 | -- Length -- 78 | ------------ 79 | 80 | function Length (S : Sequence) return Count_Type is 81 | (Length (S.Content)); 82 | 83 | --------- 84 | -- Set -- 85 | --------- 86 | 87 | function Set (S : Sequence; N : Index_Type; E : Element_Type) 88 | return Sequence is 89 | (Content => Set (S.Content, N, E)); 90 | end Conts.Functional.Sequences; 91 | -------------------------------------------------------------------------------- /src/conts-functional-sets.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | 9 | package body Conts.Functional.Sets with SPARK_Mode => Off is 10 | use Containers; 11 | 12 | pragma Assertion_Policy 13 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 14 | 15 | --------- 16 | -- "=" -- 17 | --------- 18 | 19 | function "=" (S1, S2 : Set) return Boolean is 20 | (S1.Content <= S2.Content and S2.Content <= S1.Content); 21 | 22 | ---------- 23 | -- "<=" -- 24 | ---------- 25 | 26 | function "<=" (S1, S2 : Set) return Boolean is (S1.Content <= S2.Content); 27 | 28 | --------- 29 | -- Add -- 30 | --------- 31 | 32 | function Add (S : Set; E : Element_Type) return Set is 33 | (Content => Add (S.Content, E)); 34 | 35 | ------------ 36 | -- Length -- 37 | ------------ 38 | 39 | function Length (S : Set) return Count_Type is (Length (S.Content)); 40 | 41 | --------- 42 | -- Mem -- 43 | --------- 44 | 45 | function Mem (S : Set; E : Element_Type) return Boolean is 46 | (Find (S.Content, E) > 0); 47 | 48 | ------------------ 49 | -- Num_Overlaps -- 50 | ------------------ 51 | 52 | function Num_Overlaps (S1, S2 : Set) return Count_Type is 53 | (Num_Overlaps (S1.Content, S2.Content)); 54 | 55 | ------------------ 56 | -- Intersection -- 57 | ------------------ 58 | 59 | function Intersection (S1, S2 : Set) return Set is 60 | (Content => Intersection (S1.Content, S2.Content)); 61 | 62 | ------------ 63 | -- Is_Add -- 64 | ------------ 65 | 66 | function Is_Add (S : Set; E : Element_Type; Result : Set) return Boolean 67 | is 68 | (Mem (Result, E) 69 | and (for all F of Result => Mem (S, F) or F = E) 70 | and (for all E of S => Mem (Result, E))); 71 | 72 | -------------- 73 | -- Is_Empty -- 74 | -------------- 75 | 76 | function Is_Empty (S : Set) return Boolean is (Length (S.Content) = 0); 77 | 78 | --------------------- 79 | -- Is_Intersection -- 80 | --------------------- 81 | 82 | function Is_Intersection (S1, S2, Result : Set) return Boolean is 83 | ((for all E of Result => 84 | Mem (S1, E) and Mem (S2, E)) 85 | and (for all E of S1 => 86 | (if Mem (S2, E) then Mem (Result, E)))); 87 | 88 | -------------- 89 | -- Is_Union -- 90 | -------------- 91 | 92 | function Is_Union (S1, S2, Result : Set) return Boolean is 93 | ((for all E of Result => Mem (S1, E) or Mem (S2, E)) 94 | and (for all E of S1 => Mem (Result, E)) 95 | and (for all E of S2 => Mem (Result, E))); 96 | 97 | ----------- 98 | -- Union -- 99 | ----------- 100 | 101 | function Union (S1, S2 : Set) return Set is 102 | (Content => Union (S1.Content, S2.Content)); 103 | end Conts.Functional.Sets; 104 | -------------------------------------------------------------------------------- /src/conts-functional.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | 9 | package Conts.Functional with SPARK_Mode => On is 10 | 11 | end Conts.Functional; 12 | -------------------------------------------------------------------------------- /src/conts-graphs-components.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Conts.Properties; 9 | 10 | package Conts.Graphs.Components is 11 | 12 | generic 13 | with package Graphs is new Conts.Graphs.Traits (<>); 14 | with package Component_Maps is new Conts.Properties.Maps 15 | (Key_Type => Graphs.Vertex, Element_Type => Integer, others => <>); 16 | procedure Strongly_Connected_Components 17 | (G : Graphs.Graph; 18 | Components : out Component_Maps.Map; 19 | Components_Count : out Positive); 20 | -- Compute the strongly components of the graph: 21 | -- These are maximal sets of vertices such that for every pair of 22 | -- vertices u and v in the set, there exists a path from u to v and 23 | -- a path from v to u. 24 | -- Each vertex belongs to one, and only one, such component. This 25 | -- algorithm sets the index of that component in the Components map, 26 | -- and returns the number of components that were found. In the 27 | -- Components, the indexes are in the range 1 .. Components_Count. 28 | -- 29 | -- Each vertex that is not part of a vertex forms its own component. 30 | -- 31 | -- The implementation uses the Cheriyan-Mehlhorn-Gabow algorithm. 32 | -- Complexity is O( |edges| + |vertices| ) 33 | 34 | end Conts.Graphs.Components; 35 | -------------------------------------------------------------------------------- /src/conts-lists-definite_bounded.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- Bounded controlled lists of constrained elements 8 | -- This package is compatible with SPARK. 9 | 10 | pragma Ada_2012; 11 | with Conts.Elements.Definite; 12 | with Conts.Lists.Generics; 13 | with Conts.Lists.Storage.Bounded_Definite; 14 | with Conts.Properties.SPARK; 15 | 16 | generic 17 | type Element_Type is private; 18 | with procedure Free (E : in out Element_Type) is null; 19 | package Conts.Lists.Definite_Bounded with SPARK_Mode is 20 | 21 | pragma Assertion_Policy 22 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 23 | 24 | package Elements is new Conts.Elements.Definite 25 | (Element_Type, Free => Free); 26 | package Storage is new Conts.Lists.Storage.Bounded_Definite 27 | (Elements => Elements); 28 | package Lists is new Conts.Lists.Generics (Storage.Traits); 29 | 30 | subtype Cursor is Lists.Cursor; 31 | subtype List is Lists.List; 32 | 33 | subtype Element_Sequence is Lists.Impl.M.Sequence with Ghost; 34 | subtype Cursor_Position_Map is Lists.Impl.P_Map with Ghost; 35 | 36 | package Cursors renames Lists.Cursors; 37 | package Maps renames Lists.Maps; 38 | 39 | package Content_Models is new Conts.Properties.SPARK.Content_Models 40 | (Map_Type => Lists.Base_List'Class, 41 | Element_Type => Element_Type, 42 | Model_Type => Element_Sequence, 43 | Index_Type => Lists.Impl.M.Extended_Index, 44 | Model => Lists.Impl.Model, 45 | Get => Lists.Impl.M.Get, 46 | First => Lists.Impl.M.First, 47 | Last => Lists.Impl.M.Last); 48 | 49 | end Conts.Lists.Definite_Bounded; 50 | -------------------------------------------------------------------------------- /src/conts-lists-definite_unbounded.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- Unbounded controlled lists of constrained elements. 8 | -- Compared with standard Ada containers, this is saving half of the memory 9 | -- allocations, so much more efficient in general. 10 | 11 | pragma Ada_2012; 12 | with Ada.Finalization; 13 | with Conts.Elements.Definite; 14 | with Conts.Lists.Generics; 15 | with Conts.Lists.Storage.Unbounded; 16 | 17 | generic 18 | type Element_Type is private; 19 | package Conts.Lists.Definite_Unbounded is 20 | 21 | pragma Assertion_Policy 22 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 23 | 24 | package Elements is new Conts.Elements.Definite (Element_Type); 25 | package Storage is new Conts.Lists.Storage.Unbounded 26 | (Elements => Elements.Traits, 27 | Container_Base_Type => Ada.Finalization.Controlled, 28 | Pool => Conts.Global_Pool); 29 | package Lists is new Conts.Lists.Generics (Storage.Traits); 30 | 31 | subtype Cursor is Lists.Cursor; 32 | subtype List is Lists.List; 33 | 34 | package Cursors renames Lists.Cursors; 35 | package Maps renames Lists.Maps; 36 | 37 | end Conts.Lists.Definite_Unbounded; 38 | -------------------------------------------------------------------------------- /src/conts-lists-indefinite_unbounded.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- Unbounded controlled lists of unconstrained elements 8 | 9 | pragma Ada_2012; 10 | with Ada.Finalization; 11 | with Conts.Elements.Indefinite; 12 | with Conts.Lists.Generics; 13 | with Conts.Lists.Storage.Unbounded; 14 | 15 | generic 16 | type Element_Type (<>) is private; 17 | with procedure Free (E : in out Element_Type) is null; 18 | package Conts.Lists.Indefinite_Unbounded is 19 | 20 | pragma Assertion_Policy 21 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 22 | 23 | package Elements is new Conts.Elements.Indefinite 24 | (Element_Type, Free => Free, Pool => Conts.Global_Pool); 25 | package Storage is new Conts.Lists.Storage.Unbounded 26 | (Elements => Elements.Traits, 27 | Container_Base_Type => Ada.Finalization.Controlled, 28 | Pool => Conts.Global_Pool); 29 | package Lists is new Conts.Lists.Generics (Storage.Traits); 30 | 31 | subtype Cursor is Lists.Cursor; 32 | subtype List is Lists.List; 33 | subtype Constant_Returned is Elements.Traits.Constant_Returned; 34 | 35 | package Cursors renames Lists.Cursors; 36 | package Maps renames Lists.Maps; 37 | 38 | end Conts.Lists.Indefinite_Unbounded; 39 | -------------------------------------------------------------------------------- /src/conts-lists-indefinite_unbounded_spark.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | 9 | package body Conts.Lists.Indefinite_Unbounded_SPARK with SPARK_Mode => Off is 10 | 11 | ---------- 12 | -- Copy -- 13 | ---------- 14 | 15 | function Copy (Self : List'Class) return List'Class is 16 | begin 17 | return Result : List do 18 | Result.Assign (Self); 19 | end return; 20 | end Copy; 21 | 22 | end Conts.Lists.Indefinite_Unbounded_SPARK; 23 | -------------------------------------------------------------------------------- /src/conts-lists-indefinite_unbounded_spark.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- Unbounded lists of unconstrained elements. 8 | -- Cursors are indexes into an array, to be able to write post-conditions 9 | -- and for added safety 10 | 11 | pragma Ada_2012; 12 | with Conts.Elements.Indefinite_SPARK; 13 | with Conts.Lists.Storage.Unbounded_SPARK; 14 | with Conts.Lists.Generics; 15 | with Conts.Properties.SPARK; 16 | 17 | generic 18 | type Element_Type (<>) is private; 19 | -- Element_Type must not be a controlled type that needs to be 20 | -- Adjusted when it is moved in memory, since the list will use the 21 | -- realloc() system call. 22 | 23 | package Conts.Lists.Indefinite_Unbounded_SPARK with SPARK_Mode is 24 | 25 | pragma Assertion_Policy 26 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 27 | 28 | package Elements is new Conts.Elements.Indefinite_SPARK 29 | (Element_Type, Pool => Conts.Global_Pool); 30 | package Storage is new Conts.Lists.Storage.Unbounded_SPARK 31 | (Elements => Elements.Traits, 32 | Container_Base_Type => Limited_Base); 33 | package Lists is new Conts.Lists.Generics (Storage.Traits); 34 | subtype Constant_Returned is Elements.Traits.Constant_Returned; 35 | 36 | subtype Cursor is Lists.Cursor; 37 | subtype List is Lists.List; 38 | 39 | subtype Element_Sequence is Lists.Impl.M.Sequence with Ghost; 40 | subtype Cursor_Position_Map is Lists.Impl.P_Map with Ghost; 41 | 42 | use type Element_Sequence; 43 | 44 | function Copy (Self : List'Class) return List'Class; 45 | -- Return a deep copy of Self 46 | -- Complexity: O(n) 47 | 48 | package Cursors renames Lists.Cursors; 49 | package Maps renames Lists.Maps; 50 | 51 | package Content_Models is new Conts.Properties.SPARK.Content_Models 52 | (Map_Type => Lists.Base_List'Class, 53 | Element_Type => Element_Type, 54 | Model_Type => Element_Sequence, 55 | Index_Type => Lists.Impl.M.Extended_Index, 56 | Model => Lists.Impl.Model, 57 | Get => Lists.Impl.M.Get, 58 | First => Lists.Impl.M.First, 59 | Last => Lists.Impl.M.Last); 60 | 61 | end Conts.Lists.Indefinite_Unbounded_SPARK; 62 | -------------------------------------------------------------------------------- /src/conts-lists-storage-bounded.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | 9 | package body Conts.Lists.Storage.Bounded with SPARK_Mode => Off is 10 | 11 | package body Impl is 12 | -------------- 13 | -- Allocate -- 14 | -------------- 15 | 16 | procedure Allocate 17 | (Self : in out Container'Class; 18 | Element : Stored_Type; 19 | N : out Node_Access) 20 | is 21 | begin 22 | if Self.Free > 0 then 23 | N := Node_Access (Self.Free); 24 | Self.Free := Integer (Self.Nodes (Count_Type (N)).Next); 25 | else 26 | N := Node_Access (abs Self.Free + 1); 27 | Self.Free := Self.Free - 1; 28 | end if; 29 | 30 | if Count_Type (N) <= Self.Nodes'Last then 31 | Self.Nodes (Count_Type (N)) := 32 | (Element => Element, 33 | Previous => Null_Node_Access, 34 | Next => Null_Node_Access); 35 | else 36 | N := Null_Node_Access; 37 | end if; 38 | end Allocate; 39 | 40 | ----------------- 41 | -- Get_Element -- 42 | ----------------- 43 | 44 | function Get_Element 45 | (Self : Container'Class; N : Node_Access) return Stored_Type is 46 | begin 47 | return Self.Nodes (Count_Type (N)).Element; 48 | end Get_Element; 49 | 50 | -------------- 51 | -- Get_Next -- 52 | -------------- 53 | 54 | function Get_Next 55 | (Self : Container'Class; N : Node_Access) return Node_Access is 56 | begin 57 | return Self.Nodes (Count_Type (N)).Next; 58 | end Get_Next; 59 | 60 | ------------------ 61 | -- Get_Previous -- 62 | ------------------ 63 | 64 | function Get_Previous 65 | (Self : Container'Class; N : Node_Access) return Node_Access is 66 | begin 67 | return Self.Nodes (Count_Type (N)).Previous; 68 | end Get_Previous; 69 | 70 | ------------------ 71 | -- Set_Previous -- 72 | ------------------ 73 | 74 | procedure Set_Previous 75 | (Self : in out Container'Class; N, Prev : Node_Access) is 76 | begin 77 | Self.Nodes (Count_Type (N)).Previous := Prev; 78 | end Set_Previous; 79 | 80 | -------------- 81 | -- Set_Next -- 82 | -------------- 83 | 84 | procedure Set_Next 85 | (Self : in out Container'Class; N, Next : Node_Access) is 86 | begin 87 | Self.Nodes (Count_Type (N)).Next := Next; 88 | end Set_Next; 89 | 90 | ----------------- 91 | -- Set_Element -- 92 | ----------------- 93 | 94 | procedure Set_Element 95 | (Self : in out Impl.Container'Class; 96 | N : Node_Access; 97 | E : Stored_Type) 98 | is 99 | begin 100 | Self.Nodes (Count_Type (N)).Element := E; 101 | end Set_Element; 102 | 103 | ------------ 104 | -- Assign -- 105 | ------------ 106 | 107 | procedure Assign 108 | (Nodes : in out Container'Class; 109 | Source : Container'Class; 110 | New_Head : out Node_Access; 111 | Old_Head : Node_Access; 112 | New_Tail : out Node_Access; 113 | Old_Tail : Node_Access) 114 | is 115 | N : Node_Access; 116 | begin 117 | -- Indices will remain the same 118 | New_Head := Old_Head; 119 | New_Tail := Old_Tail; 120 | 121 | Nodes.Free := Source.Free; 122 | 123 | -- We need to copy each of the elements. 124 | 125 | if not Elements.Copyable then 126 | N := Old_Head; 127 | while N /= Null_Node_Access loop 128 | declare 129 | Value : Node renames Source.Nodes (Count_Type (N)); 130 | begin 131 | Nodes.Nodes (Count_Type (N)) := 132 | (Element => Elements.Copy (Value.Element), 133 | Next => Value.Next, 134 | Previous => Value.Previous); 135 | N := Value.Next; 136 | end; 137 | end loop; 138 | 139 | else 140 | Nodes.Nodes := Source.Nodes; 141 | end if; 142 | end Assign; 143 | 144 | end Impl; 145 | 146 | end Conts.Lists.Storage.Bounded; 147 | -------------------------------------------------------------------------------- /src/conts-lists-storage-bounded.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- The implementation for bounded list of elements. 8 | -- Such a list allocates its nodes in an array, so that no memory allocation 9 | -- is needed. The implementation therefore looks like a vector, but since we 10 | -- need to be able to insert in the middle of the list in constant time, the 11 | -- nodes need to store extra information. 12 | 13 | pragma Ada_2012; 14 | with Conts.Elements; 15 | 16 | generic 17 | with package Elements is new Conts.Elements.Traits (<>); 18 | 19 | type Container_Base_Type is abstract tagged limited private; 20 | -- The base type for the container of nodes. 21 | -- Since this type is eventually also used as the base type for the list 22 | -- itself, this is a way to make lists either controlled or limited. 23 | 24 | package Conts.Lists.Storage.Bounded with SPARK_Mode => Off is 25 | 26 | pragma Assertion_Policy 27 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 28 | 29 | subtype Stored_Type is Elements.Stored_Type; 30 | 31 | package Impl is 32 | type Container (Capacity : Count_Type) 33 | is abstract new Container_Base_Type with private; 34 | type Node_Access is new Count_Type; 35 | Null_Node_Access : constant Node_Access := 0; 36 | 37 | procedure Allocate 38 | (Self : in out Impl.Container'Class; 39 | Element : Stored_Type; 40 | N : out Impl.Node_Access); 41 | function Get_Element 42 | (Self : Impl.Container'Class; 43 | N : Impl.Node_Access) return Stored_Type with Inline; 44 | function Get_Next 45 | (Self : Impl.Container'Class; 46 | N : Impl.Node_Access) return Impl.Node_Access with Inline; 47 | function Get_Previous 48 | (Self : Impl.Container'Class; 49 | N : Impl.Node_Access) return Impl.Node_Access with Inline; 50 | procedure Set_Previous 51 | (Self : in out Impl.Container'Class; 52 | N, Prev : Impl.Node_Access) with Inline; 53 | procedure Set_Next 54 | (Self : in out Impl.Container'Class; 55 | N, Next : Impl.Node_Access) with Inline; 56 | procedure Set_Element 57 | (Self : in out Impl.Container'Class; 58 | N : Node_Access; 59 | E : Stored_Type) with Inline; 60 | function Capacity (Self : Impl.Container'Class) return Count_Type 61 | is (Self.Capacity) with Inline; 62 | procedure Assign 63 | (Nodes : in out Impl.Container'Class; 64 | Source : Impl.Container'Class; 65 | New_Head : out Impl.Node_Access; 66 | Old_Head : Impl.Node_Access; 67 | New_Tail : out Impl.Node_Access; 68 | Old_Tail : Impl.Node_Access) 69 | with Pre => Nodes.Capacity >= Source.Capacity; 70 | -- See description in Conts.Lists.Nodes 71 | 72 | private 73 | type Node is record 74 | Element : Stored_Type; 75 | Previous, Next : Node_Access := Null_Node_Access; 76 | end record; 77 | 78 | type Nodes_Array is array (Count_Type range <>) of Node; 79 | 80 | type Container (Capacity : Count_Type) is 81 | abstract new Container_Base_Type 82 | with record 83 | Free : Integer := 0; -- head of free nodes list 84 | -- For a negative value, its absolute value points to the first free 85 | -- element 86 | 87 | Nodes : Nodes_Array (1 .. Capacity); 88 | end record; 89 | end Impl; 90 | 91 | use Impl; 92 | package Traits is new Conts.Lists.Storage.Traits 93 | (Elements => Elements, 94 | Container => Impl.Container, 95 | Node_Access => Impl.Node_Access, 96 | Null_Access => Impl.Null_Node_Access, 97 | Allocate => Allocate); 98 | end Conts.Lists.Storage.Bounded; 99 | -------------------------------------------------------------------------------- /src/conts-lists-storage-bounded_definite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | 9 | package body Conts.Lists.Storage.Bounded_Definite with SPARK_Mode => Off is 10 | 11 | package body Impl is 12 | -------------- 13 | -- Allocate -- 14 | -------------- 15 | 16 | procedure Allocate 17 | (Self : in out Container'Class; 18 | Element : Stored_Type; 19 | N : out Node_Access) 20 | is 21 | begin 22 | if Self.Free > 0 then 23 | N := Node_Access (Self.Free); 24 | Self.Free := Integer (Self.Nodes (Count_Type (N)).Next); 25 | else 26 | N := Node_Access (abs Self.Free + 1); 27 | Self.Free := Self.Free - 1; 28 | end if; 29 | 30 | if Count_Type (N) <= Self.Nodes'Last then 31 | Self.Nodes (Count_Type (N)) := 32 | (Element => Element, 33 | Previous => Null_Node_Access, 34 | Next => Null_Node_Access); 35 | else 36 | N := Null_Node_Access; 37 | end if; 38 | end Allocate; 39 | 40 | ----------------- 41 | -- Get_Element -- 42 | ----------------- 43 | 44 | function Get_Element 45 | (Self : Container'Class; N : Node_Access) return Stored_Type is 46 | begin 47 | return Self.Nodes (Count_Type (N)).Element; 48 | end Get_Element; 49 | 50 | -------------- 51 | -- Get_Next -- 52 | -------------- 53 | 54 | function Get_Next 55 | (Self : Container'Class; N : Node_Access) return Node_Access is 56 | begin 57 | return Self.Nodes (Count_Type (N)).Next; 58 | end Get_Next; 59 | 60 | ------------------ 61 | -- Get_Previous -- 62 | ------------------ 63 | 64 | function Get_Previous 65 | (Self : Container'Class; N : Node_Access) return Node_Access is 66 | begin 67 | return Self.Nodes (Count_Type (N)).Previous; 68 | end Get_Previous; 69 | 70 | ------------------ 71 | -- Set_Previous -- 72 | ------------------ 73 | 74 | procedure Set_Previous 75 | (Self : in out Container'Class; N, Prev : Node_Access) is 76 | begin 77 | Self.Nodes (Count_Type (N)).Previous := Prev; 78 | end Set_Previous; 79 | 80 | -------------- 81 | -- Set_Next -- 82 | -------------- 83 | 84 | procedure Set_Next 85 | (Self : in out Container'Class; N, Next : Node_Access) is 86 | begin 87 | Self.Nodes (Count_Type (N)).Next := Next; 88 | end Set_Next; 89 | 90 | ----------------- 91 | -- Set_Element -- 92 | ----------------- 93 | 94 | procedure Set_Element 95 | (Self : in out Impl.Container'Class; 96 | N : Node_Access; 97 | E : Stored_Type) is 98 | begin 99 | Self.Nodes (Count_Type (N)).Element := E; 100 | end Set_Element; 101 | 102 | ------------ 103 | -- Assign -- 104 | ------------ 105 | 106 | procedure Assign 107 | (Nodes : in out Container'Class; 108 | Source : Container'Class; 109 | New_Head : out Node_Access; 110 | Old_Head : Node_Access; 111 | New_Tail : out Node_Access; 112 | Old_Tail : Node_Access) is 113 | begin 114 | -- Indices will remain the same 115 | New_Head := Old_Head; 116 | New_Tail := Old_Tail; 117 | Nodes.Free := Source.Free; 118 | Nodes.Nodes := Source.Nodes; 119 | end Assign; 120 | 121 | end Impl; 122 | 123 | end Conts.Lists.Storage.Bounded_Definite; 124 | -------------------------------------------------------------------------------- /src/conts-lists-storage-bounded_definite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- The implementation for bounded list of definite elements. 8 | -- This implementation does not perform any memory allocation. 9 | -- It is compatible with SPARK. 10 | -- 11 | -- As opposed to some of the other list's storage packages, this package does 12 | -- not take a Base_Container formal parameter. This is for compatibility with 13 | -- SPARK, where it is not possible to extend a tagged type with new 14 | -- discriminants. 15 | -- As a result, a bounded list is always non-limited and non-controlled. This 16 | -- only works fine for a list of definite elements where no memory allocation 17 | -- occurs. 18 | 19 | pragma Ada_2012; 20 | with Conts.Elements.Definite; 21 | 22 | generic 23 | with package Elements is new Conts.Elements.Definite (<>); 24 | package Conts.Lists.Storage.Bounded_Definite with SPARK_Mode is 25 | 26 | pragma Assertion_Policy 27 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 28 | 29 | subtype Stored_Type is Elements.Traits.Stored; 30 | 31 | package Impl is 32 | type Container (Capacity : Count_Type) is abstract tagged private; 33 | type Node_Access is new Count_Type; 34 | Null_Node_Access : constant Node_Access := 0; 35 | 36 | procedure Allocate 37 | (Self : in out Impl.Container'Class; 38 | Element : Stored_Type; 39 | N : out Impl.Node_Access); 40 | function Get_Element 41 | (Self : Impl.Container'Class; 42 | N : Impl.Node_Access) return Stored_Type with Inline; 43 | function Get_Next 44 | (Self : Impl.Container'Class; 45 | N : Impl.Node_Access) return Impl.Node_Access with Inline; 46 | function Get_Previous 47 | (Self : Impl.Container'Class; 48 | N : Impl.Node_Access) return Impl.Node_Access with Inline; 49 | procedure Set_Previous 50 | (Self : in out Impl.Container'Class; 51 | N, Prev : Impl.Node_Access) with Inline; 52 | procedure Set_Next 53 | (Self : in out Impl.Container'Class; 54 | N, Next : Impl.Node_Access) with Inline; 55 | procedure Set_Element 56 | (Self : in out Impl.Container'Class; 57 | N : Node_Access; 58 | E : Stored_Type) with Inline; 59 | function Capacity (Self : Impl.Container'Class) return Count_Type 60 | is (Self.Capacity) with Inline; 61 | procedure Assign 62 | (Nodes : in out Impl.Container'Class; 63 | Source : Impl.Container'Class; 64 | New_Head : out Impl.Node_Access; 65 | Old_Head : Impl.Node_Access; 66 | New_Tail : out Impl.Node_Access; 67 | Old_Tail : Impl.Node_Access) 68 | with Pre => Nodes.Capacity >= Source.Capacity; 69 | -- See description in Conts.Lists.Nodes 70 | 71 | private 72 | pragma SPARK_Mode (Off); 73 | 74 | type Node is record 75 | Element : Stored_Type; 76 | Previous, Next : Node_Access := Null_Node_Access; 77 | end record; 78 | 79 | type Nodes_Array is array (Count_Type range <>) of Node; 80 | 81 | type Container (Capacity : Count_Type) is abstract tagged record 82 | Free : Integer := 0; -- head of free nodes list 83 | -- For a negative value, its absolute value points to the first free 84 | -- element 85 | 86 | Nodes : Nodes_Array (1 .. Capacity); 87 | end record; 88 | end Impl; 89 | 90 | use Impl; 91 | package Traits is new Conts.Lists.Storage.Traits 92 | (Elements => Elements.Traits, 93 | Container => Impl.Container, 94 | Node_Access => Impl.Node_Access, 95 | Null_Access => Impl.Null_Node_Access, 96 | Allocate => Allocate); 97 | end Conts.Lists.Storage.Bounded_Definite; 98 | -------------------------------------------------------------------------------- /src/conts-lists-storage-unbounded.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Ada.Unchecked_Deallocation; 9 | 10 | package body Conts.Lists.Storage.Unbounded with SPARK_Mode => Off is 11 | 12 | procedure Unchecked_Free is new Ada.Unchecked_Deallocation 13 | (Node, Node_Access); 14 | 15 | -------------- 16 | -- Allocate -- 17 | -------------- 18 | 19 | procedure Allocate 20 | (Self : in out Nodes_Container'Class; 21 | Element : Elements.Stored_Type; 22 | N : out Node_Access) 23 | is 24 | pragma Unreferenced (Self); 25 | begin 26 | N := new Node; 27 | N.Element := Element; 28 | end Allocate; 29 | 30 | ------------------ 31 | -- Release_Node -- 32 | ------------------ 33 | 34 | procedure Release_Node 35 | (Self : in out Nodes_Container'Class; N : in out Node_Access) 36 | is 37 | pragma Unreferenced (Self); 38 | begin 39 | Unchecked_Free (N); 40 | end Release_Node; 41 | 42 | ----------------- 43 | -- Get_Element -- 44 | ----------------- 45 | 46 | function Get_Element (Self : Nodes_Container'Class; N : Node_Access) 47 | return Elements.Stored_Type 48 | is 49 | pragma Unreferenced (Self); 50 | begin 51 | return N.Element; 52 | end Get_Element; 53 | 54 | -------------- 55 | -- Get_Next -- 56 | -------------- 57 | 58 | function Get_Next 59 | (Self : Nodes_Container'Class; N : Node_Access) return Node_Access 60 | is 61 | pragma Unreferenced (Self); 62 | begin 63 | return N.Next; 64 | end Get_Next; 65 | 66 | ------------------ 67 | -- Get_Previous -- 68 | ------------------ 69 | 70 | function Get_Previous 71 | (Self : Nodes_Container'Class; N : Node_Access) return Node_Access 72 | is 73 | pragma Unreferenced (Self); 74 | begin 75 | return N.Previous; 76 | end Get_Previous; 77 | 78 | ------------------ 79 | -- Set_Previous -- 80 | ------------------ 81 | 82 | procedure Set_Previous 83 | (Self : in out Nodes_Container'Class; N, Previous : Node_Access) 84 | is 85 | pragma Unreferenced (Self); 86 | begin 87 | N.Previous := Previous; 88 | end Set_Previous; 89 | 90 | -------------- 91 | -- Set_Next -- 92 | -------------- 93 | 94 | procedure Set_Next 95 | (Self : in out Nodes_Container'Class; N, Next : Node_Access) 96 | is 97 | pragma Unreferenced (Self); 98 | begin 99 | N.Next := Next; 100 | end Set_Next; 101 | 102 | ----------------- 103 | -- Set_Element -- 104 | ----------------- 105 | 106 | procedure Set_Element 107 | (Self : in out Nodes_Container'Class; 108 | N : Node_Access; 109 | E : Elements.Stored_Type) 110 | is 111 | pragma Unreferenced (Self); 112 | begin 113 | N.Element := E; 114 | end Set_Element; 115 | 116 | ------------ 117 | -- Assign -- 118 | ------------ 119 | 120 | procedure Assign 121 | (Nodes : in out Nodes_Container'Class; 122 | Source : Nodes_Container'Class; 123 | New_Head : out Node_Access; 124 | Old_Head : Node_Access; 125 | New_Tail : out Node_Access; 126 | Old_Tail : Node_Access) 127 | is 128 | pragma Unreferenced (Source, Old_Tail); 129 | N, Tmp, Tmp2 : Node_Access; 130 | begin 131 | if Old_Head = null then 132 | New_Head := null; 133 | New_Tail := null; 134 | return; 135 | end if; 136 | 137 | Tmp2 := Old_Head; 138 | if Elements.Copyable then 139 | Allocate (Nodes, Tmp2.Element, Tmp); 140 | else 141 | Allocate (Nodes, Elements.Copy (Tmp2.Element), Tmp); 142 | end if; 143 | New_Head := Tmp; 144 | 145 | loop 146 | Tmp2 := Tmp2.Next; 147 | exit when Tmp2 = null; 148 | 149 | if Elements.Copyable then 150 | Allocate (Nodes, Tmp2.Element, N); 151 | else 152 | Allocate (Nodes, Elements.Copy (Tmp2.Element), N); 153 | end if; 154 | 155 | Tmp.Next := N; 156 | N.Previous := Tmp; 157 | Tmp := N; 158 | end loop; 159 | 160 | New_Tail := N; 161 | end Assign; 162 | 163 | end Conts.Lists.Storage.Unbounded; 164 | -------------------------------------------------------------------------------- /src/conts-lists-storage-unbounded.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- This package provides support for unbounded lists. 8 | -- All nodes are allocated on the heap. 9 | 10 | pragma Ada_2012; 11 | with Conts.Elements; 12 | 13 | generic 14 | with package Elements is new Conts.Elements.Traits (<>); 15 | 16 | type Container_Base_Type is abstract tagged limited private; 17 | -- The base type for these unbounded list. 18 | 19 | with package Pool is new Conts.Pools (<>); 20 | -- The storage pool used for nodes. 21 | 22 | package Conts.Lists.Storage.Unbounded with SPARK_Mode => Off is 23 | 24 | pragma Assertion_Policy 25 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 26 | 27 | subtype Nodes_Container is Container_Base_Type; 28 | type Node; 29 | type Node_Access is access Node; 30 | for Node_Access'Storage_Pool use Pool.Pool; 31 | 32 | -- ??? Compiler crashes if we make this type private 33 | type Node is record 34 | Element : Elements.Stored_Type; 35 | Previous, Next : Node_Access; 36 | end record; 37 | 38 | procedure Allocate 39 | (Self : in out Nodes_Container'Class; 40 | Element : Elements.Stored_Type; 41 | N : out Node_Access) 42 | with Inline; 43 | procedure Release_Node 44 | (Self : in out Nodes_Container'Class; N : in out Node_Access); 45 | function Get_Element 46 | (Self : Nodes_Container'Class; N : Node_Access) 47 | return Elements.Stored_Type 48 | with Inline; 49 | function Get_Next 50 | (Self : Nodes_Container'Class; N : Node_Access) return Node_Access 51 | with Inline; 52 | function Get_Previous 53 | (Self : Nodes_Container'Class; N : Node_Access) return Node_Access 54 | with Inline; 55 | procedure Set_Previous 56 | (Self : in out Nodes_Container'Class; N, Previous : Node_Access) 57 | with Inline; 58 | procedure Set_Next 59 | (Self : in out Nodes_Container'Class; N, Next : Node_Access) 60 | with Inline; 61 | procedure Set_Element 62 | (Self : in out Nodes_Container'Class; 63 | N : Node_Access; 64 | E : Elements.Stored_Type) 65 | with Inline; 66 | function Capacity (Self : Nodes_Container'Class) return Count_Type 67 | is (Count_Type'Last) with Inline; 68 | procedure Assign 69 | (Nodes : in out Nodes_Container'Class; 70 | Source : Nodes_Container'Class; 71 | New_Head : out Node_Access; 72 | Old_Head : Node_Access; 73 | New_Tail : out Node_Access; 74 | Old_Tail : Node_Access); 75 | 76 | package Traits is new Conts.Lists.Storage.Traits 77 | (Elements => Elements, 78 | Container => Nodes_Container, 79 | Node_Access => Node_Access, 80 | Null_Access => null, 81 | Allocate => Allocate, 82 | Release_Node => Release_Node); 83 | 84 | end Conts.Lists.Storage.Unbounded; 85 | -------------------------------------------------------------------------------- /src/conts-lists-storage-unbounded_spark.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- This package provides support for unbounded list, compatible with SPARK. 8 | -- It uses an resizable array of access types. It is resizable so that there 9 | -- is no upper-limit on the size of the list. Since it is an array, cursors 10 | -- are indexes into this array, not actual access types, so that we can write 11 | -- pre and post-conditions conveniently. 12 | 13 | pragma Ada_2012; 14 | with Conts.Elements; 15 | 16 | generic 17 | with package Elements is new Conts.Elements.Traits (<>); 18 | 19 | type Container_Base_Type is abstract tagged limited private; 20 | -- The base type for these unbounded lists 21 | 22 | package Conts.Lists.Storage.Unbounded_SPARK with SPARK_Mode is 23 | 24 | pragma Assertion_Policy 25 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 26 | 27 | type Node_Access is new Count_Type; 28 | Null_Node_Access : constant Node_Access := 0; 29 | type Node is record 30 | Element : Elements.Stored_Type; 31 | Previous, Next : Node_Access := Null_Node_Access; 32 | end record; 33 | 34 | type Big_Nodes_Array is array (1 .. Count_Type'Last) of Node; 35 | 36 | package Private_Nodes_List with SPARK_Mode is 37 | type Nodes_List is abstract new Container_Base_Type with private; 38 | 39 | procedure Allocate 40 | (Self : in out Nodes_List'Class; 41 | Element : Elements.Stored_Type; 42 | N : out Node_Access); -- not inlined 43 | procedure Release (Self : in out Nodes_List'Class); 44 | function Get_Element 45 | (Self : Nodes_List'Class; N : Node_Access) 46 | return Elements.Stored_Type 47 | with Inline; 48 | function Get_Next 49 | (Self : Nodes_List'Class; N : Node_Access) return Node_Access 50 | with Inline; 51 | function Get_Previous 52 | (Self : Nodes_List'Class; N : Node_Access) return Node_Access 53 | with Inline; 54 | procedure Set_Next 55 | (Self : in out Nodes_List'Class; N, Next : Node_Access) 56 | with Inline; 57 | procedure Set_Previous 58 | (Self : in out Nodes_List'Class; N, Previous : Node_Access) 59 | with Inline; 60 | procedure Set_Element 61 | (Self : in out Nodes_List'Class; 62 | N : Node_Access; 63 | E : Elements.Stored_Type) with Inline; 64 | function Capacity (Self : Nodes_List'Class) return Count_Type 65 | is (Count_Type'Last) with Inline; 66 | procedure Assign 67 | (Nodes : in out Nodes_List'Class; 68 | Source : Nodes_List'Class; 69 | New_Head : out Node_Access; 70 | Old_Head : Node_Access; 71 | New_Tail : out Node_Access; 72 | Old_Tail : Node_Access); 73 | private 74 | pragma SPARK_Mode (Off); 75 | type Nodes_Array_Access is access Big_Nodes_Array; 76 | for Nodes_Array_Access'Storage_Size use 0; 77 | -- The nodes is a pointer so that we can use realloc 78 | 79 | type Nodes_List is abstract new Container_Base_Type with record 80 | Nodes : Nodes_Array_Access := null; 81 | Last : Count_Type := 0; -- Last valid index in Nodes 82 | Free : Integer := 0; -- head of free nodes list 83 | -- For a negative value, its absolute value points to the first 84 | -- free element 85 | end record; 86 | 87 | function Get_Element 88 | (Self : Nodes_List'Class; N : Node_Access) 89 | return Elements.Stored_Type 90 | is (Self.Nodes (Count_Type (N)).Element); 91 | function Get_Next 92 | (Self : Nodes_List'Class; N : Node_Access) return Node_Access 93 | is (Self.Nodes (Count_Type (N)).Next); 94 | function Get_Previous 95 | (Self : Nodes_List'Class; N : Node_Access) return Node_Access 96 | is (Self.Nodes (Count_Type (N)).Previous); 97 | end Private_Nodes_List; 98 | 99 | use Private_Nodes_List; 100 | 101 | package Traits is new Conts.Lists.Storage.Traits 102 | (Elements => Elements, 103 | Container => Nodes_List, 104 | Node_Access => Node_Access, 105 | Null_Access => Null_Node_Access, 106 | Allocate => Allocate, 107 | Release => Release); 108 | 109 | end Conts.Lists.Storage.Unbounded_SPARK; 110 | -------------------------------------------------------------------------------- /src/conts-lists-storage.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- The following packages are used to describe some types of nodes that can be 8 | -- used to build a list. We use a different type depending on whether we have 9 | -- a bounded or unbounded list, for instance. Other implementations are 10 | -- possible to adapt to existing data structures, for instance. 11 | 12 | pragma Ada_2012; 13 | with Conts.Elements; 14 | 15 | package Conts.Lists.Storage with SPARK_Mode is 16 | 17 | generic 18 | with package Elements is new Conts.Elements.Traits (<>); 19 | -- The type of elements stored in nodes 20 | 21 | type Container (<>) is abstract tagged limited private; 22 | -- A container for all nodes. 23 | -- Such a container is not needed when nodes are allocated on the heap 24 | -- and accessed via pointers; but it is needed when nodes are stored in 25 | -- an array, for instance. 26 | -- This is used as the ancestor type for the list types, so that this 27 | -- type can actually be an unconstrained type (which we could not store 28 | -- inside another list). 29 | 30 | type Node_Access is private; 31 | -- Access to a node. This is either an actual pointer or an index into 32 | -- some other data structure. 33 | 34 | Null_Access : Node_Access; 35 | 36 | with procedure Allocate 37 | (Self : in out Container'Class; 38 | Element : Elements.Stored_Type; 39 | New_Node : out Node_Access); 40 | -- Allocate a new node, that contains Element. Its next and previous 41 | -- siblings have been initialized to Null_Access. 42 | -- This procedure can return Null_Access is the new node could not be 43 | -- allocated. This should only happen when there is more than Capacity 44 | -- elements in Self. 45 | 46 | with procedure Release_Node 47 | (Self : in out Container'Class; N : in out Node_Access) is null; 48 | -- Free the memory for a specific node. 49 | -- This function should not free the element itself, this has already 50 | -- been handled by the container (this is so that a null procedure can 51 | -- be passed in the common case). 52 | 53 | with procedure Release (Self : in out Container'Class) is null; 54 | -- Free all the memory used by the container. 55 | -- This should not free the nodes themselves, this has already been 56 | -- taken care of by the container. This is so that a null procedure 57 | -- can be passed in the common case. 58 | 59 | with function Get_Element 60 | (Self : Container'Class; 61 | Pos : Node_Access) return Elements.Stored_Type is <>; 62 | with function Get_Next 63 | (Self : Container'Class; Pos : Node_Access) return Node_Access is <>; 64 | with function Get_Previous 65 | (Self : Container'Class; Pos : Node_Access) return Node_Access is <>; 66 | -- Get the next and previous elements for a node 67 | -- Must return Null_Access when there is no such element. 68 | 69 | with procedure Set_Element 70 | (Self : in out Container'Class; 71 | Pos : Node_Access; 72 | Element : Elements.Stored_Type) is <>; 73 | -- Replace the element at the given position. 74 | -- This does not free the previous element. 75 | 76 | with procedure Set_Previous 77 | (Self : in out Container'Class; 78 | Pos : Node_Access; 79 | Previous : Node_Access) is <>; 80 | with procedure Set_Next 81 | (Self : in out Container'Class; 82 | Pos : Node_Access; 83 | Next : Node_Access) is <>; 84 | -- Change the next and previous elements for a node 85 | 86 | with function Capacity (Self : Container'Class) return Count_Type is <>; 87 | -- How many nodes can be stored in Nodes 88 | 89 | with procedure Assign 90 | (Self : in out Container'Class; 91 | Source : Container'Class; 92 | New_Head : out Node_Access; 93 | Old_Head : Node_Access; 94 | New_Tail : out Node_Access; 95 | Old_Tail : Node_Access) is <>; 96 | -- Replace all nodes in Nodes with a copy of the nodes in Source. 97 | -- The elements themselves need to be copied (via Elements.Copy). 98 | 99 | package Traits with SPARK_Mode is 100 | end Traits; 101 | 102 | end Conts.Lists.Storage; 103 | -------------------------------------------------------------------------------- /src/conts-lists-strings.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- Unbounded lists of strings. 8 | -- A special allocation strategy is used for strings, so that small strings 9 | -- are directly stored in the list's node, and do not require memory 10 | -- allocation. This might make things faster in some cases, at the cost of 11 | -- using more memory since the nodes are bigger. 12 | -- Consider using Conts.Lists.Indefinite_Unbounded_Ref for another list 13 | -- usable with strings. 14 | 15 | pragma Ada_2012; 16 | with Ada.Finalization; 17 | with Conts.Elements.Arrays; 18 | with Conts.Lists.Generics; 19 | with Conts.Lists.Storage.Unbounded; 20 | 21 | package Conts.Lists.Strings is 22 | 23 | pragma Assertion_Policy 24 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 25 | 26 | package Elements is new Conts.Elements.Arrays 27 | (Positive, Character, String, Conts.Global_Pool); 28 | package Storage is new Conts.Lists.Storage.Unbounded 29 | (Elements => Elements.Traits, 30 | Container_Base_Type => Ada.Finalization.Controlled, 31 | Pool => Conts.Global_Pool); 32 | package Lists is new Conts.Lists.Generics (Storage.Traits); 33 | 34 | subtype Cursor is Lists.Cursor; 35 | type List is new Lists.List with null record 36 | with Iterable => (First => First_Primitive, 37 | Next => Next_Primitive, 38 | Has_Element => Has_Element_Primitive, 39 | Element => Element_Primitive); 40 | 41 | package Cursors renames Lists.Cursors; 42 | package Maps renames Lists.Maps; 43 | 44 | end Conts.Lists.Strings; 45 | -------------------------------------------------------------------------------- /src/conts-lists.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | 9 | package Conts.Lists with SPARK_Mode => On is 10 | 11 | end Conts.Lists; 12 | -------------------------------------------------------------------------------- /src/conts-maps-def_def_unbounded.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- Maps indexed by definite elements (integers for instance), containing 8 | -- definite elements (records for instance). 9 | 10 | pragma Ada_2012; 11 | with Conts.Elements.Definite; 12 | with Conts.Maps.Generics; 13 | 14 | generic 15 | type Key_Type is private; 16 | type Element_Type is private; 17 | type Container_Base_Type is abstract tagged limited private; 18 | with function Hash (Key : Key_Type) return Hash_Type; 19 | with function "=" (Left, Right : Key_Type) return Boolean is <>; 20 | with procedure Free (E : in out Key_Type) is null; 21 | with procedure Free (E : in out Element_Type) is null; 22 | package Conts.Maps.Def_Def_Unbounded is 23 | 24 | pragma Assertion_Policy 25 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 26 | 27 | package Keys is new Conts.Elements.Definite 28 | (Key_Type, Free => Free); 29 | package Elements is new Conts.Elements.Definite 30 | (Element_Type, Free => Free); 31 | package Impl is new Conts.Maps.Generics 32 | (Keys => Keys.Traits, 33 | Elements => Elements.Traits, 34 | Hash => Hash, 35 | "=" => "=", 36 | Probing => Conts.Maps.Perturbation_Probing, 37 | Pool => Conts.Global_Pool, 38 | Container_Base_Type => Container_Base_Type); 39 | 40 | subtype Constant_Returned_Type is Impl.Constant_Returned_Type; 41 | subtype Constant_Returned_Key_Type is Impl.Constant_Returned_Key_Type; 42 | 43 | subtype Cursor is Impl.Cursor; 44 | subtype Map is Impl.Map; 45 | 46 | package Cursors renames Impl.Cursors; 47 | package Maps renames Impl.Maps; 48 | 49 | end Conts.Maps.Def_Def_Unbounded; 50 | -------------------------------------------------------------------------------- /src/conts-maps-indef_def_unbounded.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- Maps indexed by indefinite elements (strings for instance), containing 8 | -- definite elements (records for instance). 9 | 10 | pragma Ada_2012; 11 | with Conts.Elements.Definite; 12 | with Conts.Elements.Indefinite; 13 | with Conts.Maps.Generics; 14 | 15 | generic 16 | type Key_Type (<>) is private; 17 | type Element_Type is private; 18 | type Container_Base_Type is abstract tagged limited private; 19 | with function Hash (Key : Key_Type) return Hash_Type; 20 | with function "=" (Left, Right : Key_Type) return Boolean is <>; 21 | with procedure Free (E : in out Key_Type) is null; 22 | with procedure Free (E : in out Element_Type) is null; 23 | package Conts.Maps.Indef_Def_Unbounded is 24 | 25 | pragma Assertion_Policy 26 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 27 | 28 | package Keys is new Conts.Elements.Indefinite 29 | (Key_Type, Pool => Conts.Global_Pool, Free => Free); 30 | package Elements is new Conts.Elements.Definite 31 | (Element_Type, Free => Free); 32 | 33 | function "=" (Left : Key_Type; Right : Keys.Traits.Stored) return Boolean 34 | is (Left = Right.all) with Inline; 35 | 36 | package Impl is new Conts.Maps.Generics 37 | (Keys => Keys.Traits, 38 | Elements => Elements.Traits, 39 | Hash => Hash, 40 | "=" => "=", 41 | Probing => Conts.Maps.Perturbation_Probing, 42 | Pool => Conts.Global_Pool, 43 | Container_Base_Type => Container_Base_Type); 44 | 45 | subtype Cursor is Impl.Cursor; 46 | subtype Map is Impl.Map; 47 | 48 | package Cursors renames Impl.Cursors; 49 | package Maps renames Impl.Maps; 50 | 51 | end Conts.Maps.Indef_Def_Unbounded; 52 | -------------------------------------------------------------------------------- /src/conts-maps-indef_indef_unbounded.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- Maps indexed by indefinite elements (strings for instance), containing 8 | -- indefinite elements (class-wide for instance). 9 | 10 | pragma Ada_2012; 11 | with Conts.Elements.Indefinite; 12 | with Conts.Maps.Generics; 13 | 14 | generic 15 | type Key_Type (<>) is private; 16 | type Element_Type (<>) is private; 17 | type Container_Base_Type is abstract tagged limited private; 18 | with function Hash (Key : Key_Type) return Hash_Type; 19 | with function "=" (Left, Right : Key_Type) return Boolean is <>; 20 | with procedure Free (E : in out Key_Type) is null; 21 | with procedure Free (E : in out Element_Type) is null; 22 | package Conts.Maps.Indef_Indef_Unbounded is 23 | 24 | pragma Assertion_Policy 25 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 26 | 27 | package Keys is new Conts.Elements.Indefinite 28 | (Key_Type, Pool => Conts.Global_Pool, Free => Free); 29 | package Elements is new Conts.Elements.Indefinite 30 | (Element_Type, Pool => Conts.Global_Pool, Free => Free); 31 | 32 | function "=" (Left : Key_Type; Right : Keys.Traits.Stored) return Boolean 33 | is (Left = Right.all) with Inline; 34 | 35 | package Impl is new Conts.Maps.Generics 36 | (Keys => Keys.Traits, 37 | Elements => Elements.Traits, 38 | Hash => Hash, 39 | "=" => "=", 40 | Probing => Conts.Maps.Perturbation_Probing, 41 | Pool => Conts.Global_Pool, 42 | Container_Base_Type => Container_Base_Type); 43 | 44 | subtype Constant_Returned_Type is Impl.Constant_Returned_Type; 45 | subtype Constant_Returned_Key_Type is Impl.Constant_Returned_Key_Type; 46 | 47 | subtype Cursor is Impl.Cursor; 48 | subtype Map is Impl.Map; 49 | subtype Returned is Impl.Returned_Type; 50 | 51 | package Cursors renames Impl.Cursors; 52 | package Maps renames Impl.Maps; 53 | 54 | end Conts.Maps.Indef_Indef_Unbounded; 55 | -------------------------------------------------------------------------------- /src/conts-maps-indef_indef_unbounded_spark.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | 9 | package body Conts.Maps.Indef_Indef_Unbounded_SPARK with SPARK_Mode => Off is 10 | 11 | pragma Assertion_Policy 12 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 13 | 14 | ---------- 15 | -- Copy -- 16 | ---------- 17 | 18 | function Copy (Self : Map'Class) return Map'Class is 19 | begin 20 | return Result : Map do 21 | Result.Assign (Self); 22 | end return; 23 | end Copy; 24 | 25 | end Conts.Maps.Indef_Indef_Unbounded_SPARK; 26 | -------------------------------------------------------------------------------- /src/conts-maps-indef_indef_unbounded_spark.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- Maps indexed by indefinite elements (strings for instance), containing 8 | -- indefinite elements (class-wide for instance). 9 | 10 | pragma Ada_2012; 11 | with Conts.Elements.Indefinite_SPARK; 12 | with Conts.Maps.Generics; 13 | with Conts.Properties.SPARK; 14 | 15 | generic 16 | type Key_Type (<>) is private; 17 | type Element_Type (<>) is private; 18 | with function Hash (Key : Key_Type) return Hash_Type; 19 | with function "=" (Left, Right : Key_Type) return Boolean is <>; 20 | package Conts.Maps.Indef_Indef_Unbounded_SPARK with SPARK_Mode is 21 | 22 | pragma Assertion_Policy 23 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 24 | 25 | package Keys is new Conts.Elements.Indefinite_SPARK 26 | (Key_Type, Pool => Conts.Global_Pool); 27 | package Elements is new Conts.Elements.Indefinite_SPARK 28 | (Element_Type, Pool => Conts.Global_Pool); 29 | 30 | function "=" (Left : Key_Type; Right : Keys.Traits.Stored) return Boolean is 31 | (Left = Keys.Impl.To_Element 32 | (Keys.Impl.To_Constant_Reference_Type (Right))) 33 | with Inline; 34 | 35 | package Impl is new Conts.Maps.Generics 36 | (Keys => Keys.Traits, 37 | Elements => Elements.Traits, 38 | Hash => Hash, 39 | "=" => "=", 40 | Probing => Conts.Maps.Perturbation_Probing, 41 | Pool => Conts.Global_Pool, 42 | Container_Base_Type => Limited_Base, 43 | Resize_Strategy => Resize_2_3); 44 | 45 | subtype Constant_Returned_Type is Impl.Constant_Returned_Type; 46 | subtype Constant_Returned_Key_Type is Impl.Constant_Returned_Key_Type; 47 | 48 | subtype Cursor is Impl.Cursor; 49 | subtype Map is Impl.Map; 50 | subtype Returned is Impl.Returned_Type; 51 | 52 | subtype Model_Map is Impl.Impl.M.Map with Ghost; 53 | subtype Key_Sequence is Impl.Impl.K.Sequence with Ghost; 54 | subtype Cursor_Position_Map is Impl.Impl.P_Map with Ghost; 55 | 56 | function Copy (Self : Map'Class) return Map'Class; 57 | -- Return a deep copy of Self 58 | 59 | package Cursors renames Impl.Cursors; 60 | package Maps renames Impl.Maps; 61 | 62 | package Content_Models is new Conts.Properties.SPARK.Content_Models 63 | (Map_Type => Impl.Base_Map'Class, 64 | Element_Type => Key_Type, 65 | Model_Type => Key_Sequence, 66 | Index_Type => Impl.Impl.K.Extended_Index, 67 | Model => Impl.S_Keys, 68 | Get => Impl.Impl.K.Get, 69 | First => Impl.Impl.K.First, 70 | Last => Impl.Impl.K.Last); 71 | 72 | end Conts.Maps.Indef_Indef_Unbounded_SPARK; 73 | -------------------------------------------------------------------------------- /src/conts-maps.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Ada.Containers; use Ada.Containers; 9 | 10 | package body Conts.Maps is 11 | 12 | ------------------------ 13 | -- Initialize_Probing -- 14 | ------------------------ 15 | 16 | overriding procedure Initialize_Probing 17 | (Self : in out Perturbation_Probing; 18 | Hash : Hash_Type; 19 | Size : Hash_Type) 20 | is 21 | pragma Unreferenced (Size); 22 | begin 23 | Self.Pertub := Hash; 24 | end Initialize_Probing; 25 | 26 | ------------------ 27 | -- Next_Probing -- 28 | ------------------ 29 | 30 | overriding function Next_Probing 31 | (Self : in out Perturbation_Probing; 32 | Previous : Hash_Type) return Hash_Type 33 | is 34 | Candidate : constant Hash_Type := 35 | Previous * 4 + Previous + 1 + Self.Pertub; 36 | begin 37 | Self.Pertub := Self.Pertub / (2 ** 5); 38 | return Candidate; 39 | end Next_Probing; 40 | 41 | end Conts.Maps; 42 | -------------------------------------------------------------------------------- /src/conts-maps.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Ada.Containers; use Ada.Containers; 9 | 10 | package Conts.Maps is 11 | 12 | ------------- 13 | -- Probing -- 14 | ------------- 15 | -- The implementation of the hashed map stores all elements in a single 16 | -- array. Preferably, the bucket used is the one corresponding to the hash 17 | -- computed from the key. But in case there is already another element at 18 | -- that position, other positions have to be tried. There are multiple 19 | -- strategies for this. 20 | -- We use a tagged record for this, since some strategies need to keep 21 | -- data. A new instance of the object is created and initialized every time 22 | -- we search for a new key. 23 | 24 | type Probing_Strategy is interface; 25 | -- An object whose goal is to compute the next candidate 26 | 27 | procedure Initialize_Probing 28 | (Self : in out Probing_Strategy; 29 | Hash : Hash_Type; 30 | Size : Hash_Type) is null; 31 | -- Called once when a lookup starts 32 | 33 | function Next_Probing 34 | (Self : in out Probing_Strategy; 35 | Previous : Hash_Type) return Hash_Type is abstract; 36 | -- Compute the next position to check, given we checked Previous and found 37 | -- this position already in use. 38 | 39 | -------------------- 40 | -- Linear probing -- 41 | -------------------- 42 | -- Simple probing: check the next place in the array. This is simple, 43 | -- but not optimal in general when the keys are sequential integers for 44 | -- instance, since we end up with blocks of filled slots, which slows the 45 | -- lookup. 46 | 47 | type Linear_Probing is new Probing_Strategy with null record; 48 | overriding function Next_Probing 49 | (Self : in out Linear_Probing; Previous : Hash_Type) return Hash_Type 50 | is (Previous + 1) with Inline; 51 | 52 | ------------------------- 53 | -- Pertubation_Probing -- 54 | ------------------------- 55 | -- Similar to linear probing, but more efficient since it will try various 56 | -- places in the array. 57 | 58 | type Perturbation_Probing is new Probing_Strategy with private; 59 | overriding procedure Initialize_Probing 60 | (Self : in out Perturbation_Probing; 61 | Hash : Hash_Type; 62 | Size : Hash_Type) with Inline; 63 | overriding function Next_Probing 64 | (Self : in out Perturbation_Probing; 65 | Previous : Hash_Type) return Hash_Type 66 | with Inline; 67 | 68 | --------------------- 69 | -- Resize strategy -- 70 | --------------------- 71 | 72 | function Resize_2_3 73 | (Used : Count_Type; 74 | Fill : Count_Type; 75 | Capacity : Count_Type) return Count_Type 76 | is (Count_Type 77 | (Hash_Type'Min 78 | ((if Hash_Type (Fill) > (Hash_Type (Capacity) * 2) / 3 79 | then (if Used > 100_000 80 | then Hash_Type (Used) * 2 81 | else Hash_Type (Used) * 4) 82 | else 0), -- no resizing in this case 83 | Hash_Type (Count_Type'Last)))) 84 | with Inline; 85 | -- This strategy attempts to keep the table at most 2/3. If this isn't the 86 | -- case, the size of the table is multiplied by 4 (which trades memory for 87 | -- efficiency by limiting the number of mallocs). However, when the table 88 | -- is already large, we only double the size. 89 | -- 90 | -- If memory is more important than pure speed for you, you could modify 91 | -- this strategy. 92 | -- 93 | -- The actual size allocated for the table will be the nearest power of 2 94 | -- greater than the returned value. 95 | -- 96 | -- See Conts.Maps.Generics.Resize_Strategy for more information on the 97 | -- parameters. 98 | 99 | private 100 | 101 | type Perturbation_Probing is new Probing_Strategy with record 102 | Pertub : Hash_Type; 103 | end record; 104 | 105 | end Conts.Maps; 106 | -------------------------------------------------------------------------------- /src/conts-properties-indexed.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | 9 | package body Conts.Properties.Indexed is 10 | 11 | use Value_Vectors; 12 | 13 | ----------- 14 | -- Clear -- 15 | ----------- 16 | 17 | procedure Clear (M : in out Map) is 18 | begin 19 | M.Values.Clear; 20 | end Clear; 21 | 22 | --------- 23 | -- Get -- 24 | --------- 25 | 26 | function Get (M : Map; K : Key_Type) return Element_Type is 27 | begin 28 | return M.Values.Element (Get_Index (K)); 29 | end Get; 30 | 31 | --------- 32 | -- Set -- 33 | --------- 34 | 35 | procedure Set (M : in out Map; K : Key_Type; Val : Element_Type) is 36 | Idx : constant Index_Type := Get_Index (K); 37 | begin 38 | -- ??? We should have such an operation in the vector directly 39 | if not (Value_Vectors.Vectors.To_Count (Idx) <= M.Values.Length) then 40 | M.Values.Resize 41 | (Length => Value_Vectors.Vectors.To_Count (Idx), 42 | Element => Default_Value); 43 | end if; 44 | 45 | M.Values.Replace_Element (Idx, Val); 46 | end Set; 47 | 48 | ---------------- 49 | -- Create_Map -- 50 | ---------------- 51 | 52 | function Create_Map (G : Container_Type) return Map is 53 | begin 54 | return M : Map do 55 | M.Values.Reserve_Capacity (Length (G)); 56 | end return; 57 | end Create_Map; 58 | 59 | end Conts.Properties.Indexed; 60 | -------------------------------------------------------------------------------- /src/conts-properties-indexed.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- An implementation of property maps that can be used when the key 8 | -- maps to indexes. These are implemented as vectors, rather than 9 | -- arrays, so that they can be used without necessarily knowing the 10 | -- required size in advance, and because a very large array for a 11 | -- very large container could blow the stack. 12 | -- The map is also set as a limited type to limit the number of 13 | -- copies. This ensures that Create_Map builds the map in place. 14 | 15 | pragma Ada_2012; 16 | with Conts.Vectors.Definite_Unbounded; 17 | 18 | generic 19 | type Container_Type (<>) is limited private; 20 | type Key_Type (<>) is limited private; 21 | type Element_Type is private; 22 | 23 | Default_Value : Element_Type; 24 | -- These maps are implemented as vectors, and a default value is needed 25 | -- when the vector is resized. 26 | 27 | type Index_Type is (<>); 28 | type Container_Base_Type is abstract tagged limited private; 29 | 30 | with function Get_Index (K : Key_Type) return Index_Type is <>; 31 | -- Maps the key to an index 32 | 33 | with function Length (G : Container_Type) return Count_Type is <>; 34 | -- Use to reserve the initial capacity for the vector. This can 35 | -- safely return 0 or any values, since the vector is unbounded. But 36 | -- returning a proper value will speed things up by avoiding reallocs. 37 | 38 | package Conts.Properties.Indexed is 39 | 40 | package Value_Vectors is new Conts.Vectors.Definite_Unbounded 41 | (Index_Type, Element_Type, Container_Base_Type => Container_Base_Type); 42 | 43 | type Map is limited record 44 | Values : Value_Vectors.Vector; 45 | end record; 46 | function Get (M : Map; K : Key_Type) return Element_Type; 47 | procedure Set (M : in out Map; K : Key_Type; Val : Element_Type); 48 | procedure Clear (M : in out Map); 49 | 50 | function Create_Map (G : Container_Type) return Map; 51 | -- Create a new uninitialized map 52 | 53 | package As_Map is new Maps (Map, Key_Type, Element_Type, Set, Get, Clear); 54 | package As_Read_Only renames As_Map.As_Read_Only; 55 | 56 | end Conts.Properties.Indexed; 57 | -------------------------------------------------------------------------------- /src/conts-properties-spark.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016-2017, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- This package describes the concept of property models. They are used to 8 | -- annotate containers. Models of a map are sequences of elements indexed 9 | -- by a discrete type. For ease of use, the content models property is 10 | -- instantiated in the spark version of containers. 11 | 12 | pragma Ada_2012; 13 | 14 | package Conts.Properties.SPARK is 15 | 16 | ----------------------------- 17 | -- Property content models -- 18 | ----------------------------- 19 | 20 | generic 21 | type Map_Type (<>) is limited private; 22 | type Element_Type (<>) is private; 23 | type Model_Type is private; 24 | type Index_Type is (<>); 25 | with function Model (M : Map_Type) return Model_Type; 26 | with function Get (M : Model_Type; I : Index_Type) return Element_Type; 27 | with function First return Index_Type; 28 | with function Last (M : Model_Type) return Index_Type; 29 | package Content_Models with Ghost is 30 | subtype Map is Map_Type; 31 | subtype Element is Element_Type; 32 | end Content_Models; 33 | 34 | end Conts.Properties.SPARK; 35 | -------------------------------------------------------------------------------- /src/conts-vectors-definite_bounded.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- Bounded controlled vectors of constrained elements 8 | 9 | pragma Ada_2012; 10 | with Conts.Elements.Definite; 11 | with Conts.Vectors.Generics; 12 | with Conts.Vectors.Storage.Bounded_Definite; 13 | with Conts.Properties.SPARK; 14 | 15 | generic 16 | type Index_Type is range <>; 17 | type Element_Type is private; 18 | package Conts.Vectors.Definite_Bounded with SPARK_Mode is 19 | 20 | pragma Assertion_Policy 21 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 22 | 23 | package Elements is new Conts.Elements.Definite (Element_Type); 24 | package Storage is new Conts.Vectors.Storage.Bounded_Definite 25 | (Elements => Elements); 26 | package Vectors is new Conts.Vectors.Generics (Index_Type, Storage.Traits); 27 | 28 | subtype Vector is Vectors.Vector; 29 | subtype Cursor is Vectors.Cursor; 30 | 31 | package Cursors renames Vectors.Cursors; 32 | package Maps renames Vectors.Maps; 33 | 34 | subtype Element_Sequence is Vectors.Impl.M.Sequence with Ghost; 35 | 36 | procedure Swap 37 | (Self : in out Cursors.Forward.Container; Left, Right : Index_Type) 38 | renames Vectors.Swap; 39 | 40 | package Content_Models is new Conts.Properties.SPARK.Content_Models 41 | (Map_Type => Vectors.Base_Vector'Class, 42 | Element_Type => Element_Type, 43 | Model_Type => Element_Sequence, 44 | Index_Type => Vectors.Impl.M.Extended_Index, 45 | Model => Vectors.Impl.Model, 46 | Get => Vectors.Impl.M.Get, 47 | First => Vectors.Impl.M.First, 48 | Last => Vectors.Impl.M.Last); 49 | 50 | end Conts.Vectors.Definite_Bounded; 51 | -------------------------------------------------------------------------------- /src/conts-vectors-definite_unbounded.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- Unbounded vectors of constrained elements. 8 | -- Compared with standard Ada containers, this is saving half of the memory 9 | -- allocations, so much more efficient in general. 10 | 11 | pragma Ada_2012; 12 | with Conts.Elements.Definite; 13 | with Conts.Vectors.Generics; 14 | with Conts.Vectors.Storage.Unbounded; 15 | 16 | generic 17 | type Index_Type is (<>); 18 | type Element_Type is private; 19 | type Container_Base_Type is abstract tagged limited private; 20 | with procedure Free (E : in out Element_Type) is null; 21 | package Conts.Vectors.Definite_Unbounded is 22 | 23 | pragma Assertion_Policy 24 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 25 | 26 | package Elements is new Conts.Elements.Definite 27 | (Element_Type, Free => Free); 28 | package Storage is new Conts.Vectors.Storage.Unbounded 29 | (Elements => Elements.Traits, 30 | Container_Base_Type => Container_Base_Type, 31 | Resize_Policy => Conts.Vectors.Resize_1_5); 32 | package Vectors is new Conts.Vectors.Generics (Index_Type, Storage.Traits); 33 | 34 | subtype Vector is Vectors.Vector; 35 | subtype Cursor is Vectors.Cursor; 36 | subtype Extended_Index is Vectors.Extended_Index; 37 | 38 | package Cursors renames Vectors.Cursors; 39 | package Maps renames Vectors.Maps; 40 | 41 | procedure Swap 42 | (Self : in out Cursors.Forward.Container; Left, Right : Index_Type) 43 | renames Vectors.Swap; 44 | 45 | end Conts.Vectors.Definite_Unbounded; 46 | -------------------------------------------------------------------------------- /src/conts-vectors-indefinite_unbounded.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- Unbounded controlled vectors of unconstrained elements 8 | 9 | pragma Ada_2012; 10 | with Ada.Finalization; 11 | with Conts.Elements.Indefinite; 12 | with Conts.Vectors.Generics; 13 | with Conts.Vectors.Storage.Unbounded; 14 | 15 | generic 16 | type Index_Type is (<>); 17 | type Element_Type (<>) is private; 18 | with procedure Free (E : in out Element_Type) is null; 19 | package Conts.Vectors.Indefinite_Unbounded is 20 | 21 | pragma Assertion_Policy 22 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 23 | 24 | package Elements is new Conts.Elements.Indefinite 25 | (Element_Type, Free => Free, Pool => Conts.Global_Pool); 26 | package Storage is new Conts.Vectors.Storage.Unbounded 27 | (Elements => Elements.Traits, 28 | Container_Base_Type => Ada.Finalization.Controlled, 29 | Resize_Policy => Conts.Vectors.Resize_1_5); 30 | package Vectors is new Conts.Vectors.Generics (Index_Type, Storage.Traits); 31 | 32 | subtype Vector is Vectors.Vector; 33 | subtype Cursor is Vectors.Cursor; 34 | subtype Constant_Returned is Elements.Traits.Constant_Returned; 35 | No_Element : Cursor renames Vectors.No_Element; 36 | No_Index : Index_Type renames Vectors.No_Index; 37 | 38 | package Cursors renames Vectors.Cursors; 39 | package Maps renames Vectors.Maps; 40 | 41 | procedure Swap 42 | (Self : in out Cursors.Forward.Container; Left, Right : Index_Type) 43 | renames Vectors.Swap; 44 | 45 | end Conts.Vectors.Indefinite_Unbounded; 46 | -------------------------------------------------------------------------------- /src/conts-vectors-indefinite_unbounded_spark.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | 9 | package body Conts.Vectors.Indefinite_Unbounded_SPARK with SPARK_Mode => Off is 10 | 11 | pragma Assertion_Policy 12 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 13 | 14 | ---------- 15 | -- Copy -- 16 | ---------- 17 | 18 | function Copy (Self : Vector'Class) return Vector'Class is 19 | begin 20 | return Result : Vector do 21 | Result.Assign (Self); 22 | end return; 23 | end Copy; 24 | 25 | end Conts.Vectors.Indefinite_Unbounded_SPARK; 26 | -------------------------------------------------------------------------------- /src/conts-vectors-indefinite_unbounded_spark.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- Unbounded controlled vectors of unconstrained elements 8 | 9 | pragma Ada_2012; 10 | with Conts.Elements.Indefinite_SPARK; 11 | with Conts.Vectors.Generics; 12 | with Conts.Vectors.Storage.Unbounded; 13 | with Conts.Properties.SPARK; 14 | 15 | generic 16 | type Index_Type is (<>); 17 | type Element_Type (<>) is private; 18 | package Conts.Vectors.Indefinite_Unbounded_SPARK with SPARK_Mode is 19 | 20 | pragma Assertion_Policy 21 | (Pre => Suppressible, Ghost => Suppressible, Post => Ignore); 22 | 23 | package Elements is new Conts.Elements.Indefinite_SPARK 24 | (Element_Type, Pool => Conts.Global_Pool); 25 | package Storage is new Conts.Vectors.Storage.Unbounded 26 | (Elements => Elements.Traits, 27 | Container_Base_Type => Limited_Base, 28 | Resize_Policy => Conts.Vectors.Resize_1_5); 29 | package Vectors is new Conts.Vectors.Generics (Index_Type, Storage.Traits); 30 | 31 | subtype Vector is Vectors.Vector; 32 | subtype Cursor is Vectors.Cursor; 33 | subtype Constant_Returned is Elements.Traits.Constant_Returned; 34 | subtype Extended_Index is Vectors.Extended_Index; 35 | 36 | package Cursors renames Vectors.Cursors; 37 | package Maps renames Vectors.Maps; 38 | 39 | subtype Element_Sequence is Vectors.Impl.M.Sequence with Ghost; 40 | 41 | use type Element_Sequence; 42 | 43 | function Copy (Self : Vector'Class) return Vector'Class; 44 | -- Return a deep copy of Self 45 | 46 | procedure Swap 47 | (Self : in out Cursors.Forward.Container; Left, Right : Index_Type) 48 | renames Vectors.Swap; 49 | 50 | package Content_Models is new Conts.Properties.SPARK.Content_Models 51 | (Map_Type => Vectors.Base_Vector'Class, 52 | Element_Type => Element_Type, 53 | Model_Type => Element_Sequence, 54 | Index_Type => Vectors.Impl.M.Extended_Index, 55 | Model => Vectors.Impl.Model, 56 | Get => Vectors.Impl.M.Get, 57 | First => Vectors.Impl.M.First, 58 | Last => Vectors.Impl.M.Last); 59 | 60 | end Conts.Vectors.Indefinite_Unbounded_SPARK; 61 | -------------------------------------------------------------------------------- /src/conts-vectors-storage-bounded.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | 9 | package body Conts.Vectors.Storage.Bounded with SPARK_Mode => Off is 10 | 11 | ---------- 12 | -- Impl -- 13 | ---------- 14 | 15 | package body Impl is 16 | 17 | --------------------- 18 | -- Release_Element -- 19 | --------------------- 20 | 21 | procedure Release_Element 22 | (Self : in out Container'Class; Index : Count_Type) is 23 | begin 24 | Elements.Release (Self.Nodes (Index)); 25 | end Release_Element; 26 | 27 | ----------------- 28 | -- Set_Element -- 29 | ----------------- 30 | 31 | procedure Set_Element 32 | (Self : in out Container'Class; 33 | Index : Count_Type; 34 | Element : Elements.Stored_Type) is 35 | begin 36 | Self.Nodes (Index) := Element; 37 | end Set_Element; 38 | 39 | ------------ 40 | -- Assign -- 41 | ------------ 42 | 43 | procedure Assign 44 | (Self : in out Container'Class; 45 | Source : Container'Class; 46 | Last : Count_Type) is 47 | begin 48 | Copy (Self, Source, Min_Index, Last, Min_Index); 49 | end Assign; 50 | 51 | ---------- 52 | -- Copy -- 53 | ---------- 54 | 55 | procedure Copy 56 | (Self : in out Container'Class; 57 | Source : Container'Class; 58 | Source_From, Source_To : Count_Type; 59 | Self_From : Count_Type) is 60 | begin 61 | if Elements.Copyable then 62 | Self.Nodes (Self_From .. Self_From + Source_To - Source_From) := 63 | Source.Nodes (Source_From .. Source_To); 64 | else 65 | for J in Source_From .. Source_To loop 66 | Self.Nodes (Self_From + J - Source_From) := 67 | Elements.Copy (Source.Nodes (J)); 68 | end loop; 69 | end if; 70 | end Copy; 71 | end Impl; 72 | 73 | end Conts.Vectors.Storage.Bounded; 74 | -------------------------------------------------------------------------------- /src/conts-vectors-storage-bounded.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- This package describes the underlying storage strategy for a bounded vector 8 | 9 | pragma Ada_2012; 10 | with Conts.Elements; 11 | 12 | generic 13 | with package Elements is new Conts.Elements.Traits (<>); 14 | 15 | type Container_Base_Type is abstract tagged limited private; 16 | -- The base type for the container of nodes. 17 | -- Since this type is eventually also used as the base type for the list 18 | -- itself, this is a way to make lists either controlled or limited. 19 | 20 | package Conts.Vectors.Storage.Bounded with SPARK_Mode is 21 | 22 | package Impl is 23 | type Container (Capacity : Count_Type) 24 | is abstract new Container_Base_Type with private; 25 | 26 | function Max_Capacity (Self : Container'Class) return Count_Type 27 | is (Self.Capacity) with Inline; 28 | function Capacity (Self : Container'Class) return Count_Type 29 | is (Self.Capacity) with Inline; 30 | procedure Release_Element 31 | (Self : in out Container'Class; Index : Count_Type) with Inline; 32 | procedure Set_Element 33 | (Self : in out Container'Class; 34 | Index : Count_Type; 35 | Element : Elements.Stored_Type) with Inline; 36 | function Get_Element 37 | (Self : Container'Class; 38 | Index : Count_Type) return Elements.Stored_Type with Inline; 39 | procedure Assign 40 | (Self : in out Container'Class; 41 | Source : Container'Class; 42 | Last : Count_Type); 43 | procedure Copy 44 | (Self : in out Container'Class; 45 | Source : Container'Class; 46 | Source_From, Source_To : Count_Type; 47 | Self_From : Count_Type) with Inline; 48 | 49 | private 50 | pragma SPARK_Mode (Off); 51 | type Elem_Array is array (Count_Type range <>) of Elements.Stored_Type; 52 | 53 | type Container (Capacity : Count_Type) is 54 | abstract new Container_Base_Type 55 | with record 56 | Nodes : Elem_Array (Min_Index .. Capacity); 57 | end record; 58 | 59 | function Get_Element 60 | (Self : Container'Class; 61 | Index : Count_Type) return Elements.Stored_Type 62 | is (Self.Nodes (Index)); 63 | end Impl; 64 | 65 | package Traits is new Conts.Vectors.Storage.Traits 66 | (Elements => Elements, 67 | Container => Impl.Container, 68 | Max_Capacity => Impl.Max_Capacity, 69 | Capacity => Impl.Capacity, 70 | Release_Element => Impl.Release_Element, 71 | Set_Element => Impl.Set_Element, 72 | Get_Element => Impl.Get_Element, 73 | Assign => Impl.Assign, 74 | Copy => Impl.Copy); 75 | 76 | end Conts.Vectors.Storage.Bounded; 77 | -------------------------------------------------------------------------------- /src/conts-vectors-storage-bounded_definite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | 9 | package body Conts.Vectors.Storage.Bounded_Definite with SPARK_Mode => Off is 10 | 11 | ---------- 12 | -- Impl -- 13 | ---------- 14 | 15 | package body Impl is 16 | 17 | ----------------- 18 | -- Set_Element -- 19 | ----------------- 20 | 21 | procedure Set_Element 22 | (Self : in out Container'Class; 23 | Index : Count_Type; 24 | Element : Stored_Type) is 25 | begin 26 | Self.Nodes (Index) := Element; 27 | end Set_Element; 28 | 29 | ------------ 30 | -- Assign -- 31 | ------------ 32 | 33 | procedure Assign 34 | (Self : in out Container'Class; 35 | Source : Container'Class; 36 | Last : Count_Type) is 37 | begin 38 | Copy (Self, Source, Min_Index, Last, Min_Index); 39 | end Assign; 40 | 41 | ---------- 42 | -- Copy -- 43 | ---------- 44 | 45 | procedure Copy 46 | (Self : in out Container'Class; 47 | Source : Container'Class; 48 | Source_From, Source_To : Count_Type; 49 | Self_From : Count_Type) is 50 | begin 51 | Self.Nodes (Self_From .. Self_From + Source_To - Source_From) := 52 | Source.Nodes (Source_From .. Source_To); 53 | end Copy; 54 | end Impl; 55 | 56 | end Conts.Vectors.Storage.Bounded_Definite; 57 | -------------------------------------------------------------------------------- /src/conts-vectors-storage-bounded_definite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- The implementation for bounded vectors of definite elements. 8 | -- This implementation does not perform any memory allocation. 9 | -- It is compatible with SPARK. 10 | 11 | pragma Ada_2012; 12 | with Conts.Elements.Definite; 13 | 14 | generic 15 | with package Elements is new Conts.Elements.Definite (<>); 16 | package Conts.Vectors.Storage.Bounded_Definite with SPARK_Mode is 17 | 18 | subtype Stored_Type is Elements.Traits.Stored; 19 | 20 | package Impl is 21 | type Container (Capacity : Count_Type) is abstract tagged private; 22 | 23 | function Max_Capacity (Self : Container'Class) return Count_Type 24 | is (Self.Capacity) with Inline; 25 | function Capacity (Self : Container'Class) return Count_Type 26 | is (Self.Capacity) with Inline; 27 | procedure Set_Element 28 | (Self : in out Container'Class; 29 | Index : Count_Type; 30 | Element : Stored_Type) with Inline; 31 | function Get_Element 32 | (Self : Container'Class; 33 | Index : Count_Type) return Stored_Type with Inline; 34 | procedure Assign 35 | (Self : in out Container'Class; 36 | Source : Container'Class; 37 | Last : Count_Type); 38 | procedure Copy 39 | (Self : in out Container'Class; 40 | Source : Container'Class; 41 | Source_From, Source_To : Count_Type; 42 | Self_From : Count_Type) with Inline; 43 | 44 | private 45 | pragma SPARK_Mode (Off); 46 | type Elem_Array is array (Count_Type range <>) of Stored_Type; 47 | 48 | type Container (Capacity : Count_Type) is abstract tagged record 49 | Nodes : Elem_Array (Min_Index .. Capacity); 50 | end record; 51 | 52 | function Get_Element 53 | (Self : Container'Class; 54 | Index : Count_Type) return Stored_Type 55 | is (Self.Nodes (Index)); 56 | end Impl; 57 | 58 | package Traits is new Conts.Vectors.Storage.Traits 59 | (Elements => Elements.Traits, 60 | Container => Impl.Container, 61 | Max_Capacity => Impl.Max_Capacity, 62 | Capacity => Impl.Capacity, 63 | Set_Element => Impl.Set_Element, 64 | Get_Element => Impl.Get_Element, 65 | Assign => Impl.Assign, 66 | Copy => Impl.Copy); 67 | 68 | end Conts.Vectors.Storage.Bounded_Definite; 69 | -------------------------------------------------------------------------------- /src/conts-vectors-storage-unbounded.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- This package describes the underlying storage strategy for a vector. 8 | -- There are mostly two such strategies (bounded and unbounded) depending on 9 | -- whether the vector has a maximal number of elements. 10 | 11 | pragma Ada_2012; 12 | with Conts.Elements; 13 | 14 | generic 15 | with package Elements is new Conts.Elements.Traits (<>); 16 | type Container_Base_Type is abstract tagged limited private; 17 | with package Resize_Policy is new Conts.Vectors.Resize_Strategy (<>); 18 | package Conts.Vectors.Storage.Unbounded with SPARK_Mode is 19 | 20 | package Impl with SPARK_Mode is 21 | type Container is abstract new Container_Base_Type with private; 22 | 23 | function Max_Capacity (Self : Container'Class) return Count_Type 24 | is (Count_Type'Last - Min_Index + 1) with Inline; 25 | function Capacity (Self : Container'Class) return Count_Type 26 | with Inline; 27 | procedure Release_Element 28 | (Self : in out Container'Class; Index : Count_Type) with Inline; 29 | function Get_Element 30 | (Self : Container'Class; 31 | Index : Count_Type) return Elements.Stored_Type with Inline; 32 | procedure Set_Element 33 | (Self : in out Container'Class; 34 | Index : Count_Type; 35 | Element : Elements.Stored_Type) with Inline; 36 | procedure Copy 37 | (Self : in out Container'Class; 38 | Source : Container'Class; 39 | Source_From, Source_To : Count_Type; 40 | Self_From : Count_Type) with Inline; 41 | procedure Assign 42 | (Self : in out Container'Class; 43 | Source : Container'Class; 44 | Last : Count_Type); 45 | procedure Resize 46 | (Self : in out Container'Class; 47 | New_Size : Count_Type; 48 | Last : Count_Type; 49 | Force : Boolean) 50 | with Pre => New_Size <= Self.Max_Capacity; 51 | procedure Release (Self : in out Container'Class); 52 | 53 | private 54 | pragma SPARK_Mode (Off); 55 | type Big_Nodes_Array is 56 | array (Min_Index .. Count_Type'Last) of Elements.Stored_Type; 57 | type Nodes_Array_Access is access Big_Nodes_Array; 58 | for Nodes_Array_Access'Storage_Size use 0; 59 | -- The nodes is a C-compatible pointer so that we can use realloc 60 | 61 | type Container is abstract new Container_Base_Type with record 62 | Nodes : Nodes_Array_Access; 63 | 64 | Capacity : Count_Type := 0; 65 | -- Last element in Nodes (since Nodes does not contain bounds 66 | -- information). 67 | end record; 68 | 69 | function Capacity (Self : Container'Class) return Count_Type 70 | is (Self.Capacity); 71 | function Get_Element 72 | (Self : Container'Class; 73 | Index : Count_Type) return Elements.Stored_Type 74 | is (Self.Nodes (Index)); 75 | end Impl; 76 | 77 | package Traits is new Conts.Vectors.Storage.Traits 78 | (Elements => Elements, 79 | Container => Impl.Container, 80 | Max_Capacity => Impl.Max_Capacity, 81 | Capacity => Impl.Capacity, 82 | Resize => Impl.Resize, 83 | Release_Element => Impl.Release_Element, 84 | Release => Impl.Release, 85 | Set_Element => Impl.Set_Element, 86 | Get_Element => Impl.Get_Element, 87 | Assign => Impl.Assign, 88 | Copy => Impl.Copy); 89 | 90 | end Conts.Vectors.Storage.Unbounded; 91 | -------------------------------------------------------------------------------- /src/conts-vectors.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | 9 | package Conts.Vectors with SPARK_Mode => On is 10 | 11 | generic 12 | with function Grow 13 | (Current_Size, Min_Expected_Size : Count_Type) return Count_Type; 14 | with function Shrink 15 | (Current_Size, Min_Expected_Size : Count_Type) return Count_Type; 16 | package Resize_Strategy is 17 | end Resize_Strategy; 18 | -- This package is used whenever a vector needs to be resized, and 19 | -- must return the new size. There are two cases: 20 | -- Grow: 21 | -- Space for more elements must be added to the vector. A common 22 | -- strategy is to double the size, although it is also possible to 23 | -- chose to add a fixed number of elements. 24 | -- Shrink: 25 | -- The vector is too big for what it needs. In general, it should 26 | -- not immediately resize and free memory, in case elements are 27 | -- added just afterwards. 28 | -- 29 | -- Current_Size might be 0, so simply multiplying is not enough. 30 | 31 | function Grow_1_5 32 | (Current_Size, Min_Expected : Count_Type) return Count_Type with Inline; 33 | function Shrink_1_5 34 | (Current_Size, Min_Expected : Count_Type) return Count_Type with Inline; 35 | package Resize_1_5 is new Resize_Strategy 36 | (Grow => Grow_1_5, Shrink => Shrink_1_5); 37 | -- A package that multiplies the size by 1.5 every time some more space 38 | -- is needed. 39 | 40 | private 41 | 42 | function Grow_1_5 43 | (Current_Size, Min_Expected : Count_Type) return Count_Type 44 | is (if Current_Size < Min_Expected 45 | then Count_Type'Max 46 | (Min_Expected, Count_Type'Max (4, Current_Size * 3 / 2)) 47 | else Current_Size); 48 | 49 | function Shrink_1_5 50 | (Current_Size, Min_Expected : Count_Type) return Count_Type 51 | is (Min_Expected); 52 | 53 | end Conts.Vectors; 54 | -------------------------------------------------------------------------------- /src/conts.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Ada.Unchecked_Conversion; 9 | with Interfaces; use Interfaces; 10 | 11 | package body Conts with SPARK_Mode is 12 | 13 | ------------------- 14 | -- Ranged_Random -- 15 | ------------------- 16 | 17 | procedure Ranged_Random 18 | (Self : in out Random.Generator; Result : out Random.Discrete) 19 | is 20 | use Random; 21 | begin 22 | -- These tests are performed statically by the compiler. 23 | -- Special case to avoid division by zero below 24 | if Min = Max then 25 | Result := Min; 26 | 27 | elsif Min = Discrete'First 28 | and then Max = Discrete'Last 29 | then 30 | Random.Random (Self, Result => Result); 31 | 32 | elsif Discrete'Base'Size > 32 then 33 | declare 34 | -- In the 64-bit case, we have to be careful, since not all 64-bit 35 | -- unsigned values are representable in GNAT's root_integer type. 36 | -- Ignore different-size warnings here since GNAT's handling 37 | -- is correct. 38 | 39 | pragma Warnings ("Z"); 40 | function Conv_To_Unsigned is 41 | new Ada.Unchecked_Conversion (Discrete'Base, Unsigned_64); 42 | function Conv_To_Result is 43 | new Ada.Unchecked_Conversion (Unsigned_64, Discrete'Base); 44 | pragma Warnings ("z"); 45 | 46 | N : constant Unsigned_64 := 47 | Conv_To_Unsigned (Max) - Conv_To_Unsigned (Min) + 1; 48 | Slop : constant Unsigned_64 := Unsigned_64'Last rem N + 1; 49 | X2 : Discrete; 50 | X : Unsigned_64; 51 | 52 | begin 53 | loop 54 | Random.Random (Self, Result => X2); 55 | X := Discrete'Pos (X2); 56 | exit when Slop = N or else X <= Unsigned_64'Last - Slop; 57 | end loop; 58 | Result := Conv_To_Result (Conv_To_Unsigned (Min) + X rem N); 59 | end; 60 | 61 | else 62 | declare 63 | N : constant Unsigned_32 := 64 | Unsigned_32 (Discrete'Pos (Max) - Discrete'Pos (Min) + 1); 65 | Slop : constant Unsigned_32 := Unsigned_32'Last rem N + 1; 66 | X : Unsigned_32; 67 | X2 : Discrete; 68 | begin 69 | loop 70 | Random.Random (Self, Result => X2); 71 | X := Discrete'Pos (X2); 72 | exit when Slop = N or else X <= Unsigned_32'Last - Slop; 73 | end loop; 74 | 75 | Result := Discrete'Val 76 | (Discrete'Pos (Min) + Unsigned_32'Pos (X rem N)); 77 | end; 78 | end if; 79 | end Ranged_Random; 80 | 81 | -------------------- 82 | -- Default_Random -- 83 | -------------------- 84 | 85 | package body Default_Random is 86 | 87 | ------------ 88 | -- Random -- 89 | ------------ 90 | 91 | procedure Random (Gen : in out Generator; Result : out Discrete_Type) is 92 | begin 93 | Result := Ada_Random.Random (Gen); 94 | end Random; 95 | end Default_Random; 96 | 97 | end Conts; 98 | -------------------------------------------------------------------------------- /tests/algo_equals/main.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Ada.Finalization; 9 | with Conts.Algorithms; use Conts.Algorithms; 10 | with Conts.Vectors.Definite_Unbounded; 11 | with Ada.Text_IO; use Ada.Text_IO; 12 | 13 | procedure Main is 14 | subtype Index_Type is Positive; 15 | 16 | package Int_Vecs is new Conts.Vectors.Definite_Unbounded 17 | (Index_Type, Integer, Ada.Finalization.Controlled); 18 | use Int_Vecs; 19 | function Equals is new Conts.Algorithms.Equals 20 | (Cursors => Int_Vecs.Cursors.Random_Access, 21 | Getters => Int_Vecs.Maps.Element_From_Index); 22 | 23 | V1, V2 : Vector; 24 | 25 | begin 26 | if not Equals (V1, V2) then 27 | Put_Line ("Empty Vectors should be equal"); 28 | end if; 29 | 30 | for J in 1 .. 40 loop 31 | V1.Append (J); 32 | end loop; 33 | 34 | if Equals (V1, V2) then 35 | Put_Line ("Comparing non-empty and empty Vectors should not be equal"); 36 | end if; 37 | if Equals (V2, V1) then 38 | Put_Line ("Comparing empty and non-empty Vectors should not be equal"); 39 | end if; 40 | if not Equals (V2, V2) then 41 | Put_Line ("Comparing with self should be equal"); 42 | end if; 43 | 44 | for J in 1 .. 39 loop 45 | V2.Append (J); 46 | end loop; 47 | 48 | if Equals (V1, V2) then 49 | Put_Line ("Vectors of different lengths should not be equal"); 50 | end if; 51 | 52 | V2.Append (40); 53 | 54 | if not Equals (V1, V2) then 55 | Put_Line ("Vectors should be equal"); 56 | end if; 57 | 58 | end Main; 59 | -------------------------------------------------------------------------------- /tests/algo_equals/test.yaml: -------------------------------------------------------------------------------- 1 | description: 'Tests for the Equals algorithm' 2 | driver: 'build_and_exec' 3 | -------------------------------------------------------------------------------- /tests/algo_shuffle/main.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Ada.Finalization; 9 | with Conts.Algorithms; use Conts.Algorithms; 10 | with Conts.Vectors.Definite_Unbounded; 11 | with Ada.Text_IO; use Ada.Text_IO; 12 | 13 | procedure Main is 14 | subtype Index_Type is Positive; 15 | 16 | package Int_Vecs is new Conts.Vectors.Definite_Unbounded 17 | (Index_Type, Integer, Ada.Finalization.Controlled); 18 | use Int_Vecs; 19 | package Rand is new Conts.Default_Random (Extended_Index); 20 | procedure Shuffle is new Conts.Algorithms.Shuffle 21 | (Cursors => Int_Vecs.Cursors.Random_Access, 22 | Random => Rand.Traits); 23 | function Equals is new Conts.Algorithms.Equals 24 | (Cursors => Int_Vecs.Cursors.Random_Access, 25 | Getters => Int_Vecs.Maps.Element_From_Index); 26 | 27 | V, V2 : Vector; 28 | G : Rand.Generator; 29 | 30 | begin 31 | for J in 1 .. 40 loop 32 | V.Append (J); 33 | end loop; 34 | 35 | Rand.Reset (G); 36 | 37 | V2 := V; 38 | Shuffle (V, G); 39 | if Equals (V, V2) then 40 | Put_Line ("Shuffle should change the order of elements"); 41 | end if; 42 | 43 | V2 := V; 44 | Shuffle (V, G); 45 | if Equals (V, V2) then 46 | Put_Line ("Shuffle should change the order of elements"); 47 | end if; 48 | 49 | end Main; 50 | -------------------------------------------------------------------------------- /tests/algo_shuffle/test.yaml: -------------------------------------------------------------------------------- 1 | description: 'Test the Shuffle algorithm' 2 | driver: 'build_and_exec' 3 | -------------------------------------------------------------------------------- /tests/algo_sort/test.yaml: -------------------------------------------------------------------------------- 1 | description: 'Test the Sort algorithms' 2 | driver: 'build_and_exec' 3 | mode: 'Production' 4 | -------------------------------------------------------------------------------- /tests/lists_definite_bounded/main.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Conts.Lists.Definite_Bounded; 9 | with Support; 10 | 11 | procedure Main is 12 | package Int_Lists is new Conts.Lists.Definite_Bounded (Integer); 13 | package Tests is new Support 14 | (Image => Integer'Image, 15 | Elements => Int_Lists.Elements.Traits, 16 | Storage => Int_Lists.Storage.Traits, 17 | Lists => Int_Lists.Lists); 18 | L1, L2 : Int_Lists.List (20); 19 | begin 20 | Tests.Test (L1, L2); 21 | end Main; 22 | -------------------------------------------------------------------------------- /tests/lists_definite_bounded/support.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Conts.Elements; 9 | with Conts.Lists.Generics; 10 | with Conts.Lists.Storage; 11 | 12 | generic 13 | 14 | with package Elements is new Conts.Elements.Traits 15 | (Element_Type => Integer, others => <>); 16 | with package Storage is new Conts.Lists.Storage.Traits 17 | (Elements => Elements, others => <>); 18 | with package Lists is new Conts.Lists.Generics 19 | (Storage => Storage); 20 | 21 | with function Image (Self : Elements.Constant_Returned_Type) return String; 22 | 23 | package Support is 24 | 25 | procedure Test (L1, L2 : in out Lists.List); 26 | -- Perform various tests. 27 | -- All lists should be empty on input. This is used to handle bounded 28 | -- lists. 29 | 30 | end Support; 31 | -------------------------------------------------------------------------------- /tests/lists_definite_bounded/test.out: -------------------------------------------------------------------------------- 1 | element loop=[ 1, 2, 3, 4,] 2 | list, cursor loop => 1 3 | list, cursor loop => 2 4 | list, cursor loop => 3 5 | list, cursor loop => 4 6 | assigned list, element loop=[ 1, 2, 3, 4,] 7 | after insert in empty=[ 1, 1, 1,] 8 | after insert=[ 1, 1, 1, 2, 2,] 9 | after insert at head=[ 3, 1, 1, 1, 2, 2,] 10 | after insert in middle=[ 3, 4, 4, 1, 1, 1, 2, 2,] 11 | after replace_element=[ 10, 4, 4, 1, 1, 1, 2, 2,] 12 | after delete head=[ 4, 4, 1, 1, 1, 2, 2,] 13 | after delete 2 at head=[ 1, 1, 1, 2, 2,] 14 | after delete at tail=[ 1, 1, 1, 2,] 15 | -------------------------------------------------------------------------------- /tests/lists_definite_bounded/test.yaml: -------------------------------------------------------------------------------- 1 | description: 'Basic test for lists' 2 | driver: 'build_and_exec' 3 | -------------------------------------------------------------------------------- /tests/lists_definite_limited_bounded/main.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Conts.Elements.Definite; 9 | with Conts.Lists.Generics; 10 | with Conts.Lists.Storage.Bounded; 11 | with Support; 12 | 13 | procedure Main is 14 | package E is new Conts.Elements.Definite (Integer); 15 | package S is new Conts.Lists.Storage.Bounded 16 | (E.Traits, Conts.Limited_Base); 17 | package Int_Lists is new Conts.Lists.Generics (S.Traits); 18 | package Tests is new Support 19 | (Image => Integer'Image, 20 | Elements => E.Traits, 21 | Storage => S.Traits, 22 | Lists => Int_Lists); 23 | L1, L2 : Int_Lists.List (20); 24 | begin 25 | Tests.Test (L1, L2); 26 | end Main; 27 | -------------------------------------------------------------------------------- /tests/lists_definite_limited_bounded/test.yaml: -------------------------------------------------------------------------------- 1 | description: 'Basic test for lists' 2 | driver: 'build_and_exec' 3 | srcdirs: ['../lists_definite_bounded'] 4 | baseline: '../lists_definite_bounded/test.out' 5 | -------------------------------------------------------------------------------- /tests/lists_definite_unbounded/main.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Conts.Lists.Definite_Unbounded; 9 | with Support; 10 | 11 | procedure Main is 12 | package Int_Lists is new Conts.Lists.Definite_Unbounded (Integer); 13 | package Tests is new Support 14 | (Image => Integer'Image, 15 | Elements => Int_Lists.Elements.Traits, 16 | Storage => Int_Lists.Storage.Traits, 17 | Lists => Int_Lists.Lists); 18 | L1, L2 : Int_Lists.List; 19 | begin 20 | Tests.Test (L1, L2); 21 | end Main; 22 | -------------------------------------------------------------------------------- /tests/lists_definite_unbounded/test.yaml: -------------------------------------------------------------------------------- 1 | description: 'Basic test for lists' 2 | driver: 'build_and_exec' 3 | srcdirs: ['../lists_definite_bounded'] 4 | baseline: '../lists_definite_bounded/test.out' 5 | -------------------------------------------------------------------------------- /tests/lists_indefinite_unbounded/main.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Conts.Lists.Indefinite_Unbounded; 9 | with Support; 10 | 11 | procedure Main is 12 | package Int_Lists is new Conts.Lists.Indefinite_Unbounded (Integer); 13 | function Image (R : Int_Lists.Constant_Returned) return String 14 | is (Integer'Image (R)); 15 | package Tests is new Support 16 | (Image => Image, 17 | Elements => Int_Lists.Elements.Traits, 18 | Storage => Int_Lists.Storage.Traits, 19 | Lists => Int_Lists.Lists); 20 | L1, L2 : Int_Lists.List; 21 | begin 22 | Tests.Test (L1, L2); 23 | end Main; 24 | -------------------------------------------------------------------------------- /tests/lists_indefinite_unbounded/test.yaml: -------------------------------------------------------------------------------- 1 | description: 'Basic test for lists' 2 | driver: 'build_and_exec' 3 | srcdirs: ['../lists_definite_bounded'] 4 | baseline: '../lists_definite_bounded/test.out' 5 | -------------------------------------------------------------------------------- /tests/lists_indefinite_unbounded_spark/main.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Conts.Lists.Indefinite_Unbounded_SPARK; 9 | with Support; 10 | 11 | procedure Main is 12 | package Int_Lists is new Conts.Lists.Indefinite_Unbounded_SPARK 13 | (Integer); 14 | package Tests is new Support 15 | (Image => Integer'Image, 16 | Elements => Int_Lists.Elements.Traits, 17 | Storage => Int_Lists.Storage.Traits, 18 | Lists => Int_Lists.Lists); 19 | L1, L2 : Int_Lists.List; 20 | begin 21 | Tests.Test (L1, L2); 22 | end Main; 23 | -------------------------------------------------------------------------------- /tests/lists_indefinite_unbounded_spark/test.yaml: -------------------------------------------------------------------------------- 1 | description: 'Basic test for lists' 2 | driver: 'build_and_exec' 3 | srcdirs: ['../lists_definite_bounded'] 4 | baseline: '../lists_definite_bounded/test.out' 5 | -------------------------------------------------------------------------------- /tests/maps/main.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with System.Assertions; use System.Assertions; 9 | with Ada.Finalization; 10 | with Conts.Maps.Indef_Def_Unbounded; 11 | with Ada.Strings.Hash; 12 | with Ada.Text_IO; use Ada.Text_IO; 13 | 14 | procedure Main is 15 | 16 | package Maps is new Conts.Maps.Indef_Def_Unbounded 17 | (Key_Type => String, 18 | Element_Type => Integer, 19 | Container_Base_Type => Ada.Finalization.Controlled, 20 | Hash => Ada.Strings.Hash); 21 | 22 | M : Maps.Map; 23 | 24 | begin 25 | -- Check looking for an element in an empty table 26 | begin 27 | Put_Line ("Getting element from empty table " & M.Get ("one")'Img); 28 | exception 29 | when Constraint_Error | Assert_Failure => 30 | null; 31 | end; 32 | 33 | M.Set ("one", 1); 34 | M.Set ("two", 2); 35 | M.Set ("three", 3); 36 | M.Set ("four", 4); 37 | M.Set ("five", 5); 38 | M.Set ("six", 6); 39 | M.Set ("seven", 7); 40 | M.Set ("height", 8); 41 | M.Set ("nine", 9); 42 | M.Set ("ten", 10); 43 | 44 | Put_Line ("Value for one is " & M.Get ("one")'Img); 45 | Put_Line ("Value for four is " & M ("four")'Img); 46 | 47 | M.Delete ("one"); 48 | M.Delete ("two"); 49 | M.Delete ("three"); 50 | M.Delete ("four"); 51 | M.Delete ("five"); 52 | M.Delete ("six"); 53 | 54 | Put_Line ("Value for seven is " & M ("seven")'Img); 55 | 56 | begin 57 | Put_Line ("Value for three is " & M ("three")'Img); 58 | Put_Line ("Error, three should have been removed"); 59 | exception 60 | when Constraint_Error | Assert_Failure => 61 | null; -- expected 62 | end; 63 | end Main; 64 | -------------------------------------------------------------------------------- /tests/maps/test.out: -------------------------------------------------------------------------------- 1 | Value for one is 1 2 | Value for four is 4 3 | Value for seven is 7 4 | -------------------------------------------------------------------------------- /tests/maps/test.yaml: -------------------------------------------------------------------------------- 1 | title: 'maps' 2 | description: 'Basic test for maps' 3 | driver: 'build_and_exec' 4 | -------------------------------------------------------------------------------- /tests/perfs/creport.cc: -------------------------------------------------------------------------------- 1 | /**************************************************************************** 2 | * Copyright (C) 2015-2016, AdaCore * 3 | * * 4 | * This library is free software; you can redistribute it and/or modify it * 5 | * under terms of the GNU General Public License as published by the Free * 6 | * Software Foundation; either version 3, or (at your option) any later * 7 | * version. This library is distributed in the hope that it will be useful, * 8 | * but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- * 9 | * TABILITY or FITNESS FOR A PARTICULAR PURPOSE. * 10 | * * 11 | * As a special exception under Section 7 of GPL version 3, you are granted * 12 | * additional permissions described in the GCC Runtime Library Exception, * 13 | * version 3.1, as published by the Free Software Foundation. * 14 | * * 15 | * You should have received a copy of the GNU General Public License and * 16 | * a copy of the GCC Runtime Library Exception along with this program; * 17 | * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * 18 | * . * 19 | * * 20 | ****************************************************************************/ 21 | 22 | #include 23 | 24 | #define START_GROUP 1 25 | #define SAME_GROUP 0 26 | 27 | extern "C" { 28 | extern void end_container_test 29 | (void* output, int allocated, int allocs_count, int frees_count); 30 | extern void end_test 31 | (void* output, int allocated, int allocs_count, int frees_count); 32 | } 33 | 34 | /** 35 | * Counting the number of allocations and frees. 36 | * From 37 | */ 38 | int number_of_allocs = 0; 39 | int number_of_frees = 0; 40 | std::size_t total_allocated = 0; 41 | 42 | void reset_mem() { 43 | number_of_allocs = 0; 44 | number_of_frees = 0; 45 | total_allocated = 0; 46 | } 47 | 48 | void* operator new(std::size_t size) throw(std::bad_alloc) { 49 | ++number_of_allocs; 50 | total_allocated += size; 51 | void *p = malloc(size); 52 | if(!p) throw std::bad_alloc(); 53 | return p; 54 | } 55 | void* operator new [](std::size_t size) throw(std::bad_alloc) { 56 | ++number_of_allocs; 57 | total_allocated += size; 58 | void *p = malloc(size); 59 | if(!p) throw std::bad_alloc(); 60 | return p; 61 | } 62 | void* operator new [](std::size_t size, const std::nothrow_t&) throw() { 63 | ++number_of_allocs; 64 | total_allocated += size; 65 | return malloc(size); 66 | } 67 | void* operator new (std::size_t size, const std::nothrow_t&) throw() { 68 | ++number_of_allocs; 69 | total_allocated += size; 70 | return malloc(size); 71 | } 72 | void operator delete(void* ptr) throw() { 73 | ++number_of_frees; 74 | free(ptr); 75 | } 76 | void operator delete (void* ptr, const std::nothrow_t&) throw() { 77 | ++number_of_frees; 78 | free(ptr); 79 | } 80 | void operator delete[](void* ptr) throw() { 81 | ++number_of_frees; 82 | free(ptr); 83 | } 84 | void operator delete[](void* ptr, const std::nothrow_t&) throw() { 85 | ++number_of_frees; 86 | free(ptr); 87 | } 88 | 89 | void mem_end_test(void* output) { 90 | end_test (output, total_allocated, number_of_allocs, number_of_frees); 91 | } 92 | 93 | void mem_end_container_test(void* output) { 94 | end_container_test 95 | (output, total_allocated, number_of_allocs, number_of_frees); 96 | } 97 | -------------------------------------------------------------------------------- /tests/perfs/creport.h: -------------------------------------------------------------------------------- 1 | /**************************************************************************** 2 | * Copyright (C) 2015-2016, AdaCore * 3 | * * 4 | * This library is free software; you can redistribute it and/or modify it * 5 | * under terms of the GNU General Public License as published by the Free * 6 | * Software Foundation; either version 3, or (at your option) any later * 7 | * version. This library is distributed in the hope that it will be useful, * 8 | * but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- * 9 | * TABILITY or FITNESS FOR A PARTICULAR PURPOSE. * 10 | * * 11 | * As a special exception under Section 7 of GPL version 3, you are granted * 12 | * additional permissions described in the GCC Runtime Library Exception, * 13 | * version 3.1, as published by the Free Software Foundation. * 14 | * * 15 | * You should have received a copy of the GNU General Public License and * 16 | * a copy of the GCC Runtime Library Exception along with this program; * 17 | * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * 18 | * . * 19 | * * 20 | ****************************************************************************/ 21 | 22 | #define START_GROUP 1 23 | #define SAME_GROUP 0 24 | 25 | extern "C" { 26 | extern const int items_count; 27 | extern const int repeat_count; 28 | extern void start_container_test 29 | (void* output, const char *name, const char* category, int favorite); 30 | extern void save_container_size (void* output, long int size); 31 | extern void start_test 32 | (void* output, const char* name, const int start_group); 33 | extern void end_test_not_run (void* output); 34 | } 35 | 36 | void reset_mem(); 37 | void* operator new(std::size_t size) throw(std::bad_alloc); 38 | void* operator new [](std::size_t size) throw(std::bad_alloc); 39 | void* operator new [](std::size_t size, const std::nothrow_t&) throw(); 40 | void* operator new (std::size_t size, const std::nothrow_t&) throw(); 41 | void operator delete(void* ptr) throw(); 42 | void operator delete (void* ptr, const std::nothrow_t&) throw(); 43 | void operator delete[](void* ptr) throw(); 44 | void operator delete[](void* ptr, const std::nothrow_t&) throw(); 45 | 46 | void mem_end_test(void* output); 47 | void mem_end_container_test(void* output); 48 | -------------------------------------------------------------------------------- /tests/perfs/custom_graph.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Report; use Report; 9 | 10 | package Custom_Graph is 11 | procedure Test_Custom (Stdout : not null access Output'Class); 12 | procedure Test_Adjacency_List (Stdout : not null access Output'Class); 13 | end Custom_Graph; 14 | -------------------------------------------------------------------------------- /tests/perfs/gnat.adc: -------------------------------------------------------------------------------- 1 | pragma Restrictions (No_Tasking); 2 | pragma Restrictions (No_Asynchronous_Control); 3 | pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); 4 | pragma Restrictions (No_Abort_Statements); 5 | pragma Restrictions (No_Streams); 6 | -------------------------------------------------------------------------------- /tests/perfs/graph1_support.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Ada.Text_IO; use Ada.Text_IO; 9 | 10 | package body Graph1_Support is 11 | 12 | Output : constant Boolean := False; 13 | 14 | procedure Set_Color (G : in out Graph; V : Vertex; C : Color) is 15 | begin 16 | G.Colors (V) := C; 17 | end Set_Color; 18 | 19 | function Get_Color (G : Graph; V : Vertex) return Color is 20 | begin 21 | return G.Colors (V); 22 | end Get_Color; 23 | 24 | overriding procedure Initialize_Vertex 25 | (Self : in out My_Visitor2; G : Graph; V : Vertex) 26 | is 27 | pragma Unreferenced (Self, G); 28 | begin 29 | if Output then 30 | Put_Line ("Initialize" & V'Img); 31 | end if; 32 | end Initialize_Vertex; 33 | 34 | overriding procedure Start_Vertex 35 | (Self : in out My_Visitor2; G : Graph; V : Vertex) 36 | is 37 | pragma Unreferenced (Self, G); 38 | begin 39 | if Output then 40 | Put_Line ("Start" & V'Img); 41 | end if; 42 | end Start_Vertex; 43 | 44 | overriding procedure Finish_Vertex 45 | (Self : in out My_Visitor2; G : Graph; V : Vertex) 46 | is 47 | pragma Unreferenced (Self, G); 48 | begin 49 | if Output then 50 | Put_Line ("Finish" & V'Img); 51 | end if; 52 | end Finish_Vertex; 53 | 54 | overriding procedure Discover_Vertex 55 | (Self : in out My_Visitor2; G : Graph; V : Vertex) 56 | is 57 | pragma Unreferenced (Self, G); 58 | begin 59 | if Output then 60 | Put_Line ("Discover" & V'Img); 61 | end if; 62 | end Discover_Vertex; 63 | 64 | function First (G : Graph) return Vertex_Cursor is 65 | begin 66 | return Vertex_Cursor (G.Colors'First); 67 | end First; 68 | 69 | function Element (G : Graph; C : Vertex_Cursor) return Vertex is 70 | pragma Unreferenced (G); 71 | begin 72 | return Vertex (C); 73 | end Element; 74 | 75 | function Has_Element 76 | (G : Graph; C : Vertex_Cursor) return Boolean is 77 | begin 78 | return C <= Vertex_Cursor (G.Colors'Last); 79 | end Has_Element; 80 | 81 | function Next 82 | (G : Graph; C : Vertex_Cursor) return Vertex_Cursor 83 | is 84 | pragma Unreferenced (G); 85 | begin 86 | return C + 1; 87 | end Next; 88 | 89 | function First (G : Graph; V : Vertex) return Edge_Cursor is 90 | pragma Unreferenced (G); 91 | begin 92 | return Edge_Cursor (V); 93 | end First; 94 | 95 | function Element (G : Graph; C : Edge_Cursor) return Edge is 96 | pragma Unreferenced (G); 97 | begin 98 | return (Source => Vertex (C), Target => Vertex (C + 1)); 99 | end Element; 100 | 101 | function Has_Element 102 | (G : Graph; C : Edge_Cursor) return Boolean is 103 | begin 104 | return Integer (C) >= Integer (G.Colors'First) 105 | and then Integer (C) < Integer (G.Colors'Last); 106 | end Has_Element; 107 | 108 | function Next 109 | (G : Graph; C : Edge_Cursor) return Edge_Cursor 110 | is 111 | pragma Unreferenced (C); 112 | begin 113 | -- Only one edge from each vertex 114 | return Edge_Cursor (G.Colors'Last + 1); 115 | end Next; 116 | 117 | function Get_Target (G : Graph; E : Edge) return Vertex is 118 | pragma Unreferenced (G); 119 | begin 120 | return E.Target; 121 | end Get_Target; 122 | 123 | end Graph1_Support; 124 | -------------------------------------------------------------------------------- /tests/perfs/graph1_support.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- An example of wrapping a custom data structure into the various traits 8 | -- packages that are needed to use the graph algorithms 9 | 10 | pragma Ada_2012; 11 | with Conts.Cursors; 12 | with Conts.Elements.Definite; 13 | with Conts.Graphs; use Conts.Graphs; 14 | with Conts.Graphs.DFS; 15 | with Conts.Properties; 16 | with Perf_Support; 17 | 18 | package Graph1_Support is 19 | 20 | ------------ 21 | -- Graphs -- 22 | ------------ 23 | 24 | type Vertex is new Integer; 25 | package Vertices is new Conts.Elements.Definite (Vertex); 26 | 27 | type Edge is record 28 | Source, Target : Vertex; 29 | end record; 30 | 31 | type Color_Map is array (Vertex range <>) of Color; 32 | 33 | type Graph is record 34 | Colors : Color_Map (1 .. Perf_Support.Items_Count); 35 | end record; 36 | 37 | -------------------- 38 | -- Vertex_Cursors -- 39 | -------------------- 40 | 41 | type Vertex_Cursor is new Integer; 42 | function First (G : Graph) return Vertex_Cursor with Inline; 43 | function Element (G : Graph; C : Vertex_Cursor) return Vertex with Inline; 44 | function Has_Element 45 | (G : Graph; C : Vertex_Cursor) return Boolean with Inline; 46 | function Next 47 | (G : Graph; C : Vertex_Cursor) return Vertex_Cursor with Inline; 48 | 49 | package Custom_Vertices is new Conts.Cursors.Forward_Cursors 50 | (Container_Type => Graph, 51 | Cursor_Type => Vertex_Cursor, 52 | No_Element => Vertex_Cursor'Last); 53 | package Vertices_Maps is new Conts.Properties.Read_Only_Maps 54 | (Map_Type => Graph, 55 | Key_Type => Vertex_Cursor, 56 | Element_Type => Vertex, 57 | Get => Element); 58 | 59 | ------------------ 60 | -- Edge_Cursors -- 61 | ------------------ 62 | -- Not a very interesting graph 63 | -- 1 -> 2 -> 3 -> 4 -> 5 -> ... 64 | 65 | type Edge_Cursor is new Integer; 66 | function First (G : Graph; V : Vertex) return Edge_Cursor with Inline; 67 | function Element (G : Graph; C : Edge_Cursor) return Edge with Inline; 68 | function Has_Element 69 | (G : Graph; C : Edge_Cursor) return Boolean with Inline; 70 | function Next 71 | (G : Graph; C : Edge_Cursor) return Edge_Cursor with Inline; 72 | 73 | package Custom_Edges is new Edge_Cursors 74 | (Container_Type => Graph, 75 | Vertices => Vertices.Traits, 76 | Edge_Type => Edge, 77 | Cursor_Type => Edge_Cursor); 78 | 79 | ----------- 80 | -- Graph -- 81 | ----------- 82 | 83 | function Get_Target (G : Graph; E : Edge) return Vertex; 84 | package Custom_Graphs is new Conts.Graphs.Traits 85 | (Graph_Type => Graph, 86 | Vertices => Vertices.Traits, 87 | Null_Vertex => -1, 88 | Edge_Type => Edge, 89 | Vertex_Cursors => Custom_Vertices, 90 | Vertex_Maps => Vertices_Maps, 91 | Out_Edges_Cursors => Custom_Edges); 92 | 93 | ---------------- 94 | -- Color maps -- 95 | ---------------- 96 | 97 | procedure Set_Color (G : in out Graph; V : Vertex; C : Color); 98 | function Get_Color (G : Graph; V : Vertex) return Color; 99 | package Color_Maps is new Conts.Properties.Maps 100 | (Graph, Vertex, Color, Set_Color, Get_Color); 101 | 102 | ---------------------- 103 | -- Incidence_Graphs -- 104 | ---------------------- 105 | 106 | package DFS is new Conts.Graphs.DFS.Interior 107 | (Graphs => Custom_Graphs, 108 | Color_Maps => Color_Maps); 109 | 110 | ---------------- 111 | -- Algorithms -- 112 | ---------------- 113 | 114 | type My_Visitor is new Custom_Graphs.DFS_Visitor with null record; 115 | 116 | type My_Visitor2 is new Custom_Graphs.DFS_Visitor with null record; 117 | overriding procedure Initialize_Vertex 118 | (Self : in out My_Visitor2; G : Graph; V : Vertex); 119 | overriding procedure Start_Vertex 120 | (Self : in out My_Visitor2; G : Graph; V : Vertex); 121 | overriding procedure Finish_Vertex 122 | (Self : in out My_Visitor2; G : Graph; V : Vertex); 123 | overriding procedure Discover_Vertex 124 | (Self : in out My_Visitor2; G : Graph; V : Vertex); 125 | 126 | end Graph1_Support; 127 | -------------------------------------------------------------------------------- /tests/perfs/graph_cpp.cc: -------------------------------------------------------------------------------- 1 | #include // for std::cout 2 | #include // for std::pair 3 | #include // for std::for_each 4 | #include 5 | 6 | // Suppress warnings about deprecated functions 7 | #pragma GCC diagnostic ignored "-Wdeprecated-declarations" 8 | #include 9 | #pragma GCC diagnostic pop 10 | 11 | #include 12 | #include 13 | #include 14 | 15 | extern "C" 16 | void test_cpp_graph(void* output) { 17 | using namespace boost; 18 | 19 | // create a typedef for the Graph type 20 | typedef adjacency_list Graph; 21 | 22 | const int num_vertices = items_count; 23 | 24 | reset_mem(); 25 | start_container_test (output, "C++ Boost", "Graph", 1); 26 | save_container_size (output, sizeof(Graph)); 27 | 28 | for (int r = 0; r < repeat_count; r++) { 29 | start_test (output, "fill", START_GROUP); 30 | Graph g(num_vertices); 31 | for (int i = 0; i < num_vertices - 1; i++) { 32 | add_edge(i, i + 1, g); 33 | } 34 | mem_end_test (output); 35 | 36 | start_test (output, "dfs, no visitor", START_GROUP); 37 | default_dfs_visitor vis; 38 | depth_first_search (g, visitor (vis)); 39 | mem_end_test (output); 40 | 41 | add_edge(num_vertices / 10, 3, g); 42 | add_edge(2 * num_vertices / 10, num_vertices - 1, g); 43 | 44 | start_test (output, "dfs, visitor", SAME_GROUP); 45 | end_test_not_run (output); 46 | 47 | start_test (output, "dfs-recursive, visitor", SAME_GROUP); 48 | end_test_not_run (output); 49 | 50 | start_test (output, "scc", START_GROUP); 51 | std::vector c(num_vertices); 52 | int num = strong_components( 53 | g, 54 | make_iterator_property_map(c.begin(), get(vertex_index, g))); 55 | mem_end_test (output); 56 | } 57 | 58 | mem_end_container_test (output); 59 | } 60 | -------------------------------------------------------------------------------- /tests/perfs/main.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Ada.Command_Line; use Ada.Command_Line; 9 | with Ada.Text_IO; use Ada.Text_IO; 10 | with GNAT.Strings; use GNAT.Strings; 11 | with GNATCOLL.Utils; use GNATCOLL.Utils; 12 | with Perf_Support; use Perf_Support; 13 | with QGen; use QGen; 14 | with Report; use Report; 15 | with System; 16 | with Custom_Graph; 17 | 18 | procedure Main is 19 | procedure Test_Cpp_Graph (Stdout : System.Address) 20 | with Import, Convention => C, External_Name => "test_cpp_graph"; 21 | 22 | Test_Name : String_Access; 23 | Stdout : aliased Output; 24 | 25 | type CPP_Test is not null access procedure (S : System.Address) 26 | with Convention => C; 27 | 28 | procedure Run_Test 29 | (Name : String; 30 | Proc : not null access procedure (S : not null access Output'Class)); 31 | procedure Run_Test (Name : String; Proc : CPP_Test); 32 | -- Run a test if the command line arguments allow it 33 | 34 | procedure Run_Test 35 | (Name : String; 36 | Proc : not null access procedure (S : not null access Output'Class)) is 37 | begin 38 | if Test_Name = null 39 | or else Starts_With (Name, Test_Name.all) 40 | then 41 | Put_Line ("Run " & Name); 42 | Proc (Stdout'Access); 43 | end if; 44 | end Run_Test; 45 | 46 | procedure Run_Test (Name : String; Proc : CPP_Test) is 47 | begin 48 | if Test_Name = null 49 | or else Starts_With (Name, Test_Name.all) 50 | then 51 | Put_Line ("Run " & Name); 52 | Proc (Stdout'Address); 53 | end if; 54 | end Run_Test; 55 | 56 | procedure Run_All; 57 | procedure Run_All is separate; 58 | 59 | begin 60 | if Ada.Command_Line.Argument_Count >= 1 then 61 | Test_Name := new String'(Ada.Command_Line.Argument (1)); 62 | end if; 63 | 64 | Run_Test ("int_list_c++", Test_Cpp_Int_List'Access); 65 | Run_Test ("str_list_c++", Test_Cpp_Str_List'Access); 66 | Run_Test ("int_vector_c++", Test_Cpp_Int_Vector'Access); 67 | Run_Test ("int_vector_ada_arrays", Test_Arrays_Int'Access); 68 | Run_Test ("str_vector_c++", Test_Cpp_Str_Vector'Access); 69 | Run_Test ("intint_map_c++_unordered", 70 | Test_Cpp_Int_Int_Unordered_Map'Access); 71 | Run_Test ("intint_map_c++", Test_Cpp_Int_Int_Map'Access); 72 | Run_Test ("strstr_map_c++_unordered", 73 | Test_Cpp_Str_Str_Unordered_Map'Access); 74 | Run_Test ("strstr_map_c++", Test_Cpp_Str_Str_Map'Access); 75 | Run_All; 76 | 77 | Run_Test ("graph_c++", Test_Cpp_Graph'Access); 78 | Run_Test ("graph_ada_custom", Custom_Graph.Test_Custom'Access); 79 | Run_Test ("graph_ada_adjacency_list", 80 | Custom_Graph.Test_Adjacency_List'Access); 81 | 82 | Test_QGen; 83 | 84 | Stdout.Display; 85 | 86 | Free (Test_Name); 87 | end Main; 88 | -------------------------------------------------------------------------------- /tests/perfs/memory.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | package body Memory is 8 | 9 | ----------- 10 | -- Reset -- 11 | ----------- 12 | 13 | procedure Reset is 14 | begin 15 | Current := (Total_Allocated => 0, 16 | Allocs => 0, 17 | Frees => 0, 18 | Reallocs => 0); 19 | end Reset; 20 | 21 | --------- 22 | -- "-" -- 23 | --------- 24 | 25 | function "-" (M1, M2 : Mem_Info) return Mem_Info is 26 | begin 27 | return (Total_Allocated => M1.Total_Allocated - M2.Total_Allocated, 28 | Allocs => M1.Allocs - M2.Allocs, 29 | Frees => M1.Frees - M2.Frees, 30 | Reallocs => M1.Reallocs - M2.Reallocs); 31 | end "-"; 32 | 33 | ----------- 34 | -- Pause -- 35 | ----------- 36 | 37 | procedure Pause is 38 | begin 39 | Paused := True; 40 | end Pause; 41 | 42 | ------------- 43 | -- Unpause -- 44 | ------------- 45 | 46 | procedure Unpause is 47 | begin 48 | Paused := False; 49 | end Unpause; 50 | end Memory; 51 | -------------------------------------------------------------------------------- /tests/perfs/memory.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | package Memory is 8 | 9 | type Mem_Info is record 10 | Total_Allocated : Long_Long_Integer := 0; 11 | Allocs : Integer := 0; 12 | Frees : Integer := 0; 13 | Reallocs : Integer := 0; 14 | end record; 15 | 16 | Current : Mem_Info; 17 | 18 | function "-" (M1, M2 : Mem_Info) return Mem_Info; 19 | -- Compute the delta between two memory usage 20 | 21 | Paused : Boolean := False; 22 | 23 | procedure Reset; 24 | 25 | procedure Pause; 26 | -- Stop counting allocs and frees 27 | 28 | procedure Unpause; 29 | -- Resume counting 30 | end Memory; 31 | -------------------------------------------------------------------------------- /tests/perfs/perf_support.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Conts.Algorithms; 9 | with Conts.Adaptors; use Conts.Adaptors; 10 | 11 | package body Perf_Support is 12 | 13 | ----------- 14 | -- Image -- 15 | ----------- 16 | 17 | function Image (P : Integer) return String is 18 | Img : constant String := P'Img; 19 | begin 20 | return Img (Img'First + 1 .. Img'Last); 21 | end Image; 22 | 23 | ------------ 24 | -- Assert -- 25 | ------------ 26 | 27 | procedure Assert (Count, Expected : Natural; Reason : String := "") is 28 | begin 29 | if Count /= Expected then 30 | raise Program_Error with "Wrong count (" & Reason & "): got" 31 | & Count'Img & " expected" & Expected'Img; 32 | end if; 33 | end Assert; 34 | 35 | --------------------- 36 | -- Test_Arrays_Int -- 37 | --------------------- 38 | 39 | procedure Test_Arrays_Int (Stdout : not null access Output'Class) is 40 | type Int_Array is array (Natural range <>) of Integer; 41 | package Adaptors is new Array_Adaptors 42 | (Index_Type => Natural, 43 | Element_Type => Integer, 44 | Array_Type => Int_Array); 45 | function Count_If is new Conts.Algorithms.Count_If 46 | (Adaptors.Cursors.Forward, Adaptors.Maps.Element); 47 | 48 | procedure Run (V : in out Int_Array); 49 | procedure Run (V : in out Int_Array) is 50 | Co : Natural := 0; 51 | begin 52 | Stdout.Start_Test ("fill"); 53 | for C in 1 .. Items_Count loop 54 | V (C) := 2; 55 | end loop; 56 | Stdout.End_Test; 57 | 58 | Stdout.Start_Test ("copy"); 59 | declare 60 | V_Copy : Int_Array := V; 61 | pragma Unreferenced (V_Copy); 62 | begin 63 | Stdout.End_Test; 64 | end; 65 | 66 | Co := 0; 67 | Stdout.Start_Test ("cursor loop"); 68 | for It in V'Range loop 69 | if Predicate (V (It)) then 70 | Co := Co + 1; 71 | end if; 72 | end loop; 73 | Stdout.End_Test; 74 | Assert (Co, Items_Count); 75 | 76 | Co := 0; 77 | Stdout.Start_Test ("for-of loop"); 78 | for E of V loop 79 | if Predicate (E) then 80 | Co := Co + 1; 81 | end if; 82 | end loop; 83 | Stdout.End_Test; 84 | Assert (Co, Items_Count); 85 | 86 | Stdout.Start_Test ("count_if"); 87 | Co := Count_If (V, Predicate'Access); 88 | Stdout.End_Test; 89 | Assert (Co, Items_Count); 90 | end Run; 91 | 92 | begin 93 | Stdout.Start_Container_Test ("Ada Array", "Integer Vector"); 94 | for R in 1 .. Repeat_Count loop 95 | declare 96 | V : Int_Array (1 .. Items_Count); 97 | begin 98 | Stdout.Save_Container_Size (V'Size / 8); -- in bytes 99 | Run (V); 100 | end; 101 | end loop; 102 | Stdout.End_Container_Test; 103 | end Test_Arrays_Int; 104 | 105 | end Perf_Support; 106 | -------------------------------------------------------------------------------- /tests/perfs/qgen.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | package body QGen is 8 | 9 | procedure Test_QGen is 10 | S : Sum_List; 11 | begin 12 | S.Append (Sum'(Id => 1, others => <>)); 13 | S.Append (Sum'(Id => 2, others => <>)); 14 | S.Append (Sum'(Id => 3, others => <>)); 15 | 16 | -- Test requires that aspect Iterable supports unconstrained types 17 | -- for E of S loop 18 | -- Put_Line ("E=" & External_Tag (E'Tag)); 19 | -- end loop; 20 | end Test_QGen; 21 | 22 | end QGen; 23 | -------------------------------------------------------------------------------- /tests/perfs/qgen.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Ada.Finalization; 9 | with Conts.Elements.Indefinite; 10 | with Conts.Lists.Storage.Unbounded; 11 | with Conts.Lists.Generics; 12 | 13 | package QGen is 14 | 15 | -- This package checks that an organization as used in the QGen project 16 | -- is compatible with our proposal. 17 | -- We have a hierarchy of types, a matching hierarchy of lists, and when 18 | -- we use a for..of loop on a list, we get the corresponding child type. 19 | -- We do not want to duplicate the instance of lists, the goal is to 20 | -- generate minimal additional code since there are hundreds of such 21 | -- types in QGen. 22 | 23 | type EObject is abstract tagged record 24 | Id : Integer; 25 | end record; 26 | type Block is new EObject with null record; 27 | type Sum is new Block with null record; 28 | 29 | -- We do our own instances (not the ones in 30 | -- Conts.Lists.Indefinite_Unbounded) for better sharing of code. 31 | 32 | package Elements is new Conts.Elements.Indefinite 33 | (EObject'Class, Pool => Conts.Global_Pool); 34 | package Storage is new Conts.Lists.Storage.Unbounded 35 | (Elements.Traits, 36 | Container_Base_Type => Ada.Finalization.Controlled, 37 | Pool => Conts.Global_Pool); 38 | package Lists is new Conts.Lists.Generics (Storage.Traits); 39 | 40 | type EObject_List is new Lists.List with null record 41 | with Iterable => (First => First_Primitive, 42 | Next => Next_Primitive, 43 | Has_Element => Has_Element_Primitive, 44 | Element => Element_Primitive); 45 | 46 | type Block_List is new EObject_List with null record 47 | with Iterable => (First => First_Primitive, 48 | Next => Next_Primitive, 49 | Has_Element => Has_Element_Primitive, 50 | Element => As_Block); 51 | function As_Block (C : Block_List; P : Lists.Impl.Cursor) return Block'Class 52 | is (Block'Class (Lists.Element (C, P).Element.all)) 53 | with Inline => True; 54 | -- ??? We need to use "Lists.Impl.Cursor", and not "Lists.Cursor" above, 55 | -- because of limitations in GNAT and its implementation of the Iterable 56 | -- aspect. 57 | 58 | type Sum_List is new Block_List with null record 59 | with Iterable => (First => First_Primitive, 60 | Next => Next_Primitive, 61 | Has_Element => Has_Element_Primitive, 62 | Element => As_Sum); 63 | function As_Sum (C : Sum_List; P : Lists.Impl.Cursor) return Sum'Class 64 | is (Sum'Class (Lists.Element (C, P).Element.all)) 65 | with Inline => True; 66 | 67 | procedure Test_QGen; 68 | 69 | end QGen; 70 | -------------------------------------------------------------------------------- /tests/perfs/report.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2015-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | -- Support for output of the tests 8 | 9 | with Ada.Unchecked_Conversion; 10 | with Ada.Calendar; use Ada.Calendar; 11 | with GNATCOLL.JSON; use GNATCOLL.JSON; 12 | with Memory; use Memory; 13 | 14 | package Report is 15 | 16 | type Output is tagged private; 17 | 18 | procedure Start_Container_Test 19 | (Self : not null access Output'Class; 20 | Name : String; 21 | Category : String; -- "integer list", "string list", ... 22 | Favorite : Boolean := False); 23 | -- If Favorite is true, the container will be highlighted in the results 24 | 25 | procedure Save_Container_Size 26 | (Self : not null access Output'Class; 27 | Size : Long_Integer); 28 | -- Saves the size of the container in the output (for information only) 29 | 30 | procedure End_Container_Test (Self : not null access Output'Class); 31 | -- A new set of tests is started, for a specific container. 32 | -- This automatically counts the number of allocation and 33 | -- deallocations done by that test. 34 | 35 | procedure Start_Test 36 | (Self : not null access Output'Class; 37 | Name : String; 38 | Comment : String := ""; 39 | Start_Group : Boolean := False); 40 | procedure End_Test (Self : not null access Output'Class); 41 | -- A test on the current container is executed. These procedures measure 42 | -- the execution time. Calling End_Test is optional if you are calling 43 | -- Start_Test immediately. 44 | -- You can run the same test multiple times after calling 45 | -- Start_Container_Test. All timings will be recorded. 46 | -- Tests are grouped, so that the first test run in a group, for the 47 | -- first container, is displayed as "100%", and other tests in the same 48 | -- group are displayed relative to this one. 49 | -- Set Start_Group to True to start a new group. All following tests 50 | -- will belong to the same group, until a test that also sets Start_Group 51 | -- to True. 52 | 53 | procedure End_Test_Not_Run (Self : not null access Output'Class); 54 | -- Same as End_Test, but mark the test as "NOT RUN". 55 | 56 | procedure Display (Self : not null access Output'Class); 57 | -- Outputs the results to a JSON file 58 | 59 | -- generic 60 | -- type Container (<>) is limited private; 61 | -- with procedure Run 62 | -- (Self : in out Container; Col : Column_Number; Start : Time) is <>; 63 | -- procedure Run_Tests 64 | -- (Stdout : in out Output'Class; 65 | -- Title : String; 66 | -- Self : in out Container; 67 | -- Fewer_Items : Boolean := False); 68 | -- For each column defined in Stdout and associated with a test, executes 69 | -- Run. Run can either print some output via Stdout.Print_Line (for 70 | -- instance), or let this procedure print the time on its own. 71 | 72 | private 73 | type Output is tagged record 74 | Global_Result : JSON_Value := JSON_Null; 75 | All_Tests : JSON_Array; 76 | 77 | Container_Test : JSON_Value := JSON_Null; 78 | Tests_In_Container : JSON_Value; 79 | 80 | Current_Test : JSON_Value := JSON_Null; 81 | At_Test_Start : Mem_Info; 82 | Start_Time : Ada.Calendar.Time; 83 | end record; 84 | 85 | end Report; 86 | -------------------------------------------------------------------------------- /tests/perfs/test.out: -------------------------------------------------------------------------------- 1 | Run int_list_c++ 2 | Run str_list_c++ 3 | Run int_vector_c++ 4 | Run int_vector_ada_arrays 5 | Run str_vector_c++ 6 | Run intint_map_c++_unordered 7 | Run intint_map_c++ 8 | Run strstr_map_c++_unordered 9 | Run strstr_map_c++ 10 | Run ada12_bounded 11 | Run ada12_def_unbounded 12 | Run ada12_indef_unbounded 13 | Run ada12_nocheck_def_unbounded 14 | Run indef_unbounded 15 | Run def_unbounded 16 | Run def_bounded 17 | Run indef_unbounded_spark 18 | Run ada12_indef_unbounded 19 | Run ada12_nocheck_indef_unbounded 20 | Run indef_unbounded 21 | Run def_unbounded_string 22 | Run indef_unbounded_spark 23 | Run ada12_bounded 24 | Run ada12_def_unbounded 25 | Run ada12_indef_unbounded 26 | Run ada12_nochecks_definite_unbounded 27 | Run indef_unbounded 28 | Run def_unbounded 29 | Run def_bounded 30 | Run indef_unbounded_spark 31 | Run ada12_indef_unbounded 32 | Run ada12_nochecks_indef_unbounded 33 | Run indef_unbounded 34 | Run indef_unbounded_spark 35 | Run ada12_ordered_def_unbounded 36 | Run ada12_hashed_def_unbounded 37 | Run ada12_hashed_def_bounded 38 | Run hashed_def_def_unbounded 39 | Run hashed_linear_probing_def_def_unbounded 40 | Run ada12_ordered_indef_unbounded 41 | Run ada12_hashed_indef_unbounded 42 | Run hashed_indef_indef_unbounded 43 | Run hashed_linear_probing_indef_indef_unbounded 44 | Run hashed_indef_indef_unbounded_spark 45 | Run graph_c++ 46 | Run graph_ada_custom 47 | Run graph_ada_adjacency_list 48 | Open file:///perfs//index.html 49 | -------------------------------------------------------------------------------- /tests/perfs/test.yaml: -------------------------------------------------------------------------------- 1 | title: 'maps' 2 | description: 'Basic test for maps' 3 | driver: 'build_and_exec' 4 | pre: ['python ./generate_test.py'] 5 | manual: true 6 | project: 'tests_perfs.gpr' 7 | mode: 'Production' 8 | -------------------------------------------------------------------------------- /tests/perfs/tests_perfs.gpr: -------------------------------------------------------------------------------- 1 | with "containers"; 2 | with "containers_shared"; 3 | with "gnatcoll"; 4 | 5 | project Tests_Perfs is 6 | for Source_Dirs use (".", "generated"); 7 | for Object_Dir use "obj"; 8 | for Languages use ("Ada", "C++", "Python"); 9 | for Main use ("main.adb"); 10 | 11 | -- Can be used to indicate the location of the Boost library 12 | -- on the system. 13 | BOOST := external("BOOST", "/usr/include"); 14 | Boost_Include := ("-I" & BOOST, 15 | "-I/opt/local/include"); -- OSX, macports 16 | -- Install directory for Boost (for tests only) 17 | -- It should contain all possible standard directories 18 | 19 | package Compiler extends Containers_Shared.Compiler is 20 | for Switches ("s-memory.adb") use ("-gnatg") 21 | & Compiler'Switches ("Ada"); 22 | for Switches ("C++") use Boost_Include & Compiler'Switches ("C++"); 23 | end Compiler; 24 | package Builder extends Containers_Shared.Builder is 25 | for Global_Configuration_Pragmas use "gnat.adc"; 26 | end Builder; 27 | package Naming renames Containers_Shared.Naming; 28 | package Binder renames Containers_Shared.Binder; 29 | package Linker renames Containers_Shared.Linker; 30 | end Tests_Perfs; 31 | -------------------------------------------------------------------------------- /tests/post/lists.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ignore_Pragma (Assertion_Policy); 8 | 9 | with Conts; use Conts; 10 | with Conts.Lists.Definite_Bounded; 11 | with Conts.Lists.Indefinite_Unbounded_SPARK; 12 | procedure Lists is 13 | 14 | procedure Test_Bounded; 15 | -- Test the bounded definite case 16 | 17 | procedure Test_Unbounded; 18 | -- Test the unbounded indefinite case 19 | 20 | procedure Test_Bounded is 21 | package My_Bounded_Lists is new 22 | Conts.Lists.Definite_Bounded 23 | (Element_Type => Integer); 24 | use My_Bounded_Lists; 25 | 26 | S, L : My_Bounded_Lists.Lists.List (100); 27 | C : Cursor := My_Bounded_Lists.Lists.No_Element; 28 | N : Natural := 0; 29 | begin 30 | C := L.First; 31 | C := L.Last; 32 | 33 | for I in 1 .. 10 loop 34 | L.Append (I); 35 | end loop; 36 | 37 | C := L.Last; 38 | while L.Has_Element (C) loop 39 | L.Insert (C, 0); 40 | C := L.Previous (L.Previous (C)); 41 | end loop; 42 | 43 | pragma Assert (L.Length = 20); 44 | 45 | for C in L loop 46 | if My_Bounded_Lists.Lists.As_Element (L, C) = 0 then 47 | L.Replace_Element (C, 1); 48 | N := N + 1; 49 | end if; 50 | end loop; 51 | 52 | C := L.Previous (L.First); 53 | C := L.Next (L.Last); 54 | 55 | S.Assign (L); 56 | 57 | L.Append (10, 40); 58 | 59 | declare 60 | Position : Cursor := L.Previous (L.Last); 61 | begin 62 | L.Delete (Position, 40); 63 | 64 | Position := L.Previous (L.Last); 65 | 66 | L.Insert (Position, 10, 40); 67 | 68 | L.Delete (Position, 40); 69 | end; 70 | 71 | L.Clear; 72 | end Test_Bounded; 73 | 74 | procedure Test_Unbounded is 75 | package My_Lists is new 76 | Conts.Lists.Indefinite_Unbounded_SPARK 77 | (Element_Type => Integer); 78 | use My_Lists; 79 | 80 | L, S : My_Lists.Lists.List; 81 | C : Cursor := My_Lists.Lists.No_Element; 82 | N : Natural := 0; 83 | begin 84 | C := L.First; 85 | C := L.Last; 86 | 87 | for I in 1 .. 10 loop 88 | L.Append (I); 89 | end loop; 90 | 91 | C := L.Last; 92 | while L.Has_Element (C) loop 93 | L.Insert (C, 0); 94 | C := L.Previous (L.Previous (C)); 95 | end loop; 96 | 97 | pragma Assert (L.Length = 20); 98 | 99 | for C in L loop 100 | if My_Lists.Lists.As_Element (L, C) = 0 then 101 | L.Replace_Element (C, 1); 102 | N := N + 1; 103 | end if; 104 | end loop; 105 | 106 | C := L.Previous (L.First); 107 | C := L.Next (L.Last); 108 | 109 | S.Assign (L); 110 | 111 | L.Append (10, 40); 112 | 113 | declare 114 | Position : Cursor := L.Previous (L.Last); 115 | begin 116 | L.Delete (Position, 40); 117 | 118 | Position := L.Previous (L.Last); 119 | 120 | L.Insert (Position, 10, 40); 121 | 122 | L.Delete (Position, 40); 123 | end; 124 | 125 | L.Clear; 126 | end Test_Unbounded; 127 | begin 128 | Test_Unbounded; 129 | Test_Bounded; 130 | end Lists; 131 | -------------------------------------------------------------------------------- /tests/post/main.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | with Vectors; 8 | with Lists; 9 | with Maps; 10 | 11 | -- This test should be run with assertions enables (in Debug mode). It should 12 | -- exercise the postconditions defined on container subprograms. 13 | 14 | procedure Main is 15 | begin 16 | Vectors; 17 | Lists; 18 | Maps; 19 | end Main; 20 | -------------------------------------------------------------------------------- /tests/post/maps.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ignore_Pragma (Assertion_Policy); 8 | 9 | with Conts; use Conts; 10 | with Conts.Maps.Indef_Indef_Unbounded_SPARK; 11 | with Ada.Strings.Hash; 12 | 13 | procedure Maps is 14 | package My_Maps is new 15 | Conts.Maps.Indef_Indef_Unbounded_SPARK 16 | (Key_Type => String, 17 | Element_Type => Integer, 18 | Hash => Ada.Strings.Hash); 19 | use My_Maps; 20 | 21 | M, S : My_Maps.Map; 22 | C : Cursor := My_Maps.Impl.No_Element; 23 | begin 24 | M.Resize (2); 25 | 26 | C := M.First; 27 | 28 | for I in 1 .. 10 loop 29 | M.Set (Integer'Image (I), I); 30 | end loop; 31 | 32 | M.Resize (38); 33 | M.Resize (11); -- Resize to bigger than number of elements 34 | M.Resize (2); -- Resize to smaller size 35 | 36 | M.Set (M.As_Key (M.First), 0); 37 | 38 | M.Delete (Integer'Image (1)); 39 | 40 | M.Delete (Integer'Image (1)); 41 | 42 | S.Assign (M); 43 | 44 | C := M.First; 45 | 46 | M.Clear; 47 | 48 | end Maps; 49 | -------------------------------------------------------------------------------- /tests/post/test.yaml: -------------------------------------------------------------------------------- 1 | title: 'post' 2 | description: 'Test for exercizing contracts' 3 | driver: 'build_and_exec' 4 | -------------------------------------------------------------------------------- /tests/post/vectors.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ignore_Pragma (Assertion_Policy); 8 | 9 | with Conts; use Conts; 10 | with Conts.Vectors.Indefinite_Unbounded_SPARK; 11 | with Conts.Vectors.Definite_Bounded; 12 | procedure Vectors is 13 | 14 | procedure Test_Bounded; 15 | -- Test the bounded definite case 16 | 17 | procedure Test_Unbounded; 18 | -- Test the unbounded indefinite case 19 | 20 | procedure Test_Bounded is 21 | package My_Vectors is new 22 | Conts.Vectors.Definite_Bounded 23 | (Index_Type => Positive, 24 | Element_Type => Integer); 25 | use My_Vectors; 26 | 27 | V, S : Vector (200); 28 | C : Cursor; 29 | begin 30 | C := V.First; 31 | 32 | for I in 1 .. 10 loop 33 | V.Append (I); 34 | end loop; 35 | 36 | for I in 5 .. 10 loop 37 | V.Insert (10, I); 38 | end loop; 39 | 40 | V.Reserve_Capacity (20); 41 | 42 | V.Shrink_To_Fit; 43 | 44 | V.Resize (20, 0); 45 | 46 | pragma Assert (V.Length = 20); 47 | 48 | V.Resize (10, 100); 49 | 50 | pragma Assert (V.Last_Element = 10); 51 | 52 | V.Replace_Element (3, 42); 53 | 54 | V.Swap (1, 3); 55 | 56 | V.Delete (1); 57 | 58 | pragma Assert (My_Vectors.Vectors.As_Element (V, 1) = 2); 59 | 60 | V.Delete_Last; 61 | 62 | C := V.Next (V.First); 63 | C := V.Previous (C); 64 | 65 | C := V.Previous (V.First); 66 | 67 | S.Assign (V); 68 | 69 | V.Clear; 70 | 71 | V.Append (10, 40); 72 | 73 | V.Delete (V.Last - 1, 40); 74 | 75 | V.Insert (15, 10, 40); 76 | 77 | V.Delete (15, 40); 78 | 79 | for E of S loop 80 | pragma Assert (E in 1 .. 10); 81 | end loop; 82 | end Test_Bounded; 83 | 84 | procedure Test_Unbounded is 85 | package My_Vectors is new 86 | Conts.Vectors.Indefinite_Unbounded_SPARK 87 | (Index_Type => Positive, 88 | Element_Type => Integer); 89 | use My_Vectors; 90 | 91 | V : Vector; 92 | S : Vector; 93 | C : Cursor; 94 | begin 95 | C := V.First; 96 | 97 | for I in 1 .. 10 loop 98 | V.Append (I); 99 | end loop; 100 | 101 | for I in 5 .. 10 loop 102 | V.Insert (10, I); 103 | end loop; 104 | 105 | V.Reserve_Capacity (20); 106 | 107 | V.Shrink_To_Fit; 108 | 109 | V.Resize (20, 0); 110 | 111 | pragma Assert (V.Length = 20); 112 | 113 | V.Resize (10, 100); 114 | 115 | pragma Assert (V.Last_Element = 10); 116 | 117 | V.Replace_Element (3, 42); 118 | 119 | V.Swap (1, 3); 120 | 121 | V.Delete (1); 122 | 123 | pragma Assert (My_Vectors.Vectors.As_Element (V, 1) = 2); 124 | 125 | V.Delete_Last; 126 | 127 | C := V.Next (V.First); 128 | C := V.Previous (C); 129 | 130 | C := V.Previous (V.First); 131 | 132 | S.Assign (V); 133 | 134 | V.Clear; 135 | 136 | V.Append (10, 40); 137 | 138 | V.Delete (V.Last - 1, 40); 139 | 140 | V.Insert (15, 10, 40); 141 | 142 | V.Delete (15, 40); 143 | 144 | for E of S loop 145 | pragma Assert (E in 1 .. 10); 146 | end loop; 147 | end Test_Unbounded; 148 | begin 149 | Test_Unbounded; 150 | Test_Bounded; 151 | end Vectors; 152 | -------------------------------------------------------------------------------- /tests/random/main.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | with Ada.Text_IO; use Ada.Text_IO; 8 | with Conts; use Conts; 9 | 10 | procedure Main is 11 | type My_Subtype is new Integer range 10 .. 20; 12 | package Rand is new Conts.Default_Random (My_Subtype); 13 | 14 | Gen : Rand.Traits.Generator; 15 | 16 | Total : Long_Float := 0.0; 17 | Val : My_Subtype; 18 | 19 | Items_Count : constant := 200_000; 20 | Mean : Long_Float; 21 | 22 | begin 23 | Rand.Reset (Gen); 24 | 25 | for Count in 1 .. Items_Count loop 26 | Rand.Traits.Rand (Gen, Val); 27 | Total := Total + Long_Float (Val); 28 | end loop; 29 | 30 | Mean := Total / Long_Float (Items_Count); 31 | if abs (Mean - 15.0) > 0.2 then 32 | Put_Line ("Standard random numbers"); 33 | Put_Line ("Mean =" & Long_Float'Image (Mean)); 34 | end if; 35 | 36 | declare 37 | procedure Ranged is new Conts.Ranged_Random (Rand.Traits, 12, 14); 38 | begin 39 | Total := 0.0; 40 | for Count in 1 .. Items_Count loop 41 | Ranged (Gen, Val); 42 | Total := Total + Long_Float (Val); 43 | end loop; 44 | 45 | Mean := Total / Long_Float (Items_Count); 46 | if abs (Mean - 13.0) > 0.2 then 47 | Put_Line ("Ranged random numbers"); 48 | Put_Line ("Mean =" & Long_Float'Image (Mean)); 49 | end if; 50 | end; 51 | 52 | end Main; 53 | -------------------------------------------------------------------------------- /tests/random/test.yaml: -------------------------------------------------------------------------------- 1 | description: 'Test the Random numbers API' 2 | driver: 'build_and_exec' 3 | -------------------------------------------------------------------------------- /tests/run-test: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env python 2 | """usage: ./run-test 3 | 4 | Run one Container Test""" 5 | 6 | import os 7 | from support import ContainerTestsuite 8 | 9 | if __name__ == '__main__': 10 | try: 11 | ContainerTestsuite(os.path.dirname(__file__)).test_main() 12 | except KeyboardInterrupt: 13 | pass 14 | -------------------------------------------------------------------------------- /tests/scc/main.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016-2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Ada.Finalization; 9 | with Conts; use Conts; 10 | with Conts.Elements.Null_Elements; use Conts.Elements.Null_Elements; 11 | with Conts.Graphs.Adjacency_List; 12 | with Conts.Graphs.Components; use Conts.Graphs.Components; 13 | with Ada.Text_IO; use Ada.Text_IO; 14 | 15 | procedure Main is 16 | 17 | type Vertex_With_Null is (Null_V, A, B, C, D, E, F, G, H); 18 | subtype Vertex is Vertex_With_Null range A .. Vertex_With_Null'Last; 19 | 20 | package Graphs is new Conts.Graphs.Adjacency_List 21 | (Vertex_Type => Vertex, 22 | Vertex_Properties => Conts.Elements.Null_Elements.Traits, 23 | Edge_Properties => Conts.Elements.Null_Elements.Traits, 24 | Container_Base_Type => Ada.Finalization.Controlled); 25 | use Graphs; 26 | 27 | procedure Strong is new Strongly_Connected_Components 28 | (Graphs.Traits, Graphs.Integer_Maps.As_Map); 29 | 30 | Gr : Graphs.Graph; 31 | Map : Graphs.Integer_Maps.Map; 32 | Count : Positive; 33 | begin 34 | Gr.Add_Vertices 35 | (No_Element, 36 | Count => Vertex'Pos (Vertex'Last) - Vertex'Pos (Vertex'First) + 1); 37 | 38 | Gr.Add_Edge (A, B, No_Element); 39 | Gr.Add_Edge (B, C, No_Element); 40 | Gr.Add_Edge (C, A, No_Element); 41 | Gr.Add_Edge (D, B, No_Element); 42 | Gr.Add_Edge (D, C, No_Element); 43 | Gr.Add_Edge (D, E, No_Element); 44 | Gr.Add_Edge (E, D, No_Element); 45 | Gr.Add_Edge (E, F, No_Element); 46 | Gr.Add_Edge (F, C, No_Element); 47 | Gr.Add_Edge (F, G, No_Element); 48 | Gr.Add_Edge (G, F, No_Element); 49 | Gr.Add_Edge (H, G, No_Element); 50 | Gr.Add_Edge (H, F, No_Element); 51 | Gr.Add_Edge (H, H, No_Element); 52 | 53 | Strong (Gr, Map, Components_Count => Count); 54 | Put_Line ("Found" & Count'Img & " components"); 55 | 56 | for V in Vertex loop 57 | Put_Line ("Component for " & V'Img 58 | & " is" & Graphs.Integer_Maps.Get (Map, V)'Img); 59 | end loop; 60 | end Main; 61 | -------------------------------------------------------------------------------- /tests/scc/test.out: -------------------------------------------------------------------------------- 1 | Found 4 components 2 | Component for A is 1 3 | Component for B is 1 4 | Component for C is 1 5 | Component for D is 3 6 | Component for E is 3 7 | Component for F is 2 8 | Component for G is 2 9 | Component for H is 4 10 | -------------------------------------------------------------------------------- /tests/scc/test.yaml: -------------------------------------------------------------------------------- 1 | title: 'scc' 2 | description: 'Strongly Connected Components' 3 | driver: 'build_and_exec' 4 | -------------------------------------------------------------------------------- /tests/shared/asserts.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with GNAT.IO; use GNAT.IO; 9 | 10 | package body Asserts is 11 | 12 | ------------------------- 13 | -- On_Assertion_Failed -- 14 | ------------------------- 15 | 16 | overriding procedure On_Assertion_Failed 17 | (Self : Testsuite_Reporter; 18 | Msg : String; 19 | Details : String; 20 | Location : String; 21 | Entity : String) 22 | is 23 | pragma Unreferenced (Self); 24 | begin 25 | Put_Line 26 | ((if Msg = "" then "" else Msg & " ") 27 | & "(at " & Location & ", in " & Entity & ")" 28 | & ASCII.LF & " " & Details); 29 | end On_Assertion_Failed; 30 | 31 | end Asserts; 32 | -------------------------------------------------------------------------------- /tests/shared/asserts.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | with GNATCOLL.Asserts; use GNATCOLL.Asserts; 8 | with Conts; use Conts; 9 | 10 | package Asserts is 11 | 12 | type Testsuite_Reporter is new Error_Reporter with null record; 13 | overriding procedure On_Assertion_Failed 14 | (Self : Testsuite_Reporter; 15 | Msg : String; 16 | Details : String; 17 | Location : String; 18 | Entity : String); 19 | 20 | Reporter : Testsuite_Reporter; 21 | 22 | package Testsuite_Asserts is new GNATCOLL.Asserts.Asserts 23 | (Reporter, Enabled => True); 24 | use Testsuite_Asserts; 25 | package Integers is new Compare (Integer, Integer'Image); 26 | package Booleans is new Compare (Boolean, Boolean'Image); 27 | package Counts is new Compare (Count_Type, Count_Type'Image); 28 | end Asserts; 29 | -------------------------------------------------------------------------------- /tests/spark/formal_hashed_sets.ads: -------------------------------------------------------------------------------- 1 | pragma Ada_2012; 2 | with Formal_Hashed_Sets_Impl; 3 | 4 | generic 5 | type Element_Type (<>) is private; 6 | with function "=" (Left, Right : Element_Type) return Boolean is <>; 7 | package Formal_Hashed_Sets with SPARK_Mode is 8 | package Impl is new Formal_Hashed_Sets_Impl (Element_Type); 9 | 10 | type Set is new Impl.Base_Set with null record with 11 | Iterable => (First => First_Primitive, 12 | Next => Next_Primitive, 13 | Has_Element => Has_Element_Primitive, 14 | Element => Element_Primitive); 15 | -- Iteration over sets can be done over cursors or over elements. 16 | 17 | function Model (Self : Set'Class) return Impl.M.Set is 18 | (Impl.Model (Self)) 19 | with Ghost; 20 | pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model); 21 | 22 | end Formal_Hashed_Sets; 23 | -------------------------------------------------------------------------------- /tests/spark/formal_ordered_sets.ads: -------------------------------------------------------------------------------- 1 | pragma Ada_2012; 2 | with Formal_Ordered_Sets_Impl; 3 | 4 | generic 5 | type Element_Type (<>) is private; 6 | with function "<" (E1, E2 : Element_Type) return Boolean is <>; 7 | with function "=" (E1, E2 : Element_Type) return Boolean is <>; 8 | -- Comparison over elements. BEWARE: "=" and "<" should be compatible. 9 | 10 | package Formal_Ordered_Sets with SPARK_Mode is 11 | package Impl is new Formal_Ordered_Sets_Impl (Element_Type); 12 | 13 | type Set is new Impl.Base_Set with null record with 14 | Iterable => (First => First_Primitive, 15 | Next => Next_Primitive, 16 | Has_Element => Has_Element_Primitive, 17 | Element => Element_Primitive); 18 | -- Iteration over sets can be done over cursors or over elements. 19 | 20 | function Model (Self : Set'Class) return Impl.M.Set is 21 | (Impl.Model (Self)) 22 | with Ghost; 23 | pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model); 24 | 25 | end Formal_Ordered_Sets; 26 | -------------------------------------------------------------------------------- /tests/spark/test.out: -------------------------------------------------------------------------------- 1 | conts-cursors.ads:117:13: medium: range check might fail, in instantiation at conts-vectors-generics.ads:276, in instantiation at conts-vectors-definite_bounded.ads:41, in instantiation at use_vectors.ads:29 (e.g. when Left = -3) 2 | conts-cursors.ads:117:13: medium: range check might fail, in instantiation at conts-vectors-generics.ads:276, in instantiation at conts-vectors-indefinite_unbounded_spark.ads:44, in instantiation at use_vectors.ads:125 (e.g. when Left = Zero) 3 | conts-cursors.ads:117:13: medium: range check might fail, in instantiation at conts-vectors-generics.ads:276, in instantiation at conts-vectors-indefinite_unbounded_spark.ads:44, in instantiation at use_vectors.ads:25 (e.g. when Left = -3) 4 | conts-cursors.ads:117:18: medium: precondition might fail, in instantiation at conts-vectors-generics.ads:276, in instantiation at conts-vectors-definite_bounded.ads:41, in instantiation at use_vectors.ads:29 5 | conts-cursors.ads:117:18: medium: precondition might fail, in instantiation at conts-vectors-generics.ads:276, in instantiation at conts-vectors-indefinite_unbounded_spark.ads:44, in instantiation at use_vectors.ads:125 6 | conts-cursors.ads:117:18: medium: precondition might fail, in instantiation at conts-vectors-generics.ads:276, in instantiation at conts-vectors-indefinite_unbounded_spark.ads:44, in instantiation at use_vectors.ads:25 7 | conts-cursors.ads:117:21: medium: overflow check might fail, in instantiation at conts-vectors-generics.ads:276, in instantiation at conts-vectors-definite_bounded.ads:41, in instantiation at use_vectors.ads:29 (e.g. when N = -2147483648) 8 | conts-cursors.ads:117:21: medium: overflow check might fail, in instantiation at conts-vectors-generics.ads:276, in instantiation at conts-vectors-indefinite_unbounded_spark.ads:44, in instantiation at use_vectors.ads:125 (e.g. when N = -2147483648) 9 | conts-cursors.ads:117:21: medium: overflow check might fail, in instantiation at conts-vectors-generics.ads:276, in instantiation at conts-vectors-indefinite_unbounded_spark.ads:44, in instantiation at use_vectors.ads:25 (e.g. when N = -2147483648) 10 | conts-cursors.ads:120:13: medium: range check might fail, in instantiation at conts-vectors-generics.ads:276, in instantiation at conts-vectors-definite_bounded.ads:41, in instantiation at use_vectors.ads:29 (e.g. when Idx = -3) 11 | conts-cursors.ads:120:13: medium: range check might fail, in instantiation at conts-vectors-generics.ads:276, in instantiation at conts-vectors-indefinite_unbounded_spark.ads:44, in instantiation at use_vectors.ads:125 (e.g. when Idx = Zero) 12 | conts-cursors.ads:120:13: medium: range check might fail, in instantiation at conts-vectors-generics.ads:276, in instantiation at conts-vectors-indefinite_unbounded_spark.ads:44, in instantiation at use_vectors.ads:25 (e.g. when Idx = -3) 13 | conts-cursors.ads:120:17: medium: precondition might fail, in instantiation at conts-vectors-generics.ads:276, in instantiation at conts-vectors-definite_bounded.ads:41, in instantiation at use_vectors.ads:29 14 | conts-cursors.ads:120:17: medium: precondition might fail, in instantiation at conts-vectors-generics.ads:276, in instantiation at conts-vectors-indefinite_unbounded_spark.ads:44, in instantiation at use_vectors.ads:125 15 | conts-cursors.ads:120:17: medium: precondition might fail, in instantiation at conts-vectors-generics.ads:276, in instantiation at conts-vectors-indefinite_unbounded_spark.ads:44, in instantiation at use_vectors.ads:25 16 | use_lists.ads:139:17: medium: precondition might fail 17 | use_lists.ads:146:17: medium: precondition might fail 18 | 19 | -------------------------------------------------------------------------------- /tests/spark/test.yaml: -------------------------------------------------------------------------------- 1 | description: 'Prove SPARK code' 2 | driver: 'prove' 3 | sources: ['use_sets.adb', 'use_lists.adb', 'use_maps.adb', 4 | 'use_ordered_sets.adb', 'use_vectors.adb'] 5 | manual: true 6 | sort_output: true 7 | -------------------------------------------------------------------------------- /tests/testsuite.py: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env python 2 | """usage: ./testsuite [OPTIONS] 3 | 4 | Run Containers Testsuite 5 | 6 | Use option 7 | -k do not delete the temporary project files created by the tests 8 | 9 | """ 10 | 11 | import os 12 | from support import ContainerTestsuite 13 | 14 | if __name__ == '__main__': 15 | try: 16 | ContainerTestsuite(os.path.dirname(__file__)).testsuite_main() 17 | except KeyboardInterrupt: 18 | print " interrupted !" 19 | -------------------------------------------------------------------------------- /tests/vectors_definite_bounded/main.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Conts.Vectors.Definite_Bounded; 9 | with Support; use Support; 10 | 11 | procedure Main is 12 | package Int_Vecs is new Conts.Vectors.Definite_Bounded 13 | (Index_Type, Integer); 14 | procedure T is new Support.Test 15 | (Image => Integer'Image, 16 | Elements => Int_Vecs.Elements.Traits, 17 | Storage => Int_Vecs.Storage.Traits, 18 | Vectors => Int_Vecs.Vectors); 19 | V1 : Int_Vecs.Vector (20); 20 | begin 21 | T (V1); 22 | end Main; 23 | -------------------------------------------------------------------------------- /tests/vectors_definite_bounded/support.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Conts.Elements; 9 | with Conts.Vectors.Generics; 10 | with Conts.Vectors.Storage; 11 | 12 | package Support is 13 | subtype Index_Type is Positive; 14 | 15 | generic 16 | with package Elements is new Conts.Elements.Traits 17 | (Element_Type => Integer, others => <>); 18 | with package Storage is new Conts.Vectors.Storage.Traits 19 | (Elements => Elements, others => <>); 20 | with package Vectors is new Conts.Vectors.Generics 21 | (Storage => Storage, Index_Type => Index_Type); 22 | with function Image (Self : Elements.Constant_Returned) return String; 23 | procedure Test (V1 : in out Vectors.Vector); 24 | -- Perform various tests. 25 | -- All vectors should be empty on input. This is used to handle bounded 26 | -- vectors. 27 | 28 | end Support; 29 | -------------------------------------------------------------------------------- /tests/vectors_definite_bounded/test.out: -------------------------------------------------------------------------------- 1 | element loop: [] 2 | one-element vector: [ 1, ] 3 | one-element vector, cursor loop => 1 4 | after append: [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, ] 5 | after delete: [ 2, 3, 5, 7, 8, 9, ] 6 | delete 10 elements at end: [ 2, 3, 5, 7, ] 7 | after swap: [ 9, 3, 5, 7, 8, 2, ] 8 | after swap same element: [ 9, 3, 5, 7, 8, 2, ] 9 | after replace: [ 100, 3, 5, 7, 8, 600, ] 10 | after resize: [ 1, 1, 1, 1, ] 11 | after resize (2): [ 1, 1, 1, 1, 2, 2, ] 12 | after resize (3): [ 1, 1, 1, ] 13 | after resize (4): [] 14 | after insert in empty: [ 1, 1, 1, ] 15 | after insert at end: [ 1, 1, 1, 4, 4, ] 16 | after insert at head: [ 2, 2, 1, 1, 1, 4, 4, ] 17 | -------------------------------------------------------------------------------- /tests/vectors_definite_bounded/test.yaml: -------------------------------------------------------------------------------- 1 | description: 'Basic test for vectors' 2 | driver: 'build_and_exec' 3 | -------------------------------------------------------------------------------- /tests/vectors_definite_unbounded/main.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Ada.Finalization; 9 | with Conts.Vectors.Definite_Unbounded; 10 | with Support; use Support; 11 | 12 | procedure Main is 13 | package Int_Vecs is new Conts.Vectors.Definite_Unbounded 14 | (Index_Type, Integer, Ada.Finalization.Controlled); 15 | procedure T is new Support.Test 16 | (Image => Integer'Image, 17 | Elements => Int_Vecs.Elements.Traits, 18 | Storage => Int_Vecs.Storage.Traits, 19 | Vectors => Int_Vecs.Vectors); 20 | V1 : Int_Vecs.Vector; 21 | begin 22 | T (V1); 23 | end Main; 24 | -------------------------------------------------------------------------------- /tests/vectors_definite_unbounded/test.yaml: -------------------------------------------------------------------------------- 1 | description: 'Basic test for vectors' 2 | driver: 'build_and_exec' 3 | srcdirs: ['../vectors_definite_bounded'] 4 | baseline: '../vectors_definite_bounded/test.out' 5 | -------------------------------------------------------------------------------- /tests/vectors_indefinite_unbounded/main.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Conts.Vectors.Indefinite_Unbounded; 9 | with Support; use Support; 10 | 11 | procedure Main is 12 | package Int_Vecs is new Conts.Vectors.Indefinite_Unbounded 13 | (Index_Type, Integer); 14 | function Image (R : Int_Vecs.Constant_Returned) return String 15 | is (Integer'Image (R)); 16 | procedure T is new Support.Test 17 | (Image => Image, 18 | Elements => Int_Vecs.Elements.Traits, 19 | Storage => Int_Vecs.Storage.Traits, 20 | Vectors => Int_Vecs.Vectors); 21 | V1 : Int_Vecs.Vector; 22 | begin 23 | T (V1); 24 | end Main; 25 | -------------------------------------------------------------------------------- /tests/vectors_indefinite_unbounded/test.yaml: -------------------------------------------------------------------------------- 1 | description: 'Basic test for vectors' 2 | driver: 'build_and_exec' 3 | srcdirs: ['../vectors_definite_bounded'] 4 | baseline: '../vectors_definite_bounded/test.out' 5 | -------------------------------------------------------------------------------- /tests/vectors_indefinite_unbounded_spark/main.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2016, AdaCore 3 | -- 4 | -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 | -- 6 | 7 | pragma Ada_2012; 8 | with Conts.Vectors.Indefinite_Unbounded_SPARK; 9 | with Support; use Support; 10 | 11 | procedure Main is 12 | package Int_Vecs is new Conts.Vectors.Indefinite_Unbounded_SPARK 13 | (Index_Type, Integer); 14 | procedure T is new Support.Test 15 | (Image => Integer'Image, 16 | Elements => Int_Vecs.Elements.Traits, 17 | Storage => Int_Vecs.Storage.Traits, 18 | Vectors => Int_Vecs.Vectors); 19 | V1 : Int_Vecs.Vector; 20 | begin 21 | T (V1); 22 | end Main; 23 | -------------------------------------------------------------------------------- /tests/vectors_indefinite_unbounded_spark/test.yaml: -------------------------------------------------------------------------------- 1 | description: 'Basic test for vectors' 2 | driver: 'build_and_exec' 3 | srcdirs: ['../vectors_definite_bounded'] 4 | baseline: '../vectors_definite_bounded/test.out' 5 | --------------------------------------------------------------------------------