├── .github └── workflows │ ├── build_prove.yml │ ├── generate_doc.yml │ └── run_tests.yml ├── .gitignore ├── LICENSE ├── README.md ├── alire.toml ├── docs └── README.md ├── spark_unbound.gpr ├── src ├── spark_unbound-arrays.adb ├── spark_unbound-arrays.ads ├── spark_unbound-safe_alloc.adb ├── spark_unbound-safe_alloc.ads └── spark_unbound.ads └── tests ├── .gitignore ├── alire.toml ├── src ├── Safe_Alloc │ ├── sa_arrays_tests.adb │ ├── sa_arrays_tests.ads │ ├── sa_definite_tests.adb │ ├── sa_definite_tests.ads │ ├── safe_alloc_suite.adb │ └── safe_alloc_suite.ads ├── Unbound_Array │ ├── ua_append_tests.adb │ ├── ua_append_tests.ads │ ├── unbound_array_suite.adb │ └── unbound_array_suite.ads ├── prove_unbound.adb └── tests.adb └── tests.gpr /.github/workflows/build_prove.yml: -------------------------------------------------------------------------------- 1 | # Builds and Proves Spark_Unbound 2 | name: Build-Prove 3 | 4 | on: 5 | push: 6 | branches: [ main ] 7 | pull_request: 8 | branches: [ main ] 9 | 10 | # Allows to run this workflow manually from the Actions tab 11 | workflow_dispatch: 12 | 13 | jobs: 14 | build: 15 | name: Build 16 | runs-on: ubuntu-latest 17 | 18 | steps: 19 | # Checks-out repository under $GITHUB_WORKSPACE 20 | - uses: actions/checkout@v2 21 | 22 | - uses: ada-actions/toolchain@ce2021 23 | with: 24 | distrib: community 25 | 26 | - uses: alire-project/setup-alire@latest-stable 27 | 28 | - name: Set alr toolchain 29 | run: | 30 | alr toolchain --disable-assistant 31 | alr toolchain --select gnat_external 32 | 33 | - name: Alire build 34 | run: alr build 35 | 36 | 37 | prove: 38 | name: Prove 39 | runs-on: ubuntu-latest 40 | needs: build 41 | defaults: 42 | run: 43 | working-directory: tests 44 | 45 | steps: 46 | - uses: actions/checkout@v2 47 | 48 | - uses: ada-actions/toolchain@ce2021 49 | with: 50 | distrib: community 51 | 52 | - uses: alire-project/setup-alire@latest-stable 53 | 54 | - name: Set alr toolchain 55 | run: | 56 | alr toolchain --disable-assistant 57 | alr toolchain --select gnat_external 58 | 59 | - name: Alire build 60 | run: alr build 61 | 62 | - name: Run GNATprove 63 | run: | 64 | alr printenv --unix 65 | eval `alr printenv --unix` 66 | gnatprove -Ptests.gpr -j0 -u prove_unbound.adb --level=4 --proof-warnings 67 | -------------------------------------------------------------------------------- /.github/workflows/generate_doc.yml: -------------------------------------------------------------------------------- 1 | # Workflow to generate documentation using GNATdoc and publish it as GitHub page 2 | name: Documentation 3 | 4 | on: 5 | push: 6 | branches: [ main ] 7 | 8 | jobs: 9 | gen-doc: 10 | name: Generate Documentation 11 | runs-on: ubuntu-latest 12 | 13 | steps: 14 | - uses: actions/checkout@v2 15 | 16 | - uses: ada-actions/toolchain@ce2021 17 | with: 18 | distrib: community 19 | 20 | - uses: alire-project/setup-alire@latest-stable 21 | 22 | - name: Set alr toolchain 23 | run: | 24 | alr toolchain --disable-assistant 25 | alr toolchain --select gnat_external 26 | 27 | - name: Alire build 28 | run: alr build 29 | 30 | - name: Generate documentation 31 | run: gnatdoc -Pspark_unbound.gpr --no-subprojects -l 32 | 33 | - name: Push documentation to doc-branch 34 | run: | 35 | git config user.name github-actions 36 | git config user.email hatzl.manuel@outlook.com 37 | mv -v obj/gnatdoc/* docs/ 38 | git add docs 39 | git commit -m "Generated documentation" 40 | git push --force origin main:doc 41 | -------------------------------------------------------------------------------- /.github/workflows/run_tests.yml: -------------------------------------------------------------------------------- 1 | # Runs all tests for Spark_Unbound 2 | name: Tests 3 | 4 | on: 5 | push: 6 | branches: [ main ] 7 | pull_request: 8 | branches: [ main ] 9 | 10 | # Allows to run this workflow manually from the Actions tab 11 | workflow_dispatch: 12 | 13 | defaults: 14 | run: 15 | working-directory: tests 16 | 17 | jobs: 18 | test: 19 | name: Test 20 | runs-on: ubuntu-latest 21 | env: 22 | RESULT_FILE: results.txt 23 | FAILURE_CNT: failures.txt 24 | UNEXPECTED_CNT: unexpected.txt 25 | 26 | steps: 27 | - uses: actions/checkout@v2 28 | - uses: actions/setup-python@v2 29 | with: 30 | python-version: '3.x' 31 | 32 | - uses: ada-actions/toolchain@ce2021 33 | with: 34 | distrib: community 35 | 36 | - uses: alire-project/setup-alire@latest-stable 37 | 38 | - name: Set alr toolchain 39 | run: | 40 | alr toolchain --disable-assistant 41 | alr toolchain --select gnat_external 42 | 43 | - name: Alire build 44 | run: | 45 | alr build 46 | 47 | - name: Run tests 48 | run: | 49 | alr run 50 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Object file 2 | *.o 3 | 4 | # Ada Library Information 5 | *.ali 6 | obj/ 7 | lib/ 8 | alire/ 9 | config/ 10 | 11 | # editors 12 | .vscode 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Manuel Hatzl 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # spark_unbound 2 | 3 | ![Build and Prove](https://github.com/mhatzl/spark_unbound/actions/workflows/build_prove.yml/badge.svg?branch=main) 4 | ![Tests](https://github.com/mhatzl/spark_unbound/actions/workflows/run_tests.yml/badge.svg?branch=main) 5 | ![Generate Documentation](https://github.com/mhatzl/spark_unbound/actions/workflows/generate_doc.yml/badge.svg?branch=main) 6 | 7 | `Spark_Unbound` offers generic unbound data structures in *Ada-Spark*. 8 | All data structures are proven with *Spark* to achieve platinum level (functional correctness) and the allocation handles `Storage_Error` internally. 9 | So only a **Stack Overflow** might happen. 10 | 11 | **Note:** Using tools like *GNATstack* can resolve this last error 12 | 13 | ## Added Types 14 | 15 | `Long_Natural` and `Long_Positive` are defined using `Long_Integer` 16 | in `Spark_Unbound` like `Natural` and `Positive` are defined for `Integer`. 17 | 18 | This allows to use `Long_Natural` as return value for the array length. 19 | 20 | According to the GNAT reference manual at [implementation defined characteristics](https://docs.adacore.com/gnat_rm-docs/html/gnat_rm/gnat_rm/implementation_defined_characteristics.html), `Integer` should only represent signed 32-bit even for 64-bit targets. 21 | Therefore, I decided to switch to `Long_Integer` as base to support 64-bit signed integers on 64-bit targets. 22 | 23 | **Note:** `Long_Integer` might still be signed 32-bit on a 64-bit target, but for most targets it should be signed 64-bit. 24 | 25 | ## Supported Data Structures 26 | ### Unbound_Array 27 | 28 | **Note:** Currently, **Unbound_Array** is the only supported unbound data structure. 29 | 30 | This data structure is defined in the [`Spark_Unbound.Arrays`](/src/spark_unbound-arrays.ads) package with according functions and procedures and is intended as a safe replacement of `Ada.Containers.Vectors` 31 | with notable restrictions for creating `Unbound_Array`s and removing the `Cursor` type. 32 | All procedures that might fail have a `Success` output that states if the execution was successful. 33 | 34 | Internally, `Unbound_Array` uses an array that is dynamically allocated and resized on the heap. 35 | 36 | **Note:** The maximum length of an `Unbound_Array` is constrained by `Spark_Unbound.Long_Natural'Range_Length` since `Capacity` and `Length` return `Spark_Unbound.Long_Natural`. 37 | This also means that the biggest possible index_type is `Spark_Unbound.Long_Positive` (Hint: `first = last => 1 element in array`). 38 | 39 | **Current missing functionality:** 40 | 41 | - `Insert`, `Prepend`, `Reverse_Elements`, `Swap` and indexed deletion is not yet implemented 42 | - The sub-package `Generic_Sorting` is not yet implemented 43 | - Other functions/procedures available in `Ada.Containers.Vectors` might never be implemented 44 | 45 | Below is an example on how to use `Unbound_Array`: 46 | 47 | ~~~Ada 48 | with Spark_Unbound.Arrays; 49 | 50 | procedure Test is 51 | package UA_Integer is new Spark_Unbound.Arrays(Element_Type => Integer, Index_Type => Positive); 52 | Test_UA : UA_Integer.Unbound_Array := UA_Integer.To_Unbound_Array(Initial_Capacity => 3); 53 | Success : Boolean; 54 | begin 55 | -- Fill Array 56 | UA_Integer.Append(Test_UA, 1, Success); 57 | UA_Integer.Append(Test_UA, 2, Success); 58 | UA_Integer.Append(Test_UA, 3, Success); 59 | 60 | -- Now Append() needs to resize 61 | UA_Integer.Append(Test_UA, 4, Success); 62 | end Test; 63 | ~~~ 64 | 65 | **Note:** You should check for `Success` after every call to `Append()`. 66 | 67 | ## Safe Allocation 68 | 69 | *Spark* can prove absence of runtime errors except `Storage_Error`, but as discussed in an issue at [AdaCore/ada-spark-rfcs](https://github.com/AdaCore/ada-spark-rfcs/issues/78), 70 | it is possible to catch `Storage_Error` for heap allocations. 71 | Since handling exceptions is not supported in *Spark*, the generic package `Safe_Alloc` is a wrapper with a small part not in *Spark* 72 | that handles `Storage_Error` and returns `null` in that case. 73 | 74 | Below is an example on how to use `Safe_Alloc`: 75 | 76 | ~~~Ada 77 | with Spark_Unbound.Safe_Alloc; 78 | 79 | procedure Test is 80 | type Alloc_Record is record 81 | V1 : Integer; 82 | V2 : Natural; 83 | V3 : Positive; 84 | end record; 85 | 86 | type Record_Acc is access Alloc_Record; 87 | 88 | package Record_Alloc is new Spark_Unbound.Safe_Alloc.Definite(T => Alloc_Record, T_Acc => Record_Acc); 89 | Rec_Acc : Record_Acc; 90 | begin 91 | Rec_Acc := Record_Alloc.Alloc; -- Note: No `new` is set before 92 | 93 | -- check if Rec_Acc is NOT null and then do something 94 | 95 | Record_Alloc.Free(Rec_Acc); 96 | end Test; 97 | ~~~ 98 | 99 | # Proves 100 | 101 | Since *Spark* does not prove generics directly, some instances are used per data structure trying to cover most type ranges. 102 | Those types are located under [tests/src/prove_unbound.adb](). 103 | 104 | The following command executes GNATprove to prove all data structures instantiated in `prove_unbound.adb`: 105 | 106 | ~~~ 107 | gnatprove -Ptests.gpr -j0 -u prove_unbound.adb --level=4 --proof-warnings 108 | ~~~ 109 | 110 | **Note:** As the chosen instance dictates the conducted proves, it is best to run *GNATprove* on your own instance. 111 | 112 | 113 | # Tests 114 | 115 | Tests are set up in the `tests` subdirectory using [AUnit](https://github.com/AdaCore/aunit) to verify the `Safe_Alloc` part that is not in *Spark* 116 | and some functionality of every data structure to serve as a kind of usage guide. 117 | 118 | To run tests manually, move to the `tests` directory and run 119 | 120 | ~~~ 121 | alr run 122 | ~~~ 123 | 124 | # Installation 125 | 126 | `Spark_Unbound` is available as crate in the Alire package manager. 127 | To use the crate in an Alire project, add it with 128 | 129 | ~~~ 130 | alr with spark_unbound 131 | ~~~ 132 | 133 | **Note:** To use Alire with GNAT studio, I use a small Python [script](https://github.com/mhatzl/gps_alire) as GPS plugin to automatically set needed environment variables. 134 | 135 | # Contribution 136 | 137 | Feedback is very much welcomed as I am very new to Ada. 138 | 139 | My focus at the moment is to fix the following GitHub issues: 140 | 141 | - [ ] https://github.com/mhatzl/spark_unbound/issues/3 142 | - [ ] https://github.com/mhatzl/spark_unbound/issues/2 143 | 144 | Any help with them is greatly appreciated. 145 | 146 | # License 147 | 148 | MIT Licensed 149 | 150 | **Note:** The `doc`-branch contains API documentation that was automatically generated by GNATdoc, whose license restrictions for generated files depends on your version of GNATdoc. 151 | 152 | **Note:** If you use this library somewhere, sending me a private message or so would be really nice 🙂 153 | -------------------------------------------------------------------------------- /alire.toml: -------------------------------------------------------------------------------- 1 | name = "spark_unbound" 2 | description = "Unbound data structures in Ada-Spark" 3 | version = "0.2.1" 4 | 5 | long-description = """ 6 | Spark_Unbound is a take on providing generic unbound data structures in Spark. 7 | 8 | In addition to proving general absence of runtime errors, the heap allocation is done in a non-Spark function to catch a possible `Storage_Error`. 9 | This further increases the security and confident use of this library. 10 | 11 | **The following packages are currently available:** 12 | 13 | - `Spark_Unbound.Safe_Alloc`: Providing formally proven safe heap allocation functionality 14 | - `Spark_Unbound.Arrays`: Providing a formally proven alternative to `Ada.Containers.Vector` 15 | 16 | **Note:** If you use this library, starring the repository on GitHub helps me a lot to see if it is even useful for someone else. 17 | """ 18 | 19 | authors = ["Manuel Hatzl"] 20 | maintainers = ["Manuel Hatzl "] 21 | maintainers-logins = ["mhatzl"] 22 | website = "https://github.com/mhatzl/spark_unbound" 23 | 24 | licenses = "MIT" 25 | 26 | tags = ["spark", "unbound"] 27 | 28 | [[depends-on]] 29 | # Needed for Ada.Numerics.Big_Numbers 30 | gnat = "(>=9.3.1 & <2000) | >=2021" 31 | -------------------------------------------------------------------------------- /docs/README.md: -------------------------------------------------------------------------------- 1 | # Spark_Unbound Documentation 2 | ## API 3 | 4 | The API documentation is automatically generated using *GNATdoc*. 5 | The current API documentation of the `main` branch can be seen at [mhatzl.github.io/spark_unbound/](https://mhatzl.github.io/spark_unbound/). 6 | 7 | ## Examples 8 | 9 | Checkout the [tests](/tests/src) directory for some examples on how to use Spark_Unbound. 10 | -------------------------------------------------------------------------------- /spark_unbound.gpr: -------------------------------------------------------------------------------- 1 | with "config/spark_unbound_config.gpr"; 2 | project Spark_Unbound is 3 | 4 | for Library_Name use "Spark_Unbound"; 5 | for Library_Version use Project'Library_Name & ".so." & Spark_Unbound_Config.Crate_Version; 6 | 7 | for Source_Dirs use ("src"); 8 | for Object_Dir use "obj"; 9 | for Create_Missing_Dirs use "True"; 10 | for Library_Dir use "lib"; 11 | 12 | type Library_Type_Type is ("relocatable", "static", "static-pic"); 13 | Library_Type : Library_Type_Type := 14 | external ("SPARK_UNBOUND_LIBRARY_TYPE", external ("LIBRARY_TYPE", "static")); 15 | for Library_Kind use Library_Type; 16 | 17 | type Enabled_Kind is ("enabled", "disabled"); 18 | Compile_Checks : Enabled_Kind := External ("SPARK_UNBOUND_COMPILE_CHECKS", "disabled"); 19 | Runtime_Checks : Enabled_Kind := External ("SPARK_UNBOUND_RUNTIME_CHECKS", "disabled"); 20 | Style_Checks : Enabled_Kind := External ("SPARK_UNBOUND_STYLE_CHECKS", "disabled"); 21 | Contracts_Checks : Enabled_Kind := External ("SPARK_UNBOUND_CONTRACTS", "disabled"); 22 | 23 | type Build_Kind is ("debug", "optimize"); 24 | Build_Mode : Build_Kind := External ("SPARK_UNBOUND_BUILD_MODE", "optimize"); 25 | 26 | Compile_Checks_Switches := (); 27 | case Compile_Checks is 28 | when "enabled" => 29 | Compile_Checks_Switches := 30 | ("-gnatwa", -- All warnings 31 | "-gnatVa", -- All validity checks 32 | "-gnatwe"); -- Warnings as errors 33 | when others => null; 34 | end case; 35 | 36 | Runtime_Checks_Switches := (); 37 | case Runtime_Checks is 38 | when "enabled" => null; 39 | when others => 40 | Runtime_Checks_Switches := 41 | ("-gnatp"); -- Suppress checks 42 | end case; 43 | 44 | Style_Checks_Switches := (); 45 | case Style_Checks is 46 | when "enabled" => 47 | Style_Checks_Switches := 48 | ("-gnatyg", -- GNAT Style checks 49 | "-gnaty-d", -- Disable no DOS line terminators 50 | "-gnatyM80", -- Maximum line length 51 | "-gnatyO"); -- Overriding subprograms explicitly marked as such 52 | when others => null; 53 | end case; 54 | 55 | Contracts_Switches := (); 56 | case Contracts_Checks is 57 | when "enabled" => 58 | Contracts_Switches := 59 | ("-gnata"); -- Enable assertions and contracts 60 | when others => null; 61 | end case; 62 | 63 | Build_Switches := (); 64 | case Build_Mode is 65 | when "optimize" => 66 | Build_Switches := ("-O3", -- Optimization 67 | "-gnatn"); -- Enable inlining 68 | when "debug" => 69 | Build_Switches := ("-g", -- Debug info 70 | "-Og"); -- No optimization 71 | end case; 72 | 73 | package Compiler is 74 | for Default_Switches ("Ada") use 75 | Compile_Checks_Switches & 76 | Build_Switches & 77 | Runtime_Checks_Switches & 78 | Style_Checks_Switches & 79 | Contracts_Switches & 80 | ("-gnatw.X", -- Disable warnings for No_Exception_Propagation 81 | "-gnatQ", -- Don't quit. Generate ALI and tree files even if illegalities 82 | "-gnat2020"); -- Big_Numbers 83 | end Compiler; 84 | 85 | package Binder is 86 | for Switches ("Ada") use ("-Es"); -- Symbolic traceback 87 | end Binder; 88 | 89 | package Documentation is 90 | for Doc_Pattern use "^-"; 91 | -- This considers comments beginning with "---" to be documentation 92 | -- Needed to ignore commented Ghost functions that would break GNATdoc 93 | end Documentation; 94 | 95 | end Spark_Unbound; 96 | -------------------------------------------------------------------------------- /src/spark_unbound-arrays.adb: -------------------------------------------------------------------------------- 1 | with Spark_Unbound.Safe_Alloc; 2 | 3 | package body Spark_Unbound.Arrays with SPARK_Mode is 4 | 5 | package Array_Alloc is new Spark_Unbound.Safe_Alloc.Arrays(Element_Type => Element_Type, Index_Type => Index_Type, Array_Type => Array_Type, Array_Type_Acc => Array_Acc); 6 | 7 | 8 | function Get_Capacity_Offset (Offset : Long_Positive) return Index_Type 9 | is 10 | Arr_Offset : Long_Natural := Long_Natural(Offset) - Long_Natural(Long_Positive'First); 11 | begin 12 | return Index_Type(Long_Integer(Index_Type'First) + Arr_Offset); 13 | end Get_Capacity_Offset; 14 | 15 | 16 | function To_Unbound_Array (Initial_Capacity : Long_Positive) return Unbound_Array 17 | is 18 | Arr_Acc : Array_Acc := Array_Alloc.Alloc(First => Index_Type'First, Last => Get_Capacity_Offset(Initial_Capacity)); 19 | Unbound_Arr : Unbound_Array := Unbound_Array'(Last => No_Index, Arr => Arr_Acc); 20 | begin 21 | return Unbound_Arr; 22 | end To_Unbound_Array; 23 | 24 | 25 | function "=" (Left, Right : Unbound_Array) return Boolean 26 | is 27 | begin 28 | if Left.Arr = null and then Right.Arr = null then 29 | return True; 30 | end if; 31 | 32 | if (Left.Arr = null and then Right.Arr /= null) or else (Left.Arr /= null and then Right.Arr = null) then 33 | return False; 34 | end if; 35 | 36 | if (Last_Index(Left) /= Last_Index(Right)) or else (First_Index(Left) /= First_Index(Right)) then 37 | return False; 38 | end if; 39 | 40 | for I in First_Index(Left) .. Last_Index(Left) loop 41 | if Element(Left, I) /= Element(Right, I) then 42 | return False; 43 | end if; 44 | pragma Loop_Invariant (for all P in First_Index(Left) .. I => Element(Left, P) = Element(Right, P)); 45 | end loop; 46 | 47 | return True; 48 | end "="; 49 | 50 | 51 | function Capacity (Self : Unbound_Array) return Long_Natural 52 | is 53 | begin 54 | if Self.Arr = null then 55 | return Long_Natural'First; 56 | end if; 57 | 58 | return Self.Arr.all'Length; 59 | end Capacity; 60 | 61 | 62 | -- procedure Reserve_Capacity (Self : in out Unbound_Array; Cap : in Count_Type; Success: out Boolean) is 63 | -- begin 64 | -- null; 65 | -- end Reserve_Capacity; 66 | 67 | 68 | procedure Shrink (Self : in out Unbound_Array; New_Capacity : Long_Natural; Success : out Boolean) 69 | is 70 | begin 71 | if New_Capacity = Long_Natural'First then 72 | Clear(Self); 73 | if Self.Arr = null and then Self.Last = No_Index then 74 | Success := True; 75 | return; 76 | else 77 | raise Program_Error; 78 | end if; 79 | end if; 80 | 81 | declare 82 | Arr_Acc : Array_Acc := Array_Alloc.Alloc(First => First_Index(Self), Last => Get_Capacity_Offset(Long_Positive(New_Capacity))); 83 | Tmp : Unbound_Array := Unbound_Array'(Last => No_Index, Arr => Arr_Acc); 84 | begin 85 | if Tmp.Arr = null then 86 | Success := False; 87 | else 88 | if Is_Empty(Self) then 89 | Clear(Self); 90 | else 91 | Move(Tmp, Self); 92 | end if; 93 | 94 | if Self.Arr = null and then Self.Last = No_Index then 95 | Self.Arr := Tmp.Arr; 96 | Self.Last := Tmp.Last; 97 | Success := True; 98 | else 99 | Clear(Tmp); 100 | if Tmp.Arr = null and then Tmp.Last = No_Index then 101 | Success := False; 102 | else 103 | raise Program_Error; 104 | end if; 105 | end if; 106 | end if; 107 | end; 108 | end Shrink; 109 | 110 | 111 | function Length (Self : Unbound_Array) return Long_Natural 112 | is 113 | begin 114 | if Last_Index(Self) = No_Index then 115 | return Long_Natural'First; 116 | end if; 117 | -- abs() needed since indizes might be negative 118 | return Long_Natural(abs(Long_Integer(Last_Index(Self)) - Long_Integer(First_Index(Self))) + 1); -- Last = First leaves room for 1 element 119 | end Length; 120 | 121 | 122 | function Is_Empty (Self : Unbound_Array) return Boolean 123 | is 124 | begin 125 | return Last_Index(Self) = No_Index; 126 | end Is_Empty; 127 | 128 | 129 | procedure Clear (Self : in out Unbound_Array) is 130 | begin 131 | Self.Last := No_Index; 132 | Array_Alloc.Free(Self.Arr); 133 | end Clear; 134 | 135 | 136 | function Element (Self : Unbound_Array; Index : Index_Type) return Element_Type 137 | is 138 | begin 139 | return Self.Arr.all(Index); 140 | end Element; 141 | 142 | 143 | procedure Replace_Element (Self : in out Unbound_Array; Index : in Index_Type; New_Item : in Element_Type) 144 | is 145 | begin 146 | Self.Arr.all(Index) := New_Item; 147 | end Replace_Element; 148 | 149 | 150 | -- procedure Update_Element 151 | -- (Self : in out Unbound_Array; 152 | -- Index : in Index_Type; 153 | -- Process : not null access procedure (Process_Element : in out Element_Type)) is 154 | -- begin 155 | -- Process.all(Self.Arr.all(Index)); 156 | -- end Update_Element; 157 | 158 | 159 | procedure Copy (Target : out Unbound_Array; Source : Unbound_Array; Success: out Boolean) 160 | is 161 | begin 162 | Target.Last := No_Index; 163 | Target.Arr := null; 164 | 165 | if Source.Arr = null then 166 | Success := True; 167 | return; 168 | end if; 169 | 170 | Target.Arr := Array_Alloc.Alloc(First => Source.Arr.all'First, Last => Source.Arr.all'Last); 171 | 172 | if Target.Arr = null then 173 | Success := False; 174 | else 175 | Target.Last := Source.Last; 176 | for I in First_Index(Source) .. Last_Index(Source) loop 177 | Target.Arr.all(I) := Source.Arr.all(I); 178 | pragma Loop_Invariant (for all P in First_Index(Source) .. I => Target.Arr.all(P) = Source.Arr.all(P)); 179 | end loop; 180 | 181 | Success := True; 182 | end if; 183 | end Copy; 184 | 185 | 186 | procedure Move (Target : in out Unbound_Array; Source : in out Unbound_Array) 187 | is 188 | begin 189 | for I in First_Index(Source) .. Last_Index(Source) loop 190 | Target.Arr.all(I) := Source.Arr.all(I); 191 | pragma Loop_Invariant (for all P in First_Index(Source) .. I => Target.Arr.all(P) = Source.Arr.all(P)); 192 | end loop; 193 | Target.Last := Source.Last; 194 | 195 | Source.Last := No_Index; 196 | Array_Alloc.Free(Source.Arr); 197 | 198 | if Source.Arr /= null or else Source.Last /= No_Index then 199 | raise Program_Error; 200 | end if; 201 | end Move; 202 | 203 | 204 | procedure Append (Self : in out Unbound_Array; New_Item : in Element_Type; Success: out Boolean) 205 | is 206 | begin 207 | if Last_Index(Self) < Self.Arr.all'Last then 208 | Self.Last := Self.Last + 1; 209 | Self.Arr.all(Last_Index(Self)) := New_Item; 210 | Success := True; 211 | else 212 | declare 213 | Added_Capacity : Long_Natural := Capacity(Self); -- Try to double array capacity for O(Log(N)) 214 | Ghost_Added_Capactiy : Long_Natural with Ghost; 215 | begin 216 | while (Long_Integer(Index_Type'Last) - Added_Capacity) < Long_Integer(Get_Capacity_Offset(Long_Positive(Capacity(Self)))) and then Added_Capacity > Long_Natural'First loop 217 | Ghost_Added_Capactiy := Added_Capacity; 218 | Added_Capacity := Added_Capacity - 1; 219 | 220 | pragma Loop_Invariant (Added_Capacity = Ghost_Added_Capactiy - 1); 221 | end loop; 222 | 223 | declare 224 | New_Max_Last : Index_Type := Get_Capacity_Offset(Long_Positive(Capacity(Self) + Added_Capacity)); 225 | Ghost_New_Max_Last : Index_Type with Ghost; 226 | Arr_Acc : Array_Acc := null; 227 | Tmp_Last : Extended_Index := Self.Last; 228 | begin 229 | while Arr_Acc = null and then New_Max_Last > Get_Capacity_Offset(Long_Positive(Capacity(Self))) loop 230 | Arr_Acc := Array_Alloc.Alloc(First => Self.Arr.all'First, Last => New_Max_Last); 231 | Ghost_New_Max_Last := New_Max_Last; 232 | New_Max_Last := New_Max_Last - 1; 233 | 234 | pragma Loop_Invariant (New_Max_Last = Ghost_New_Max_Last - 1); 235 | pragma Loop_Invariant (if Arr_Acc /= null then Arr_Acc.all'Last >= Arr_Acc.all'First); 236 | pragma Loop_Invariant (if Arr_Acc /= null then Arr_Acc.all'First = First_Index(Self)); 237 | pragma Loop_Invariant (if Arr_Acc /= null then Arr_Acc.all'Last > Get_Capacity_Offset(Long_Positive(Capacity(Self)))); 238 | end loop; 239 | 240 | if Arr_Acc = null then 241 | Success := False; 242 | else 243 | for I in First_Index(Self) .. Last_Index(Self) loop 244 | Arr_Acc.all(I) := Self.Arr.all(I); 245 | pragma Loop_Invariant (for all P in First_Index(Self) .. I => Arr_Acc.all(P) = Self.Arr.all(P)); 246 | end loop; 247 | Self.Last := No_Index; 248 | Array_Alloc.Free(Self.Arr); 249 | if Self.Arr = null and then Self.Last = No_Index then 250 | Self.Arr := Arr_Acc; 251 | if Self.Arr /= null and Tmp_Last < Self.Arr.all'Last then 252 | Self.Last := Tmp_Last + 1; 253 | Self.Arr.all(Last_Index(Self)) := New_Item; 254 | Success := True; 255 | else 256 | raise Program_Error; 257 | end if; 258 | else 259 | raise Program_Error; 260 | end if; 261 | end if; 262 | end; 263 | end; 264 | end if; 265 | end Append; 266 | 267 | 268 | -- procedure Delete (Self : in out Unbound_Array; 269 | -- Index : in Extended_Index; 270 | -- Count : in Positive := 1) is 271 | -- begin 272 | -- null; 273 | -- end Delete; 274 | 275 | 276 | procedure Delete_Last (Self : in out Unbound_Array; Count : in Long_Positive := 1) 277 | is 278 | begin 279 | -- Actually not deleting anything, but moving values out of scope 280 | Self.Last := Extended_Index(Long_Integer(Self.Last) - Count); 281 | end; 282 | 283 | 284 | function First_Element (Self : Unbound_Array) return Element_Type 285 | is 286 | begin 287 | return Self.Arr.all(First_Index(Self)); 288 | end First_Element; 289 | 290 | 291 | function First_Index (Self : Unbound_Array) return Index_Type 292 | is 293 | begin 294 | if Self.Arr = null then 295 | return Index_Type'First; 296 | end if; 297 | 298 | return Self.Arr.all'First; 299 | end First_Index; 300 | 301 | 302 | function Last_Index (Self : Unbound_Array) return Extended_Index 303 | is 304 | begin 305 | return Self.Last; 306 | end Last_Index; 307 | 308 | 309 | function Last_Element (Self : Unbound_Array) return Element_Type 310 | is 311 | begin 312 | return Self.Arr.all(Last_Index(Self)); 313 | end Last_Element; 314 | 315 | 316 | function Find_Index (Self : Unbound_Array; Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index 317 | is 318 | begin 319 | if Last_Index(Self) = No_Index then 320 | return No_Index; 321 | end if; 322 | 323 | for I in Index .. Last_Index(Self) loop 324 | if Element(Self, I) = Item then 325 | return I; 326 | end if; 327 | pragma Loop_Invariant (for all P in Index .. I => Element(Self, P) /= Item); 328 | end loop; 329 | 330 | return No_Index; 331 | end Find_Index; 332 | 333 | 334 | function Contains (Self : Unbound_Array; Item : Element_Type; Index : Index_Type := Index_Type'First) return Boolean 335 | is 336 | begin 337 | if Self.Arr = null or else Self.Last = No_Index then 338 | return False; 339 | end if; 340 | 341 | for I in Index .. Last_Index(Self) loop 342 | if Self.Arr.all(I) = Item then 343 | return True; 344 | end if; 345 | pragma Loop_Invariant (for all P in Index .. I => Element(Self, P) /= Item); 346 | end loop; 347 | return False; 348 | end Contains; 349 | 350 | 351 | 352 | -- Ghost ---------------------------------------------------------------------------------- 353 | 354 | 355 | function Ghost_Acc_Length (Self : Array_Acc) return Long_Natural 356 | is 357 | begin 358 | if Self = null then 359 | return Long_Natural'First; 360 | end if; 361 | 362 | return Self.all'Length; 363 | end Ghost_Acc_Length; 364 | 365 | 366 | function Ghost_Arr_Equals (Left, Right : Array_Type; First, Last : Index_Type) return Boolean 367 | is 368 | begin 369 | if Left'First > First or else Right'First > First 370 | or else Left'Last < Last or else Right'Last < Last then 371 | 372 | return False; 373 | end if; 374 | 375 | for I in First .. Last loop 376 | if Left(I) /= Right(I) then 377 | return False; 378 | end if; 379 | pragma Loop_Invariant (for all P in First .. I => Left(P) = Right(P)); 380 | end loop; 381 | return True; 382 | end Ghost_Arr_Equals; 383 | 384 | 385 | function Ghost_Arr_Length (Self : Array_Type) return Long_Natural 386 | is 387 | begin 388 | return Self'Length; 389 | end Ghost_Arr_Length; 390 | 391 | 392 | end Spark_Unbound.Arrays; 393 | -------------------------------------------------------------------------------- /src/spark_unbound-arrays.ads: -------------------------------------------------------------------------------- 1 | with Ada.Numerics.Big_Numbers.Big_Integers; use Ada.Numerics.Big_Numbers.Big_Integers; 2 | 3 | --- @summary 4 | --- This package is intended as a safe and proven alternative to `Ada.Containers.Vector`. 5 | --- 6 | --- @description 7 | --- This package offers proven functions/procedures for an unbound array that are inspired by the `Ada.Containers.Vector` package. 8 | --- 9 | --- Note: The range of `Index_Type` must be smaller than `Natural'Range_Length` since `Capacity' and `Length` return type `Natural`. 10 | --- This is NOT enforced by the compiler! 11 | generic 12 | type Element_Type is private; 13 | type Index_Type is range <>; 14 | with function "=" (Left, Right : Element_Type) return Boolean is <>; 15 | --- Function used to compare elements inside `Unbound_Array`s. 16 | --- @param Left Element that is compared against `Right`. 17 | --- @param Right Element that is comparef against `Left`. 18 | --- @return `True` if `Left` and `Right` are equal. 19 | 20 | package Spark_Unbound.Arrays with SPARK_Mode is 21 | 22 | use Spark_Unbound; 23 | 24 | package Index_Type_To_Big is new Signed_Conversions(Int => Index_Type); 25 | 26 | -- needed to use `Self.Arr.all'Old` to prove some contracts 27 | pragma Unevaluated_Use_Of_Old (Allow); 28 | 29 | -- Type and variabble definitions ------------------------------------------------------------------------------------ 30 | -- Note: Having Last and Arr of some private type would be better, but then Pre and Post contracts get really messy 31 | 32 | --- Type to provide the possibility of one invalid index. 33 | subtype Extended_Index is 34 | Index_Type'Base range 35 | Index_Type'First-1 .. Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; 36 | 37 | --- Index used to indicate 'out of range`. 38 | No_Index : constant Extended_Index := Extended_Index'First; 39 | 40 | --- Note: Type should be treated as private. 41 | type Array_Type is array(Index_Type range <>) of Element_Type; 42 | --- Note: Type should be treated as private. 43 | type Array_Acc is access Array_Type; 44 | 45 | --- Main type for `Unbound_Array` handling. 46 | --- 47 | --- Note: `Last` and `Arr` should not be changed manually. 48 | --- @field Last Index of the last valid entry in Arr.all. 49 | --- @field Arr Reference to the underlying allocated array. 50 | type Unbound_Array is record 51 | Last : Extended_Index := No_Index; 52 | Arr : Array_Acc := null; 53 | end record 54 | with Dynamic_Predicate => (if Arr = null then 55 | Last = No_Index 56 | else 57 | (Arr.all'First = Index_Type'First 58 | and then Arr.all'First <= Arr.all'Last 59 | and then (if Arr.all'Length <= 0 then Last = No_Index else Last <= Arr.all'Last))); 60 | 61 | 62 | -- Unbound_Array creations ------------------------------------------------------------------------------ 63 | 64 | --- Sets up a new `Unbound_Array` with `Initial_Capacity` as capacity. 65 | --- 66 | --- Complexity: O(1) => Only allocates the array without setting any value 67 | --- @param Initial_Capacity Tries to allocate an `Unbound_Array` with `Capacity(To_Unbound_Array'Result) = Initial_Capacity`. 68 | --- @return `Unbound_Array` with `Capacity(To_Unbound_Array'Result) = Initial_Capacity` if allocation was successful, or `To_Unbound_Array'Result.Arr = null`. 69 | function To_Unbound_Array (Initial_Capacity : Long_Positive) return Unbound_Array 70 | with Pre => Ghost_In_Index_Range(Initial_Capacity), 71 | Post => (if To_Unbound_Array'Result.Arr /= null then Capacity(To_Unbound_Array'Result) = Long_Natural(Initial_Capacity) 72 | and then To_Unbound_Array'Result.Arr.all'First = Index_Type'First and then To_Unbound_Array'Result.Arr.all'Last = Get_Capacity_Offset(Initial_Capacity) 73 | else Capacity(To_Unbound_Array'Result) = Long_Natural'First); 74 | 75 | 76 | -- Procedures/Functions ---------------------------------------------------------------------------------- 77 | 78 | --- This function calculates the `Index_Type` for `Offset + Index_Type'Last`. 79 | --- 80 | --- Complexity: O(1) => Integer calculation. 81 | --- @param Offset The vallue added to `Index_Type'First`. 82 | --- @return `Offset + Index_Type'First`. 83 | function Get_Capacity_Offset (Offset : Long_Positive) return Index_Type 84 | with Pre => Ghost_In_Index_Range(Offset), 85 | Post => Index_Type_To_Big.To_Big_Integer(Get_Capacity_Offset'Result) 86 | = Index_Type_To_Big.To_Big_Integer(Index_Type'First) + (Long_Positive_To_Big.To_Big_Integer(Offset) - Long_Positive_To_Big.To_Big_Integer(Long_Positive'First)); 87 | 88 | --- This function compares two `Unbound_Array`s by comparing each element (using the generic formal equality operator) 89 | --- if `Left` and `Right` have the same length. 90 | --- 91 | --- Note: The capacity can be different and `Left` and `Right` are still considered equal. 92 | --- 93 | --- Complexity: O(n) => All elements might be compared. 94 | --- @param Left `Unbound_Array` compared against `Right`. 95 | --- @param Right `Unbound_Array` compared against `Left`. 96 | --- @return `True` if `Left` and `Right` have the same elements in the same sequence. Otherwise, `False` is returned. 97 | function "=" (Left, Right : Unbound_Array) return Boolean 98 | with Global => null, Post => (if "="'Result then (Left.Arr = null and then Right.Arr = null) 99 | or else (Last_Index(Left) = Last_Index(Right) and then First_Index(Left) = First_Index(Right) 100 | and then (Left.Arr /= null and then Right.Arr /= null 101 | and then (for all I in First_Index(Left) .. Last_Index(Left) 102 | => Element(Left,I) = Element(Right,I)))) 103 | else ((Left.Arr = null and then Right.Arr /= null) 104 | or else (Left.Arr /= null and then Right.Arr = null) 105 | or else Last_Index(Left) /= Last_Index(Right) 106 | or else First_Index(Left) /= First_Index(Right) 107 | or else (for some I in First_Index(Left) .. Last_Index(Left) => Element(Left,I) /= Element(Right,I)))); 108 | 109 | --- This function returns the capacity of `Self`. 110 | --- 111 | --- Complexity: O(1) => Size of underlying array is always known. 112 | --- @param Self Instance of an `Unbound_Array`. 113 | --- @return The capacity of `Self` (More precise: The length of the underlying allocated array). 114 | function Capacity (Self : Unbound_Array) return Long_Natural 115 | with Post => (if Self.Arr /= null then Capacity'Result = Ghost_Acc_Length(Self.Arr) else Capacity'Result = Long_Natural'First); 116 | 117 | 118 | -- procedure Reserve_Capacity (Self : in out Unbound_Array; New_Capacity : in Positive; Default_Item : Element_Type; Success: out Boolean) 119 | -- with Pre => New_Capacity > Length(Self), 120 | -- Post => (if Success then Capacity(Self) = New_Capacity else Ghost_Last_Array'Length = Capacity(Self)); 121 | 122 | 123 | --- This procedure tries to move the content of `Self` to an `Unbound_Array` of a smaller capacity. 124 | --- 125 | --- Note: `Self` remains unchanged if `Success = False`. 126 | --- 127 | --- Complexity: O(n) => All elements are moved, but allocation might fail before. 128 | --- @param Self Instance of an `Unbound_Array`. 129 | --- @param New_Capacity The new capacity `Self` should be shrunken to. 130 | --- @param Success `True` if `Self` got shrunken or `False` if the content of `Self` could not be moved. 131 | procedure Shrink (Self : in out Unbound_Array; New_Capacity : Long_Natural; Success : out Boolean) 132 | with Pre => Self.Arr /= null and then New_Capacity >= Length(Self) and then New_Capacity < Capacity(Self), 133 | Post => (If New_Capacity = 0 and then Success then Capacity(Self) = Long_Natural'First and then Last_Index(Self) = No_Index 134 | else Self.Arr /= null and then Self.Last = Self.Last'Old 135 | and then (if Self.Last'Old > No_Index then Ghost_Arr_Equals(Left => Self.Arr.all, Right => Self.Arr.all'Old, First => First_Index(Self), Last => Last_Index(Self))) 136 | and then (if Success then Capacity(Self) = New_Capacity)); 137 | 138 | --- This function returns the number of elements inside `Self`. 139 | --- 140 | --- Complexity: O(1) => First_Index(Self) and Last_Index(Self) is always known. 141 | --- @param Self Instance of an `Unbound_Array`. 142 | --- @return Number of elements inside `Self`. 143 | function Length (Self : Unbound_Array) return Long_Natural 144 | with Post => (if Last_Index(Self) = No_Index or else Capacity(Self) = Long_Natural'First then Length'Result = Long_Natural'First 145 | else (if First_Index(Self) > Last_Index(Self) then Length'Result = Long_Natural'First 146 | else Length'Result = Long_Natural(abs(Long_Integer(Last_Index(Self)) - Long_Integer(First_Index(Self))) + 1))); 147 | 148 | --- This function denotes if `Self` as no elements. 149 | --- 150 | --- Complexity: O(1) => Length(Self) is always known. 151 | --- @param Self Instance of an `Unbound_Array`. 152 | --- @return `True` if `Self` has no elements, or `False` if `Self` has at least one element. 153 | function Is_Empty (Self : Unbound_Array) return Boolean 154 | with Post => (if Last_Index(Self) = No_Index then Is_Empty'Result = True else Is_Empty'Result = False); 155 | 156 | --- This procedure deallocates the underlying array of `Self` and sets `Self.Last = No_Index`. 157 | --- 158 | --- Complexity: O(1) => Unchecked_Deallocation of underlying array. 159 | --- @param Self Instance of an `Unbound_Array`. 160 | procedure Clear (Self : in out Unbound_Array) 161 | with Post => Self.Arr = null and then Self.Last = No_Index; 162 | 163 | --- This function returns the element inside `Self` at index `Index`. 164 | --- 165 | --- Complexity: O(1) => Index access on array is constant time. 166 | --- @param Self Instance of an `Unbound_Array`. 167 | --- @param Index Array index for the element that should be returned. 168 | --- @return The element inside `Self` at index `Index`. 169 | function Element (Self : Unbound_Array; Index : Index_Type) return Element_Type 170 | with Pre => Last_Index(Self) > No_Index and then Last_Index(Self) >= Index and then First_Index(Self) <= Index, 171 | Post => Element'Result = Self.Arr.all(Index); 172 | 173 | --- This procedure replaces the element inside `Self` at index `Index` with `New_Item`. 174 | --- 175 | --- Complexity: O(1) => Index access on array is constant time. 176 | --- @param Self Instance of an `Unbound_Array`. 177 | --- @param Index Array index for the element that should be replaced. 178 | --- @param New_Item Value that is set for the element at index `Index`. 179 | procedure Replace_Element (Self : in out Unbound_Array; Index : in Index_Type; New_Item : in Element_Type) 180 | with Pre => Last_Index(Self) > No_Index and then Last_Index(Self) >= Index and then First_Index(Self) <= Index, 181 | Post => Element(Self, Index) = New_Item; 182 | 183 | 184 | -- procedure Update_Element 185 | -- (Self : in out Unbound_Array; 186 | -- Index : in Index_Type; 187 | -- Process : not null access procedure (Process_Element : in out Element_Type)) 188 | -- with Pre => First_Index <= Index and then Last_Index(Self) >= Index; --, 189 | -- Post => Element(Self, Index) = Process_Element; -- Not sure how to prove that Process_Element got changed correctly 190 | 191 | --- Procedure that tries to copy elements of `Source` to `Target`. 192 | --- 193 | --- Note: `Target` is set to `Target.Arr = null` and `Target.Last = No_Index` if `Success = False`. `Source` remains unchanged. 194 | --- 195 | --- Complexity: O(n) => All elements must be copied, but allocation might fail before. 196 | --- @param Target Instance of an `Unbound_Array` with `Target = Source` and `Capacity(Target) = Capacity(Source)` on `Success = True`. 197 | --- @param Source Instance of an `Unbound_Array` that is copied to `Target`. 198 | --- @param Success `True` if all elements of `Source` were copied to `Target`. 199 | procedure Copy (Target : out Unbound_Array; Source : Unbound_Array; Success: out Boolean) 200 | with Post => (if Success then Target = Source and then Capacity(Target) = Capacity(Source) 201 | else (Target.Last = No_Index and then Target.Arr = null)); 202 | 203 | --- Procedure that tries to move elements of `Source` to `Target`. 204 | --- 205 | --- Note: `Capacity(Target)` can be different to `Capacity(Source)`, but all elements of `Source` must fit inside `Target`. 206 | --- 207 | --- Complexity: Theta(n) => Alle elements of `Source` must be copied. 208 | --- @param Target Instance of `Unbound_Array` with all elements of `Source` being moved to. 209 | --- @param Source Instance of `Unbound_Array` that is cleared at the end of `Move`. 210 | procedure Move (Target : in out Unbound_Array; Source : in out Unbound_Array) 211 | with Pre => Source.Arr /= null and then Target.Arr /= null and then Last_Index(Source) /= No_Index 212 | and then Capacity(Target) > Long_Natural'First and then First_Index(Source) = First_Index(Target) 213 | and then Ghost_In_Index_Range(Long_Positive(Capacity(Target))) and then Last_Index(Source) <= Get_Capacity_Offset(Long_Positive(Capacity(Target))), 214 | Post => Capacity(Target) = Ghost_Arr_Length(Target.Arr.all'Old) 215 | and then Source.Arr = null and then Source.Last = No_Index 216 | and then Target.Last = Source.Last'Old and then Ghost_Arr_Equals(Left => Target.Arr.all, Right => Source.Arr.all'Old, First => First_Index(Target), Last => Last_Index(Target)); 217 | 218 | 219 | -- else (Target.Last = Target.Last'Old and then Ghost_Arr_Equals(Left => Target.Arr.all'Old, Right => Target.Arr.all, First => Target.Arr.all'First, Last => Target.Arr.all'Last) 220 | -- and then Source.Last = Source.Last'Old and then Ghost_Arr_Equals(Left => Source.Arr.all'Old, Right => Source.Arr.all, First => Source.Arr.all'First, Last => Source.Arr.all'Last))); 221 | 222 | 223 | -- procedure Insert (Self : in out Unbound_Array; 224 | -- Before : in Extended_Index; 225 | -- New_Item : in Unbound_Array; Success: out Boolean); 226 | -- 227 | -- procedure Insert (Container : in out Unbound_Array; 228 | -- Before : in Extended_Index; 229 | -- New_Item : in Element_Type; Success: out Boolean); 230 | -- 231 | -- procedure Prepend (Self : in out Unbound_Array; 232 | -- New_Item : in Unbound_Array; Success: out Boolean); 233 | -- 234 | -- procedure Prepend (Self : in out Unbound_Array; 235 | -- New_Item : in Element_Type; Success: out Boolean); 236 | -- 237 | -- procedure Append (Self : in out Unbound_Array; 238 | -- New_Item : in Unbound_Array; Success: out Boolean); 239 | 240 | --- Procedure that tries to append `New_Item` to `Self`. 241 | --- 242 | --- Note: The underlying array of `Self` is tried to be increased automatically if `Capacity(Self) = Length(Self)`. 243 | --- 244 | --- Complexity: O(n) => `Capacity(Self)` is tried to be doubled if `Capacity(Self) = Length(Self)` is reached. 245 | --- @param Self Instance of an `Unbound_Array`. 246 | --- @param New_Item Element that is appended to `Self` if `Success = True`. 247 | --- @param Success `True` if `New_Item` got appended to `Self`. 248 | procedure Append (Self : in out Unbound_Array; New_Item : in Element_Type; Success: out Boolean) 249 | with Pre => Self.Arr /= null and then In_Range(Arg => Long_Natural_To_Big.To_Big_Integer(Capacity(Self)), 250 | Low => Long_Natural_To_Big.To_Big_Integer(Long_Natural'First), 251 | High => abs(Index_Type_To_Big.To_Big_Integer(Index_Type'Last) - Index_Type_To_Big.To_Big_Integer(Index_Type'First))), 252 | Post => (if Success then 253 | Self.Arr /= null and then Last_Element(Self) = New_Item and then Self.Last = Self.Last'Old + 1 254 | and then (if Self.Last'Old /= No_Index then Ghost_Arr_Equals(Left => Self.Arr.all, Right => Self.Arr.all'Old, First => First_Index(Self), Last => Self.Last'Old)) 255 | elsif Self.Arr = null then Self.Last = No_Index 256 | else (Self.Last = Self.Last'Old and then Ghost_Arr_Equals(Left => Self.Arr.all, Right => Self.Arr.all'Old, First => First_Index(Self), Last => Last_Index(Self)))); 257 | 258 | 259 | -- procedure Delete (Self : in out Unbound_Array; 260 | -- Index : in Extended_Index; 261 | -- Count : in Positive := 1) 262 | -- with Pre => (Extended_Index'Last >= Extended_Index(Count) and then Index <= (Extended_Index'Last - Extended_Index(Count)) and then 263 | -- First_Index <= Index and then Last_Index(Self) >= (Index + Extended_Index(Count))), 264 | -- Post => (Length(Ghost_Last_Array) - Count_Type(Count) = Length(Self) and then 265 | -- (for all I in First_Index .. Last_Index(Self) 266 | -- => Element(Self, I) = Element(Ghost_Last_Array,I))); 267 | 268 | -- mhatzl 269 | -- procedure Delete_First (Self : in out Unbound_Array; 270 | -- Count : in Positive := 1); 271 | 272 | --- This procedure deletes the last `Count` elements inside `Self`. 273 | --- 274 | --- Complexity: O(1) => Only `Last_Index(Self)` is reduced. 275 | --- @param Self Instance of an `Unbound_Array`. 276 | --- @param Count Number of elements to delete. 277 | procedure Delete_Last (Self : in out Unbound_Array; Count : in Long_Positive := 1) 278 | with Pre => Self.Arr /= null and then Length(Self) >= Long_Natural(Count), 279 | Post => Long_Integer(Self.Last'Old) - Long_Integer(Self.Last) = Count 280 | and then (if Last_Index(Self) > No_Index then 281 | Ghost_Arr_Equals(Left => Self.Arr.all, Right => Self.Arr.all'Old, First => First_Index(Self), Last => Last_Index(Self)) 282 | else Is_Empty(Self)); 283 | 284 | 285 | -- procedure Reverse_Elements (Self : in out Unbound_Array); 286 | -- 287 | 288 | -- procedure Swap (Self : in out Unbound_Array; 289 | -- I, J : in Index_Type); 290 | 291 | --- This function returns the first index of `Self`. 292 | --- 293 | --- Complexity: O(1) => First index is fixed. 294 | --- @param Self Instance of an `Unbound_Array`. 295 | --- @return The first index of `Self`. 296 | function First_Index (Self : Unbound_Array) return Index_Type 297 | with Inline, Post => (if Self.Arr = null then First_Index'Result = Index_Type'First else First_Index'Result = Self.Arr.all'First); 298 | 299 | --- This function returns the element at `First_Index(Self)`. 300 | --- 301 | --- Complexity: O(1) => Array access is constant time. 302 | --- @param Self Instance of an `Unbound_Array`. 303 | --- @return The first element of `Self`. 304 | function First_Element (Self : Unbound_Array) return Element_Type 305 | with Pre => Self.Arr /= null and then Self.Last /= No_Index and then Length(Self) > Long_Natural'First, 306 | Post => First_Element'Result = Self.Arr.all(First_Index(Self)); 307 | 308 | --- This function returns the last index of `Self`. 309 | --- 310 | --- Complexity: O(1) => `Last_Index(Self)` is kept with `Self.Last`. 311 | --- @param Self Instance of an `Unbound_Array`. 312 | --- @return The last index of `Self`. 313 | function Last_Index (Self : Unbound_Array) return Extended_Index 314 | with Post => (Last_Index'Result = Self.Last and then (if Self.Arr = null then Last_Index'Result = No_Index 315 | elsif Self.Arr.all'Length > 0 then Last_Index'Result <= Self.Arr.all'Last else Last_Index'Result = No_Index)), Inline; 316 | 317 | --- This function returns the element at `Last_Index(Self)`. 318 | --- 319 | --- Complexity: O(1) => Array access is constant time. 320 | --- @param Self Instance of an `Unbound_Array`. 321 | --- @return The last element of `Self`. 322 | function Last_Element (Self : Unbound_Array) return Element_Type 323 | with Pre => Self.Arr /= null and then Last_Index(Self) > No_Index and then Length(Self) > Long_Natural'First, 324 | Post => Last_Element'Result = Self.Arr.all(Last_Index(Self)); 325 | 326 | --- This function searches the elements of `Self` for an element equal to `Item` (using the generic formal equality operator). 327 | --- The search starts at position `Index` and proceeds towards `Last_Index(Self)`. 328 | --- If no equal element is found, then `Find_Index` returns `No_Index`. Otherwise, it returns the index of the first equal element encountered. 329 | --- 330 | --- Note: Same behavior as `Find_Index` defined in `Ada.Containers.Vectors` [RM-A-18-2]. 331 | --- 332 | --- Complexity: O(n) => All elements might get compared against `Item`. 333 | --- @param Self Instance of an `Unbound_Array`. 334 | --- @param Item Element that is searched for in `Self`. 335 | --- @param Index Array index to start searching towards `Last_Index(Self)` for `Item`. 336 | --- @return `No_Index` if `Item` was not found, or the index `I` where `Element(Self, I) = Item`. 337 | function Find_Index (Self : Unbound_Array; Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index 338 | with Pre => Last_Index(Self) >= Index and then First_Index(Self) <= Index, 339 | Post => (if Find_Index'Result /= No_Index then Element(Self,Find_Index'Result) = Item 340 | else (Last_Index(Self) = No_Index or else (for all I in Index .. Last_Index(Self) => Element(Self, I) /= Item))); 341 | 342 | -- mhatzl 343 | -- function Reverse_Find_Index (Self : Unbound_Array; 344 | -- Item : Element_Type; 345 | -- Index : Index_Type := Index_Type'Last) 346 | -- return Extended_Index; 347 | 348 | --- This function searches the elements of `Self` for an element equal to `Item` (using the generic formal equality operator). 349 | --- The search starts at position `Index` and proceeds towards `Last_Index(Self)`. 350 | --- If no equal element is found, then `Contains` returns `False`. Otherwise, `Contains` returns true. 351 | --- 352 | --- Complexity: O(n) => All elements might get compared against `Item`. 353 | --- @param Self Instance of an `Unbound_Array`. 354 | --- @param Item Element that is searched for in `Self`. 355 | --- @param Index Array index to start searching towards `Last_Index(Self)` for `Item`. 356 | function Contains (Self : Unbound_Array; Item : Element_Type; Index : Index_Type := Index_Type'First) return Boolean 357 | with Post => (if Contains'Result then Self.Arr /= null and then Self.Last /= No_Index 358 | and then (for some I in Index .. Last_Index(Self) => Element(Self, I) = Item)); 359 | 360 | 361 | -- function Reverse_Contains (Self : Unbound_Array; 362 | -- Item : Element_Type; 363 | -- Index : Index_Type := Index_Type'Last) 364 | -- return Boolean; 365 | 366 | -- mhatzl 367 | -- generic 368 | -- with function "<" (Left, Right : Element_Type) return Boolean is <>; 369 | -- package Generic_Sorting with SPARK_Mode is 370 | -- 371 | -- function Is_Sorted (Self : Unbound_Array) return Boolean; 372 | -- 373 | -- procedure Sort (Self : in out Unbound_Array; Success: out Boolean); 374 | -- 375 | -- procedure Merge (Target : in out Unbound_Array; 376 | -- Source : in out Unbound_Array; Success: out Boolean); 377 | -- 378 | -- function Sorted_Contains (Self : Unbound_Array; 379 | -- Item : Element_Type) return Boolean 380 | -- with Post => (if Contains'Result then 381 | -- (for some I in First_Index(Self) .. Last_Index(Self) 382 | -- => Element(Self, I) = Item) 383 | -- else (for all I in First_Index(Self) .. Last_Index(Self) 384 | -- => Element(Self, I) /= Item)); 385 | -- 386 | -- procedure Sorted_Add (Self : in out Unbound_Array; New_Item : in Element_Type; Success: out Boolean) 387 | -- 388 | -- function Sorted_Find_Index (Self : Unbound_Array; Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index 389 | -- with Pre => Last_Index(Self) /= No_Index and then Last_Index(Self) >= Index and then First_Index(Self) <= Index, 390 | -- Post => (if Find_Index'Result /= No_Index then Element(Self,Find_Index'Result) = Item 391 | -- else (for all I in First_Index(Self) .. Index => Element(Self, I) /= Item)); 392 | -- 393 | -- function Sorted_Reverse_Find_Index (Self : Unbound_Array; Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index 394 | -- with Pre => Last_Index(Self) /= No_Index and then Last_Index(Self) >= Index and then First_Index(Self) <= Index, 395 | -- Post => (if Find_Index'Result /= No_Index then Element(Self,Find_Index'Result) = Item 396 | -- else (for all I in First_Index(Self) .. Index => Element(Self, I) /= Item)); 397 | -- 398 | -- end Generic_Sorting; 399 | 400 | 401 | -- Ghost -------------------------------------------------------------------------------------------------------------- 402 | 403 | -- This ghost function checks if `Offset + Index_Type'First` is still in the range of `Index_Type`. 404 | -- Note: Not to be used for anything but proves 405 | -- @param Offset The value added to `Index_Type'First`. 406 | -- @return `True` if `Offset + Index_Type'First` is still inside the range of `Index_Type`, `False` otherwise. 407 | function Ghost_In_Index_Range (Offset : Long_Positive) return Boolean is 408 | (In_Range(Arg => (Index_Type_To_Big.To_Big_Integer(Index_Type'First) + Long_Positive_To_Big.To_Big_Integer(Offset) - Long_Positive_To_Big.To_Big_Integer(Long_Positive'First)), 409 | Low => Index_Type_To_Big.To_Big_Integer(Index_Type'First), 410 | High => Index_Type_To_Big.To_Big_Integer(Index_Type'Last))) with Ghost; 411 | 412 | 413 | -- Ghost function needed for some proves. 414 | -- Note: Not to be used for anything but proves. 415 | function Ghost_Acc_Length (Self : Array_Acc) return Long_Natural 416 | with Ghost, 417 | Post => ((if Self = null then Ghost_Acc_Length'Result = Long_Natural'First else Ghost_Acc_Length'Result = Self.all'Length)); 418 | 419 | -- Ghost function needed for some proves. 420 | -- Note: Not to be used for anything but proves. 421 | function Ghost_Arr_Equals (Left, Right : Array_Type; First, Last : Index_Type) return Boolean 422 | with Ghost, 423 | Post => (if Ghost_Arr_Equals'Result then (for all I in First .. Last => Left(I) = Right(I)) 424 | else (Left'First > First or else Right'First > First or else Left'Last < Last or else Right'Last < Last 425 | or else (for some I in First .. Last => Left(I) /= Right(I)))); 426 | 427 | -- Ghost function needed for some proves. 428 | -- Note: Not to be used for anything but proves. 429 | function Ghost_Arr_Length (Self : Array_Type) return Long_Natural 430 | with Ghost, 431 | Post => Ghost_Arr_Length'Result = Self'Length; 432 | 433 | end Spark_Unbound.Arrays; 434 | -------------------------------------------------------------------------------- /src/spark_unbound-safe_alloc.adb: -------------------------------------------------------------------------------- 1 | with Ada.Unchecked_Deallocation; 2 | 3 | package body Spark_Unbound.Safe_Alloc with SPARK_Mode is 4 | 5 | package body Definite with SPARK_Mode is 6 | 7 | function Alloc return T_Acc is 8 | pragma SPARK_Mode (Off); -- Spark OFF for exception handling 9 | begin 10 | return new T; 11 | exception 12 | when Storage_Error => 13 | return null; 14 | end Alloc; 15 | 16 | procedure Free (Pointer : in out T_Acc) is 17 | procedure Dealloc is new Ada.Unchecked_Deallocation (T, T_Acc); 18 | begin 19 | Dealloc (Pointer); 20 | end Free; 21 | end Definite; 22 | 23 | package body Arrays with SPARK_Mode is 24 | 25 | function Alloc (First, Last : Index_Type) return Array_Type_Acc is 26 | pragma SPARK_Mode (Off); -- Spark OFF for exception handling 27 | begin 28 | return new Array_Type(First .. Last); 29 | exception 30 | when Storage_Error => 31 | return null; 32 | end Alloc; 33 | 34 | procedure Free (Pointer : in out Array_Type_Acc) is 35 | procedure Dealloc is new Ada.Unchecked_Deallocation (Array_Type, Array_Type_Acc); 36 | begin 37 | Dealloc (Pointer); 38 | end Free; 39 | 40 | end Arrays; 41 | 42 | end Spark_Unbound.Safe_Alloc; 43 | -------------------------------------------------------------------------------- /src/spark_unbound-safe_alloc.ads: -------------------------------------------------------------------------------- 1 | --- @summary 2 | --- Package for save heap allocation. 3 | --- 4 | --- @description 5 | --- Package containing two generic packages for safe heap allocation. 6 | --- No `Storage_Error` is propagated if the heap allocation failed. 7 | --- 8 | package Spark_Unbound.Safe_Alloc with SPARK_Mode is 9 | 10 | --- @summary 11 | --- Generic package for safe heap allocation of type `T` whose size is known at compile time. 12 | --- 13 | --- @description 14 | --- Generic package for safe heap allocation of type `T` whose size is known at compile time. 15 | --- Type `T_Acc` is used to access the allocated instance of type `T`. 16 | generic 17 | type T is limited private; 18 | type T_Acc is access T; 19 | package Definite with SPARK_Mode is 20 | 21 | --- Tries to allocate type `T` on the heap. 22 | --- @return `null` if `Storage_Error` was raised. 23 | function Alloc return T_Acc; 24 | 25 | --- Deallocates the instance of type `T` from the heap. 26 | --- @param Pointer The reference to an heap allocated instance of type `T` set to `null` after deallocation. 27 | procedure Free (Pointer: in out T_Acc) 28 | with Post => Pointer = null; 29 | 30 | end Definite; 31 | 32 | --- @summary 33 | --- Generic package for safe heap allocation of array `Array_Type`. 34 | --- 35 | --- @description 36 | --- Generic package for safe heap allocation of array `Array_Type`. 37 | --- Type `Array_Type_Acc` is used to access the allocated instance of array `Array_Type`. 38 | --- 39 | --- Note: The allocated array is NOT initialized. 40 | generic 41 | type Element_Type is private; 42 | type Index_Type is range <>; 43 | type Array_Type is array (Index_Type range <>) of Element_Type; 44 | type Array_Type_Acc is access Array_Type; 45 | package Arrays with SPARK_Mode is 46 | 47 | --- Tries to allocate an array of `Element_Type` with range from `First` to `Last` on the heap. 48 | --- @param First Sets the lower bound for the allocated array. 49 | --- @param Last Sets the upper bound for the allocated array. 50 | --- @return `null` if `Storage_Error` was raised. 51 | function Alloc (First, Last : Index_Type) return Array_Type_Acc 52 | with Pre => Last >= First, 53 | Post => (if Alloc'Result /= null then (Alloc'Result.all'First = First and then Alloc'Result.all'Last = Last)); 54 | 55 | --- Deallocates the instance of type `Array_Type` from the heap. 56 | --- @param Pointer The reference to an heap allocated instance of type `Array_Type` set to `null` after deallocation. 57 | procedure Free (Pointer: in out Array_Type_Acc) 58 | with Post => Pointer = null; 59 | 60 | end Arrays; 61 | 62 | end Spark_Unbound.Safe_Alloc; 63 | -------------------------------------------------------------------------------- /src/spark_unbound.ads: -------------------------------------------------------------------------------- 1 | with Ada.Numerics.Big_Numbers.Big_Integers; use Ada.Numerics.Big_Numbers.Big_Integers; 2 | 3 | --- @summary 4 | --- The `Spark_Unbound` package contains various unbound generic data structures. 5 | --- All data structures are formally proven by Spark and `Storage_Error` for heap allocation is handled internally. 6 | --- 7 | --- @description 8 | --- The `Spark_Unbound` package contains the following unbound generic data structures: 9 | --- 10 | --- - `Unbound_Array`: The package `Spark_Unbound.Arrays` provides the type and functionality for this data structure. 11 | --- 12 | --- The functionality for safe heap allocation is provided in the package `Spark_Unbound.Safe_Alloc`. 13 | --- 14 | --- The source code is MIT licensed and can be found at: https://github.com/mhatzl/spark_unbound 15 | package Spark_Unbound with SPARK_Mode is 16 | 17 | package Long_Integer_To_Big is new Signed_Conversions(Int => Long_Integer); 18 | 19 | subtype Long_Natural is Long_Integer range 0 .. Long_Integer'Last; 20 | package Long_Natural_To_Big is new Signed_Conversions(Int => Long_Natural); 21 | 22 | subtype Long_Positive is Long_Integer range 1 .. Long_Integer'Last; 23 | package Long_Positive_To_Big is new Signed_Conversions(Int => Long_Positive); 24 | 25 | end Spark_Unbound; 26 | -------------------------------------------------------------------------------- /tests/.gitignore: -------------------------------------------------------------------------------- 1 | obj/ 2 | lib/ 3 | alire/ 4 | config/ 5 | bin/ 6 | -------------------------------------------------------------------------------- /tests/alire.toml: -------------------------------------------------------------------------------- 1 | name = "tests" 2 | description = "Tests for spark_unbound" 3 | version = "0.0.0" 4 | 5 | authors = ["Manuel Hatzl"] 6 | maintainers = ["Manuel Hatzl "] 7 | maintainers-logins = ["mhatzl"] 8 | 9 | executables = ["tests"] 10 | 11 | [[depends-on]] 12 | spark_unbound = "*" 13 | aunit = "*" 14 | 15 | [[pins]] 16 | spark_unbound = { path = ".." } 17 | -------------------------------------------------------------------------------- /tests/src/Safe_Alloc/sa_arrays_tests.adb: -------------------------------------------------------------------------------- 1 | with Spark_Unbound.Safe_Alloc; 2 | with AUnit.Assertions; use AUnit.Assertions; 3 | with Ada.Exceptions; 4 | 5 | package body SA_Arrays_Tests is 6 | 7 | procedure TestAlloc_WithForcingStorageError_ResultNullReturned(T : in out Test_Fixture) 8 | is 9 | type Array_Type is array (Integer range <>) of Integer; 10 | type Array_Acc is access Array_Type; 11 | package Int_Arrays is new Spark_Unbound.Safe_Alloc.Arrays(Element_Type => Integer, Index_Type => Integer, Array_Type => Array_Type, Array_Type_Acc => Array_Acc); 12 | Arr_Acc : Array_Acc; 13 | Array_Last : Integer := 1_000_000_000; 14 | Storage_Error_Forced : Boolean := False; 15 | 16 | -- table to keep track of allocated arrays to be freed later 17 | type Acc_Table_Array is array (Integer range <>) of Array_Acc; 18 | Acc_Table : Acc_Table_Array(0 .. 1_000_000); 19 | Table_Index : Integer := Acc_Table'First; 20 | begin 21 | declare 22 | begin 23 | loop 24 | exit when (Storage_Error_Forced or else Table_Index >= Acc_Table'Last); 25 | 26 | begin 27 | Arr_Acc := Int_Arrays.Alloc(First => Integer'First, Last => Array_Last); 28 | 29 | begin 30 | Acc_Table(Table_Index) := Arr_Acc; 31 | Table_Index := Table_Index + 1; 32 | exception 33 | when others => 34 | Assert(False, "Table append failed"); 35 | end; 36 | 37 | if Arr_Acc = null then 38 | Storage_Error_Forced := True; 39 | elsif Array_Last < Integer'Last - Array_Last then 40 | Array_Last := Array_Last + Array_Last; 41 | else 42 | Array_Last := Integer'Last; 43 | end if; 44 | exception 45 | when E : others => 46 | Assert(False, "Alloc failed: " & Ada.Exceptions.Exception_Name(E) & " => " & Ada.Exceptions.Exception_Message(E)); 47 | end; 48 | end loop; 49 | 50 | -- free allocated 51 | for I in Acc_Table'First .. Acc_Table'Last loop 52 | Int_Arrays.Free(Acc_Table(I)); 53 | end loop; 54 | 55 | Assert(Storage_Error_Forced, "Storage_Error could not be forced. Last value = " & Array_Last'Image); 56 | exception 57 | when E : others => 58 | Assert(False, "Exception got raised with Last = " & Array_Last'Image & " Reason: " & Ada.Exceptions.Exception_Name(E) & " => " & Ada.Exceptions.Exception_Message(E)); 59 | end; 60 | end TestAlloc_WithForcingStorageError_ResultNullReturned; 61 | 62 | 63 | end SA_Arrays_Tests; 64 | -------------------------------------------------------------------------------- /tests/src/Safe_Alloc/sa_arrays_tests.ads: -------------------------------------------------------------------------------- 1 | with AUnit; 2 | with AUnit.Test_Fixtures; 3 | 4 | package SA_Arrays_Tests is 5 | 6 | type Test_Fixture is new AUnit.Test_Fixtures.Test_Fixture with null record; 7 | 8 | 9 | procedure TestAlloc_WithForcingStorageError_ResultNullReturned(T : in out Test_Fixture); 10 | 11 | 12 | end SA_Arrays_Tests; 13 | -------------------------------------------------------------------------------- /tests/src/Safe_Alloc/sa_definite_tests.adb: -------------------------------------------------------------------------------- 1 | with Spark_Unbound.Safe_Alloc; 2 | with AUnit.Assertions; use AUnit.Assertions; 3 | with Ada.Exceptions; 4 | 5 | package body SA_Definite_Tests is 6 | 7 | procedure TestAlloc_WithForcingStorageError_ResultNullReturned(T : in out Test_Fixture) 8 | is 9 | -- type Inner_Array is array(-90 .. 90) of Integer; -- forced test fail 10 | type Inner_Array is array(-9_00_000_000 .. 9_00_000_000) of Integer; 11 | type Alloc_Record is record 12 | Arr1 : Inner_Array; 13 | Arr2 : Inner_Array; 14 | Arr3 : Inner_Array; 15 | Arr4 : Inner_Array; 16 | Arr5 : Inner_Array; 17 | Arr6 : Inner_Array; 18 | Arr7 : Inner_Array; 19 | Arr8 : Inner_Array; 20 | Arr9 : Inner_Array; 21 | Arr10 : Inner_Array; 22 | Arr11 : Inner_Array; 23 | Arr12 : Inner_Array; 24 | Arr13 : Inner_Array; 25 | Arr14 : Inner_Array; 26 | Arr15 : Inner_Array; 27 | Arr16 : Inner_Array; 28 | Arr17 : Inner_Array; 29 | Arr18 : Inner_Array; 30 | Arr19 : Inner_Array; 31 | Arr20 : Inner_Array; 32 | V1 : Integer; 33 | V2 : Natural; 34 | V3 : Positive; 35 | end record; 36 | 37 | type Record_Acc is access Alloc_Record; 38 | 39 | package Record_Alloc is new Spark_Unbound.Safe_Alloc.Definite(T => Alloc_Record, T_Acc => Record_Acc); 40 | Rec_Acc : Record_Acc; 41 | Storage_Error_Forced : Boolean := False; 42 | 43 | -- table to keep track of allocated records to be freed later 44 | type Rec_Table_Array is array (Integer range <>) of Record_Acc; 45 | Rec_Table : Rec_Table_Array(0 .. 1_000_000); 46 | Table_Index : Integer := Rec_Table'First; 47 | begin 48 | declare 49 | begin 50 | loop 51 | exit when (Storage_Error_Forced or else Table_Index >= Rec_Table'Last); 52 | 53 | begin 54 | Rec_Acc := Record_Alloc.Alloc; 55 | 56 | begin 57 | Rec_Table(Table_Index) := Rec_Acc; 58 | Table_Index := Table_Index + 1; 59 | exception 60 | when others => 61 | Assert(False, "Table append failed"); 62 | end; 63 | 64 | if Rec_Acc = null then 65 | Storage_Error_Forced := True; 66 | end if; 67 | exception 68 | when E : others => 69 | Assert(False, "Alloc failed: " & Ada.Exceptions.Exception_Name(E) & " => " & Ada.Exceptions.Exception_Message(E)); 70 | end; 71 | end loop; 72 | 73 | -- free allocated 74 | for I in Rec_Table'First .. Rec_Table'Last loop 75 | Record_Alloc.Free(Rec_Table(I)); 76 | end loop; 77 | 78 | Assert(Storage_Error_Forced, "Storage_Error could not be forced"); 79 | exception 80 | when E : others => 81 | Assert(False, "Exception got raised! Reason: " & Ada.Exceptions.Exception_Name(E) & " => " & Ada.Exceptions.Exception_Message(E)); 82 | end; 83 | 84 | end TestAlloc_WithForcingStorageError_ResultNullReturned; 85 | 86 | end SA_Definite_Tests; 87 | -------------------------------------------------------------------------------- /tests/src/Safe_Alloc/sa_definite_tests.ads: -------------------------------------------------------------------------------- 1 | with AUnit; 2 | with AUnit.Test_Fixtures; 3 | 4 | package SA_Definite_Tests is 5 | 6 | type Test_Fixture is new AUnit.Test_Fixtures.Test_Fixture with null record; 7 | 8 | 9 | procedure TestAlloc_WithForcingStorageError_ResultNullReturned(T : in out Test_Fixture); 10 | 11 | end SA_Definite_Tests; 12 | -------------------------------------------------------------------------------- /tests/src/Safe_Alloc/safe_alloc_suite.adb: -------------------------------------------------------------------------------- 1 | with AUnit.Test_Caller; 2 | with SA_Arrays_Tests; 3 | with SA_Definite_Tests; 4 | 5 | package body Safe_Alloc_Suite is 6 | 7 | package SA_Arrays_Test_Caller is new AUnit.Test_Caller(SA_Arrays_Tests.Test_Fixture); 8 | package SA_Definite_Test_Caller is new AUnit.Test_Caller(SA_Definite_Tests.Test_Fixture); 9 | 10 | 11 | function Suite return Access_Test_Suite is 12 | SA_Suite : constant Access_Test_Suite := new Test_Suite; 13 | begin 14 | -- Add Arrays Tests --------------------------------- 15 | SA_Suite.Add_Test(SA_Arrays_Test_Caller.Create("Test Arrays Alloc with trying to force Storage_Error => Returns `null`", SA_Arrays_Tests.TestAlloc_WithForcingStorageError_ResultNullReturned'Access)); 16 | 17 | 18 | -- Add Definite Tests --------------------------------- 19 | SA_Suite.Add_Test(SA_Definite_Test_Caller.Create("Test Definite Alloc with trying to force Storage_Error => Returns `null`", SA_Definite_Tests.TestAlloc_WithForcingStorageError_ResultNullReturned'Access)); 20 | 21 | return SA_Suite; 22 | end Suite; 23 | 24 | end Safe_Alloc_Suite; 25 | -------------------------------------------------------------------------------- /tests/src/Safe_Alloc/safe_alloc_suite.ads: -------------------------------------------------------------------------------- 1 | with AUnit.Test_Suites; use AUnit.Test_Suites; 2 | 3 | package Safe_Alloc_Suite is 4 | 5 | function Suite return Access_Test_Suite; 6 | 7 | end Safe_Alloc_Suite; 8 | -------------------------------------------------------------------------------- /tests/src/Unbound_Array/ua_append_tests.adb: -------------------------------------------------------------------------------- 1 | with Spark_Unbound.Arrays; 2 | with AUnit.Assertions; use AUnit.Assertions; 3 | 4 | 5 | package body UA_Append_Tests is 6 | 7 | use Spark_Unbound; 8 | 9 | procedure Set_Up (T : in out Test_Fixture) 10 | is 11 | begin 12 | T.V1 := 1; 13 | T.V2 := 2; 14 | T.V3 := 3; 15 | T.V4 := 4; 16 | end; 17 | 18 | 19 | procedure TestAppend_WithEnoughCapacity_ResultAppended(T : in out Test_Fixture) 20 | is 21 | package UA_Integer is new Spark_Unbound.Arrays(Element_Type => Integer, Index_Type => Positive); 22 | Test_UA : UA_Integer.Unbound_Array := UA_Integer.To_Unbound_Array(Initial_Capacity => 10); 23 | Success : Boolean; 24 | begin 25 | UA_Integer.Append(Test_UA, T.V1, Success); 26 | Assert(Success, "Appending V1 failed"); 27 | Assert(UA_Integer.Last_Element(Test_UA) = T.V1, "Appending V1 did not set it as last element"); 28 | 29 | UA_Integer.Append(Test_UA, T.V2, Success); 30 | Assert(Success, "Appending V2 failed"); 31 | Assert(UA_Integer.Last_Element(Test_UA) = T.V2, "Appending V2 did not set it as last element"); 32 | 33 | UA_Integer.Append(Test_UA, T.V3, Success); 34 | Assert(Success, "Appending V3 failed"); 35 | Assert(UA_Integer.Last_Element(Test_UA) = T.V3, "Appending V3 did not set it as last element"); 36 | 37 | UA_Integer.Append(Test_UA, T.V4, Success); 38 | Assert(Success, "Appending V4 failed"); 39 | Assert(UA_Integer.Last_Element(Test_UA) = T.V4, "Appending V4 did not set it as last element"); 40 | 41 | UA_Integer.Clear(Test_UA); 42 | end; 43 | 44 | 45 | procedure TestAppend_WithSmallCapacity_ResultAppended(T : in out Test_Fixture) 46 | is 47 | package UA_Integer is new Spark_Unbound.Arrays(Element_Type => Integer, Index_Type => Positive); 48 | Test_UA : UA_Integer.Unbound_Array := UA_Integer.To_Unbound_Array(Initial_Capacity => 3); -- Note the low capacity 49 | Success : Boolean; 50 | begin 51 | UA_Integer.Append(Test_UA, T.V1, Success); 52 | Assert(Success, "Appending V1 failed"); 53 | Assert(UA_Integer.Last_Element(Test_UA) = T.V1, "Appending V1 did not set it as last element"); 54 | 55 | UA_Integer.Append(Test_UA, T.V2, Success); 56 | Assert(Success, "Appending V2 failed"); 57 | Assert(UA_Integer.Last_Element(Test_UA) = T.V2, "Appending V2 did not set it as last element"); 58 | 59 | UA_Integer.Append(Test_UA, T.V3, Success); 60 | Assert(Success, "Appending V3 failed"); 61 | Assert(UA_Integer.Last_Element(Test_UA) = T.V3, "Appending V3 did not set it as last element"); 62 | 63 | 64 | Assert(UA_Integer.Length(Test_UA) = UA_Integer.Capacity(Test_UA), "Length of Unbound_Array did not reach Capacity"); 65 | 66 | -- Now Append needs to resize 67 | 68 | UA_Integer.Append(Test_UA, T.V4, Success); 69 | Assert(Success, "Appending V4 failed"); 70 | Assert(UA_Integer.Last_Element(Test_UA) = T.V4, "Appending V4 did not set it as last element"); 71 | 72 | UA_Integer.Clear(Test_UA); 73 | end; 74 | 75 | 76 | procedure TestAppend_WithIndexEndReached_ResultNotAppended(T : in out Test_Fixture) 77 | is 78 | type Small_Index is range 0 .. 2; -- Note: Type only allows 3 values 79 | package UA_Integer is new Spark_Unbound.Arrays(Element_Type => Integer, Index_Type => Small_Index); 80 | Test_UA : UA_Integer.Unbound_Array := UA_Integer.To_Unbound_Array(Initial_Capacity => 3); 81 | Success : Boolean; 82 | begin 83 | UA_Integer.Append(Test_UA, T.V1, Success); 84 | Assert(Success, "Appending V1 failed"); 85 | Assert(UA_Integer.Last_Element(Test_UA) = T.V1, "Appending V1 did not set it as last element"); 86 | 87 | UA_Integer.Append(Test_UA, T.V2, Success); 88 | Assert(Success, "Appending V2 failed"); 89 | Assert(UA_Integer.Last_Element(Test_UA) = T.V2, "Appending V2 did not set it as last element"); 90 | 91 | UA_Integer.Append(Test_UA, T.V3, Success); 92 | Assert(Success, "Appending V3 failed"); 93 | Assert(UA_Integer.Last_Element(Test_UA) = T.V3, "Appending V3 did not set it as last element"); 94 | 95 | 96 | Assert(UA_Integer.Length(Test_UA) = UA_Integer.Capacity(Test_UA), "Length of Unbound_Array did not reach Capacity"); 97 | 98 | -- Append can not resize beyond Index_Type range 99 | 100 | UA_Integer.Append(Test_UA, T.V4, Success); 101 | Assert(not Success, "Appened V4 even though Index_Type exceeded"); 102 | Assert(UA_Integer.Last_Element(Test_UA) /= T.V4, "Appended V4 even though Index_Type limit exceeded"); 103 | Assert(UA_Integer.Last_Element(Test_UA) = T.V3, "V3 not last element after exceeding Index_Type limit"); 104 | 105 | UA_Integer.Clear(Test_UA); 106 | end; 107 | 108 | 109 | end UA_Append_Tests; 110 | -------------------------------------------------------------------------------- /tests/src/Unbound_Array/ua_append_tests.ads: -------------------------------------------------------------------------------- 1 | with AUnit; 2 | with AUnit.Test_Fixtures; 3 | 4 | package UA_Append_Tests is 5 | 6 | type Test_Fixture is new AUnit.Test_Fixtures.Test_Fixture with record 7 | V1 : Integer; 8 | V2 : Integer; 9 | V3 : Integer; 10 | V4 : Integer; 11 | end record; 12 | 13 | 14 | procedure Set_Up (T : in out Test_Fixture); 15 | 16 | 17 | procedure TestAppend_WithEnoughCapacity_ResultAppended(T : in out Test_Fixture); 18 | 19 | 20 | procedure TestAppend_WithSmallCapacity_ResultAppended(T : in out Test_Fixture); 21 | 22 | 23 | procedure TestAppend_WithIndexEndReached_ResultNotAppended(T : in out Test_Fixture); 24 | 25 | 26 | end UA_Append_Tests; 27 | -------------------------------------------------------------------------------- /tests/src/Unbound_Array/unbound_array_suite.adb: -------------------------------------------------------------------------------- 1 | with AUnit.Test_Caller; 2 | with UA_Append_Tests; 3 | 4 | package body Unbound_Array_Suite is 5 | 6 | 7 | package Append_Test_Caller is new AUnit.Test_Caller(UA_Append_Tests.Test_Fixture); 8 | 9 | 10 | function Suite return Access_Test_Suite is 11 | UA_Suite : constant Access_Test_Suite := new Test_Suite; 12 | begin 13 | -- Add Append Tests --------------------------------- 14 | UA_Suite.Add_Test(Append_Test_Caller.Create("Test Append with enough Capacity => Everything appended", UA_Append_Tests.TestAppend_WithEnoughCapacity_ResultAppended'Access)); 15 | UA_Suite.Add_Test(Append_Test_Caller.Create("Test Append with too small initial Capacity => Everything appended", UA_Append_Tests.TestAppend_WithSmallCapacity_ResultAppended'Access)); 16 | UA_Suite.Add_Test(Append_Test_Caller.Create("Test Append with Index_Type limit reached => Not appended after limit", UA_Append_Tests.TestAppend_WithIndexEndReached_ResultNotAppended'Access)); 17 | 18 | 19 | 20 | return UA_Suite; 21 | end Suite; 22 | 23 | 24 | end Unbound_Array_Suite; 25 | -------------------------------------------------------------------------------- /tests/src/Unbound_Array/unbound_array_suite.ads: -------------------------------------------------------------------------------- 1 | with AUnit.Test_Suites; use AUnit.Test_Suites; 2 | 3 | package Unbound_Array_Suite is 4 | 5 | function Suite return Access_Test_Suite; 6 | 7 | end Unbound_Array_Suite; 8 | -------------------------------------------------------------------------------- /tests/src/prove_unbound.adb: -------------------------------------------------------------------------------- 1 | with Spark_Unbound.Arrays; 2 | 3 | --- Procedure to instantiate concrete packages of Unbound_Array to be proven by GNATprove. 4 | procedure Prove_Unbound with SPARK_Mode 5 | is 6 | 7 | type MyInt is new Integer with Default_Value => 0; 8 | 9 | package unbound_int is new Spark_Unbound.Arrays(Element_Type => MyInt, Index_Type => Positive); 10 | test : unbound_int.Unbound_Array := unbound_int.To_Unbound_Array (Initial_Capacity => 2); 11 | 12 | type myRange is range -1_000 .. 1_000; 13 | 14 | package unbound_neg_int is new Spark_Unbound.Arrays(Element_Type => MyInt, Index_Type => myRange); 15 | test_neg : unbound_neg_int.Unbound_Array := unbound_neg_int.To_Unbound_Array (Initial_Capacity => 1); 16 | 17 | type Test_Record is record 18 | Val1 : Integer; 19 | Val2 : Positive; 20 | end record; 21 | 22 | type Short_Range is range Short_Integer'First + 1 .. Short_Integer'Last; -- +1 needed for No_Index 23 | 24 | package unbound_record is new Spark_Unbound.Arrays(Element_Type => Test_Record, Index_Type => Short_Range); 25 | test_short : unbound_record.Unbound_Array := unbound_record.To_Unbound_Array(Initial_Capacity => 100); 26 | 27 | package pos_unbound_record is new Spark_Unbound.Arrays(Element_Type => Test_Record, Index_Type => Spark_Unbound.Long_Positive); -- Note: Long_Positive is the longest supported index range 28 | test_pos : pos_unbound_record.Unbound_Array := pos_unbound_record.To_Unbound_Array(Initial_Capacity => 10_000); 29 | 30 | -- Current Problem: "memory accessed through objects of access type" might not be initialized after elaboration of main program 31 | -- Note: Default_Component_Value is currently only supported for scalar types so no idea how to solve this 32 | 33 | -- Note: Using type Float will fail function `Contains` with default `=` (equality without delta is a bad idea for float types) 34 | 35 | begin 36 | 37 | unbound_int.Clear (test); 38 | unbound_neg_int.Clear (test_neg); 39 | unbound_record.Clear (test_short); 40 | pos_unbound_record.Clear (test_pos); 41 | 42 | end Prove_Unbound; 43 | -------------------------------------------------------------------------------- /tests/src/tests.adb: -------------------------------------------------------------------------------- 1 | with AUnit.Reporter.Text; 2 | with AUnit.Run; 3 | with Unbound_Array_Suite; 4 | with Safe_Alloc_Suite; 5 | with GNAT.OS_Lib; 6 | 7 | with Text_IO; 8 | with Spark_Unbound; 9 | 10 | procedure Tests is 11 | use type AUnit.Status; 12 | 13 | Reporter : AUnit.Reporter.Text.Text_Reporter; 14 | 15 | function Unbound_Array_Test_Runner is new AUnit.Run.Test_Runner_With_Status(Unbound_Array_Suite.Suite); 16 | function Safe_Alloc_Test_Runner is new AUnit.Run.Test_Runner_With_Status(Safe_Alloc_Suite.Suite); 17 | 18 | begin 19 | -- Run Unbound_Array tests 20 | if Unbound_Array_Test_Runner(Reporter) /= AUnit.Success then 21 | GNAT.OS_Lib.OS_Exit(1); 22 | end if; 23 | 24 | -- Run Safe_Alloc tests 25 | if Safe_Alloc_Test_Runner(Reporter) /= AUnit.Success then 26 | GNAT.OS_Lib.OS_Exit(1); 27 | end if; 28 | end Tests; 29 | -------------------------------------------------------------------------------- /tests/tests.gpr: -------------------------------------------------------------------------------- 1 | with "config/tests_config.gpr"; 2 | project Tests is 3 | 4 | for Source_Dirs use ("src/**"); 5 | for Object_Dir use "obj"; 6 | for Create_Missing_Dirs use "True"; 7 | for Exec_Dir use "bin"; 8 | for Main use ("tests.adb"); 9 | 10 | type Enabled_Kind is ("enabled", "disabled"); 11 | Compile_Checks : Enabled_Kind := External ("TESTS_COMPILE_CHECKS", "disabled"); 12 | Runtime_Checks : Enabled_Kind := External ("TESTS_RUNTIME_CHECKS", "disabled"); 13 | Style_Checks : Enabled_Kind := External ("TESTS_STYLE_CHECKS", "disabled"); 14 | Contracts_Checks : Enabled_Kind := External ("TESTS_CONTRACTS", "disabled"); 15 | 16 | type Build_Kind is ("debug", "optimize"); 17 | Build_Mode : Build_Kind := External ("TESTS_BUILD_MODE", "optimize"); 18 | 19 | Compile_Checks_Switches := (); 20 | case Compile_Checks is 21 | when "enabled" => 22 | Compile_Checks_Switches := 23 | ("-gnatwa", -- All warnings 24 | "-gnatVa", -- All validity checks 25 | "-gnatwe"); -- Warnings as errors 26 | when others => null; 27 | end case; 28 | 29 | Runtime_Checks_Switches := (); 30 | case Runtime_Checks is 31 | when "enabled" => null; 32 | when others => 33 | Runtime_Checks_Switches := 34 | ("-gnatp"); -- Suppress checks 35 | end case; 36 | 37 | Style_Checks_Switches := (); 38 | case Style_Checks is 39 | when "enabled" => 40 | Style_Checks_Switches := 41 | ("-gnatyg", -- GNAT Style checks 42 | "-gnaty-d", -- Disable no DOS line terminators 43 | "-gnatyM80", -- Maximum line length 44 | "-gnatyO"); -- Overriding subprograms explicitly marked as such 45 | when others => null; 46 | end case; 47 | 48 | Contracts_Switches := (); 49 | case Contracts_Checks is 50 | when "enabled" => 51 | Contracts_Switches := 52 | ("-gnata"); -- Enable assertions and contracts 53 | when others => null; 54 | end case; 55 | 56 | Build_Switches := (); 57 | case Build_Mode is 58 | when "optimize" => 59 | Build_Switches := ("-O3", -- Optimization 60 | "-gnatn"); -- Enable inlining 61 | when "debug" => 62 | Build_Switches := ("-g", -- Debug info 63 | "-Og"); -- No optimization 64 | end case; 65 | 66 | package Compiler is 67 | for Default_Switches ("Ada") use 68 | Compile_Checks_Switches & 69 | Build_Switches & 70 | Runtime_Checks_Switches & 71 | Style_Checks_Switches & 72 | Contracts_Switches & 73 | ("-gnatw.X", -- Disable warnings for No_Exception_Propagation 74 | "-gnatQ"); -- Don't quit. Generate ALI and tree files even if illegalities 75 | end Compiler; 76 | 77 | package Binder is 78 | for Switches ("Ada") use ("-Es"); -- Symbolic traceback 79 | end Binder; 80 | 81 | end Tests; 82 | --------------------------------------------------------------------------------