├── .github └── workflows │ └── ci.yml ├── .gitignore ├── README.md ├── array.cbl ├── assert-logic.cbl ├── assert.cbl ├── compile.bat ├── copy ├── array.cpy ├── catch9.pdv ├── catchx.pdv ├── definitions.cpy ├── macros.cpy └── movex.pdv ├── test-array.cbl └── testcomparator.cbl /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | # This is a basic workflow to help you get started with Actions 2 | 3 | name: CI 4 | 5 | # Controls when the action will run. Triggers the workflow on push or pull request 6 | # events but only for the master branch 7 | on: 8 | push: 9 | branches: [ master ] 10 | pull_request: 11 | branches: [ master ] 12 | 13 | # A workflow run is made up of one or more jobs that can run sequentially or in parallel 14 | jobs: 15 | # This workflow contains a single job called "build" 16 | build: 17 | # The type of runner that the job will run on 18 | runs-on: windows-latest 19 | 20 | # Steps represent a sequence of tasks that will be executed as part of the job 21 | steps: 22 | # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it 23 | - uses: actions/checkout@v2 24 | 25 | # Runs a single command using the runners shell 26 | - name: compile 27 | run: compile.bat 28 | 29 | # Runs a set of commands using the runners shell 30 | - name: test 31 | run: | 32 | crun32 -b bin\test-array.acu 33 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .vscode 2 | 3 | bin/* 4 | */**/err 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # (Acu) COBOL dynamic Arrays library 2 | 3 | ## Introduction 4 | 5 | The purpose of this project is to **provide a usable COBOL implementation of dynamic arrays**. 6 | 7 | Unfortunately it is written in **Acu dialect**. Syncerely I completely ignore if it can compile in any other COBOL dialect or not. 8 | 9 | However even if not, you can always fork this repo and provide your own. 10 | 11 | ## Why? 12 | 13 | I worked exlusively in Acu COBOL for 4 years consecutively. Unfortunately I discovered that Acu didn't provide any dynamic array implementation. 14 | 15 | Actually, as far as i know, no COBOL implementation provide dynamic arrays out of the box. 16 | 17 | **So here it is my COBOL implementation of dynamic arrays**. 18 | 19 | ## Getting Started 20 | 21 | For a complete usage examples of all the functionalities of the library, refer to [test-array.cbl](test-array.cbl) 22 | 23 | ### Declaring and allocating 24 | 25 | You can include as many arrays as you want, copying `copy "array.cpy" replacing ==!PREFIX!== by ==w-==.` in your working storage section. 26 | 27 | Then you should allocate a new array with 28 | 29 | ```cobol 30 | call "array:new" using w-array length of w-element. 31 | ``` 32 | 33 | There is a third optional parameter that is the type of the array. Default is **alphanumeric**, but you can specify to have a pure numeric array declaring 34 | 35 | ```cobol 36 | call "array:new" using w-array length of w-element "9". 37 | ``` 38 | 39 | or if you `copy definitions.cpy` 40 | 41 | ```cobol 42 | call "array:new" using w-array length of w-element NUMERIC. 43 | ``` 44 | 45 | You **MUST** free the array manually in order to prevent memory leak: 46 | 47 | ```cobol 48 | call "array:free" using w-array. 49 | ``` 50 | 51 | ### Complete basic usage example 52 | 53 | ```cobol 54 | identification division. 55 | program-id. usage-example. 56 | environment division. 57 | working-storage section. 58 | 59 | copy "array.cpy" replacing ==!PREFIX!== by ==w-==. | array data structure 60 | 77 w-element pic x(25) value spaces. 61 | 62 | linkage section. 63 | 64 | procedure division. 65 | call "array". 66 | | each array element is going to be 25 bytes in size 67 | call "array:new" using w-array length of w-element. 68 | 69 | | add 3 elements to the array 70 | call "array:append" using w-array "new element". 71 | call "array:append" using w-array "new element 2". 72 | call "array:append" using w-array "banana". 73 | 74 | | get the first 75 | call "array:get" using w-array w-element 0. | this gets "new element" into w-element 76 | 77 | | free dynamic memory 78 | call "array:free" using w-array. 79 | cancel "array". 80 | 81 | goback. 82 | ``` 83 | 84 | ### Dereference and use it as a table 85 | 86 | In order to improve performance and allow the use of **search** and **search all** keywords 87 | 88 | ```cobol 89 | identification division. 90 | program-id. usage-example. 91 | environment division. 92 | working-storage section. 93 | 94 | copy "array.cpy" replacing ==!PREFIX!== by ==w-==. 95 | 77 w-element pic x(25) value spaces. 96 | 97 | linkage section. 98 | 01 d-array-tbl. 99 | 03 d-array-element pic x(25) 100 | occurs 20000000 | use a number big enough but the total must be less then 2GB 101 | depending on w-array-length 102 | ascending key is d-array-element | this enables the usage of search all keyword 103 | . 104 | 105 | procedure division. 106 | call "array". 107 | |each array element is going to be 25 bytes in size 108 | call "array:new" using w-array length of w-element. 109 | 110 | | add 3 elements to the array 111 | call "array:append" using w-array "new element". 112 | call "array:append" using w-array "new element 2". 113 | call "array:append" using w-array "banana". 114 | 115 | | always set the address after all the appends. Append operation can change the pointer. 116 | | So every time you append something you have to set address of linkage again 117 | set address of d-array-tbl to w-array-ptr. 118 | move d-array-element(1) to w-element. | use it... this is 1 based index, as a usual table 119 | 120 | call "array:free" using w-array. 121 | cancel "array". 122 | 123 | goback. 124 | 125 | ``` 126 | 127 | ### Sorting 128 | 129 | Sorting is implemented with iterative quicksort. 130 | 131 | It can be as simple as 132 | 133 | ```cobol 134 | call "array:sort" using w-array. 135 | ``` 136 | 137 | but if you need to sort with only a part of you data structure, then you can do 138 | 139 | ```cobol 140 | call "array:sort" 141 | using w-array 142 | record-position of w-your-record-part | offset 143 | length of w-your-record-part | length 144 | . 145 | ``` 146 | 147 | ### Sorting with comparators 148 | 149 | If you need more complex ordering logic you can implement your own comparator. 150 | 151 | **A complete example of a comparator** can be found here [testcomparator.cbl](testcomparator.cbl) 152 | 153 | Comparators receive two elements and return -1 if the first is smaller then the second, 0 if they are equal or 1 it the first is greater then the second. 154 | 155 | Comparators linkage is declared as follows 156 | 157 | ```cobol 158 | identification division. 159 | program-id. mycomparator. 160 | 161 | ... 162 | 163 | linkage section. 164 | 77 l-first pic x(MAX-LINKAGE). 165 | 77 l-second pic x(MAX-LINKAGE). 166 | copy "array.cpy" replacing ==!PREFIX!== by ==l-==. 167 | 168 | procedure division using l-first l-second l-array. 169 | 170 | ... 171 | ``` 172 | 173 | then use it in this way 174 | 175 | ```cobol 176 | call "array:sort" 177 | using w-array 178 | record-position of w-your-record 179 | length of w-your-record 180 | "mycomparator" 181 | . 182 | ``` 183 | 184 | ## How to Compile 185 | 186 | A **compile.bat** script is provided for convenience. On Windows open a command prompt and run 187 | 188 | ```bash 189 | compile.bat 190 | ``` 191 | 192 | In order to run it succesfully, it is supposed that you have set the **ccbl32** compiler in your Windows **PATH** environment variable. 193 | 194 | This is going to compile in a directory named **bin**, in same path of the repo. 195 | 196 | If you want to compile only the **array** library, then run 197 | 198 | ```bash 199 | ccbl32.exe -Sp copy array.cbl 200 | ``` 201 | 202 | ## Test 203 | 204 | If you want to test if it is working properly, then you can open a prompt and run 205 | 206 | ```bash 207 | crun32.exe -b test-array.acu 208 | ``` 209 | 210 | If the output ends with 211 | 212 | ```bash 213 | Test is OK 214 | ``` 215 | 216 | then it is working properly. 217 | 218 | ## Code conventions 219 | 220 | The following conventions are applied in the code: 221 | 222 | * working storage variables start with **w-** 223 | * linkage variables start with **l-** 224 | * linkage variables used to dereference pointers start with **d-** (dynamic) 225 | 226 | Called programs that receives a linkage (like array itself) handles the linkage and move it in a safe corresponding working storage variable. 227 | 228 | This is done using: 229 | 230 | * **$CATCHPARAMS** macro declared in [macros.cpy](copy/macros.cpy) and copied in [definitions.cpy](copy/definitions.cpy) 231 | * copy [catchx.cpy](copy/catchx.cpy)/[catch9.cpy](copy/catch9.cpy) safely moves linkage in working 232 | * **linkage variables are declared as the maximum size** allowed for the corresponding picture type. 233 | 234 | This approach simplifies the use of libraries, so that it is not required that variables used to call a program, match the format declared in the corresponding linkage section. 235 | 236 | ## Test driven approach 237 | 238 | This library is developed following the test driven development approach (TDD). 239 | Tests are in [test-array.cbl](test-array.cbl). 240 | 241 | By the way this file represents also a complete specification of the library, as well as an extensive usage examples documentation. **If you are interested in this library I would suggest to have a look at it**. 242 | 243 | I implemented the minimum assertion logic needed in this development 244 | 245 | * [assert.cbl](assert.cbl) 246 | * [assert-logic.cbl](assert-logic.cbl) 247 | 248 | ## Error handling 249 | 250 | There is no error handling :fearful:. Yes this is quite an extreme choice, then I will try to argument. 251 | 252 | This is the second version of this library. I wrote the first one exacly 9 years ago. There was an error handling system in that case, but no one never actually used it. In 9 years of a really intensive usage of this library... it has never been a problem. (In our code base the word "array:" has **23954 hits in 1918 files**) 253 | 254 | I think that there is one main reasons for this: the cost/benefits ratio: doing a proper error handling in a procedural programming language, comes at the cost of explicitly check some kind of error code. You are going to write a lot of boilerplate code that, **given the relative low level of this library**, has the only effect to negatively affect the readability of your code. 255 | 256 | However if you are concerned about the fact that a `m$alloc` could eventually go out of memory, you can always check that the value of the pointer of the array returned different than zero, after an allocation or an element insertion. 257 | 258 | ## More about this library. 259 | 260 | I spoke about this library together Michele Riva in his podcast. Check it out if you like it. 261 | [![Making COBOL modern: dynamic arrays, recursion](https://img.youtube.com/vi/uQP89kG6K4k/0.jpg)](https://www.youtube.com/watch?v=uQP89kG6K4k) 262 | -------------------------------------------------------------------------------- /array.cbl: -------------------------------------------------------------------------------- 1 | identification division. 2 | program-id. array. 3 | author. Luca Piccinelli. 4 | date-written. 24.04.2020. 5 | environment division. 6 | configuration section. 7 | special-names. 8 | input-output section. 9 | file-control. 10 | data division. 11 | file section. 12 | working-storage section. 13 | copy "definitions.cpy" 14 | replacing ==!MAX-PARAMS-NUM== by ==4== 15 | . 16 | 17 | 78 INITIAL-CAPACITY value 2. 18 | 19 | copy "array.cpy" replacing ==!PREFIX!== by ==w-==. 20 | 77 w-element-sz pic 9(09) value 0. 21 | 77 w-capacity pic 9(09) value 0. 22 | 77 w-old-capacity pic 9(09) value 0. 23 | 77 w-bytes-to-shift pic 9(09) value 0. 24 | 77 w-offset-ptr usage pointer value 0. 25 | 77 w-where-to-move-ptr usage pointer value 0. 26 | 77 w-tmp-ptr usage pointer value 0. 27 | 77 w-index pic 9(MAX-NUMBER-SIZE). 28 | 77 w-out-element pic x(2048). 29 | 30 | 01 w-qsort-stack-tbl value zeros. 31 | 03 w-qsort-stack occurs 100. 32 | 05 w-qsort-stack-from pic 9(09). 33 | 05 w-qsort-stack-to pic 9(09). 34 | 35 | 77 w-qsort-stack-idx pic 9(09) value 0. 36 | 77 w-qsort-pivot-idx pic s9(09) value 0. 37 | 77 w-from pic 9(09) value 0. 38 | 77 w-to pic 9(09) value 0. 39 | 77 w-from-tmp pic 9(09) value 0. 40 | 77 w-to-tmp pic 9(09) value 0. 41 | 77 i pic 9(09) value 0. 42 | 77 j pic 9(09) value 0. 43 | 77 w-swap-idx1 pic 9(09) value 0. 44 | 77 w-swap-idx2 pic 9(09) value 0. 45 | 77 w-step pic 9(09) value 0. 46 | 77 w-store-idx pic 9(09) value 0. 47 | 48 | 77 w-swap-tmp-ptr usage pointer value 0. 49 | 77 w-array-compare-ptr usage pointer value 0. 50 | 77 w-pivot-value-ptr usage pointer value 0. 51 | 77 w-double-step pic 9(09) value 0. 52 | 77 w-partition-size pic 9(09) value 0. 53 | 77 w-compare-offset pic 9(09). 54 | 77 w-compare-sz pic 9(09). 55 | 77 w-comparator pic x(50) value spaces. 56 | 57 | 77 w-compare-result pic s9 value 0. 58 | 77 w-type pic x(32) value spaces. 59 | 60 | linkage section. 61 | copy "array.cpy" replacing ==!PREFIX!== by ==l-==. 62 | 77 l-element-sz pic 9(09). 63 | 77 l-type pic x(MAX-LINKAGE). 64 | 77 l-element pic x(MAX-LINKAGE). 65 | 77 l-out-element pic x(MAX-LINKAGE). 66 | 77 l-index pic 9(MAX-NUMBER-SIZE). 67 | 77 l-compare-offset pic 9(09). 68 | 77 l-compare-sz pic 9(09). 69 | 77 l-comparator pic x(MAX-LINKAGE). 70 | 71 | 77 d-array pic x(MAX-LINKAGE). 72 | 77 d-array-compare pic x(MAX-LINKAGE). 73 | 77 d-swap-tmp pic x(MAX-LINKAGE). 74 | 77 d-pivot-value pic x(MAX-LINKAGE). 75 | 76 | procedure division using 77 | d-array 78 | . 79 | post-process. 80 | goback. 81 | 82 | entry "array:new" using l-array l-element-sz l-type. 83 | $CATCHPARAMS. 84 | copy "catchx.pdv" replacing 85 | ==!W== by ==array== 86 | ==!N== by ==1==. 87 | copy "catch9.pdv" replacing 88 | ==!W== by ==element-sz== 89 | ==!N== by ==2==. 90 | move TALPHANUMERIC to w-type. 91 | copy "catchx.pdv" replacing 92 | ==!W== by ==type== 93 | ==!N== by ==3==. 94 | 95 | move w-element-sz to w-array-element-sz. 96 | move w-type to w-array-type. 97 | move INITIAL-CAPACITY to w-array-capacity. 98 | perform alloc thru alloc-ex. 99 | 100 | move 0 to w-array-length. 101 | 102 | copy "movex.pdv" replacing 103 | ==!W== by ==array== 104 | ==!N== by ==1==. 105 | $RETURN. 106 | 107 | entry "array:free" using l-array. 108 | $CATCHPARAMS. 109 | copy "catchx.pdv" replacing 110 | ==!W== by ==array== 111 | ==!N== by ==1==. 112 | 113 | if w-array-ptr = 0 114 | $RETURN 115 | end-if. 116 | 117 | call "m$free" using w-array-ptr. 118 | initialize w-array. 119 | 120 | copy "movex.pdv" replacing 121 | ==!W== by ==array== 122 | ==!N== by ==1==. 123 | $RETURN. 124 | 125 | 126 | entry "array:append" using l-array l-element. 127 | $CATCHPARAMS. 128 | copy "catchx.pdv" replacing 129 | ==!W== by ==array== 130 | ==!N== by ==1==. 131 | 132 | perform realloc thru realloc-ex. 133 | compute w-offset-ptr = 134 | w-array-ptr + (w-array-element-sz * w-array-length). 135 | perform move-linkage-value-to-the-array 136 | thru move-linkage-value-to-the-array-ex. 137 | 138 | copy "movex.pdv" replacing 139 | ==!W== by ==array== 140 | ==!N== by ==1==. 141 | $RETURN. 142 | 143 | entry "array:insert" using l-array l-element l-index. 144 | $CATCHPARAMS. 145 | copy "catchx.pdv" replacing 146 | ==!W== by ==array== 147 | ==!N== by ==1==. 148 | copy "catch9.pdv" replacing 149 | ==!W== by ==index== 150 | ==!N== by ==3==. 151 | 152 | if w-index >= w-array-length 153 | $RETURN 154 | end-if. 155 | perform realloc thru realloc-ex. 156 | perform shift-the-array thru shift-the-array-ex. 157 | perform move-linkage-value-to-the-array 158 | thru move-linkage-value-to-the-array-ex. 159 | 160 | copy "movex.pdv" replacing 161 | ==!W== by ==array== 162 | ==!N== by ==1==. 163 | $RETURN. 164 | 165 | 166 | entry "array:get" using l-array l-out-element l-index. 167 | $CATCHPARAMS. 168 | copy "catchx.pdv" replacing 169 | ==!W== by ==array== 170 | ==!N== by ==1==. 171 | copy "catch9.pdv" replacing 172 | ==!W== by ==index== 173 | ==!N== by ==3==. 174 | 175 | compute w-offset-ptr = 176 | w-array-ptr + (w-array-element-sz * w-index). 177 | set address of d-array to w-offset-ptr. 178 | move d-array(1:w-array-element-sz) 179 | to l-out-element(1:w-args-size(2)). 180 | 181 | $RETURN. 182 | 183 | entry "array:sort" using 184 | l-array 185 | l-compare-offset 186 | l-compare-sz 187 | l-comparator 188 | . 189 | 190 | $CATCHPARAMS. 191 | copy "catchx.pdv" replacing 192 | ==!W== by ==array== 193 | ==!N== by ==1==. 194 | move 0 to w-compare-offset. 195 | copy "catch9.pdv" replacing 196 | ==!W== by ==compare-offset== 197 | ==!N== by ==2==. 198 | move w-array-element-sz to w-compare-sz. 199 | copy "catch9.pdv" replacing 200 | ==!W== by ==compare-sz== 201 | ==!N== by ==3==. 202 | move spaces to w-comparator. 203 | copy "catchx.pdv" replacing 204 | ==!W== by ==comparator== 205 | ==!N== by ==4==. 206 | 207 | perform initialize-sort 208 | thru initialize-sort-ex. 209 | 210 | perform initialize-stack 211 | thru initialize-stack-ex. 212 | 213 | perform until w-qsort-stack-idx <= 0 214 | perform pop-stack 215 | 216 | subtract w-from from w-to giving w-partition-size 217 | if w-from >= w-to or (w-partition-size < w-step) 218 | exit perform cycle 219 | end-if 220 | 221 | perform compute-pivot 222 | perform qpartition 223 | perform push-left-partition 224 | perform push-right-partition 225 | end-perform. 226 | 227 | call "m$free" using w-pivot-value-ptr. 228 | call "m$free" using w-swap-tmp-ptr. 229 | 230 | $RETURN. 231 | 232 | 233 | qpartition. 234 | if w-partition-size = 0 235 | exit paragraph 236 | end-if. 237 | if w-partition-size = w-step 238 | perform partition-only-two-elements 239 | exit paragraph 240 | end-if. 241 | 242 | move d-array-compare(w-qsort-pivot-idx:w-compare-sz) 243 | to d-pivot-value(1:w-compare-sz). 244 | 245 | move w-qsort-pivot-idx to w-swap-idx1. 246 | move w-to to w-swap-idx2. 247 | perform swap. 248 | 249 | move w-from to w-store-idx. 250 | perform varying i from w-from by w-step 251 | until i >= w-to 252 | 253 | perform compare-with-pivot 254 | 255 | if w-compare-result < 0 256 | move i to w-swap-idx1 257 | move w-store-idx to w-swap-idx2 258 | perform swap 259 | add w-step to w-store-idx 260 | end-if 261 | 262 | end-perform. 263 | move w-to to w-swap-idx1. 264 | move w-store-idx to w-swap-idx2. 265 | perform swap. 266 | 267 | move w-store-idx to w-qsort-pivot-idx. 268 | qpartition-ex. 269 | exit. 270 | 271 | compare-with-pivot. 272 | if w-comparator <> spaces 273 | call w-comparator 274 | using d-array-compare(i:w-compare-sz) 275 | d-pivot-value(1:w-compare-sz) 276 | w-array 277 | giving w-compare-result 278 | exit paragraph 279 | end-if. 280 | 281 | if d-array-compare(i:w-compare-sz) < 282 | d-pivot-value(1:w-compare-sz) 283 | 284 | move -1 to w-compare-result 285 | else 286 | move 1 to w-compare-result 287 | end-if. 288 | compare-with-pivot-ex. 289 | exit. 290 | 291 | compare-array-elements. 292 | if w-comparator <> spaces 293 | call w-comparator 294 | using d-array-compare(w-from:w-compare-sz) 295 | d-array-compare(w-to:w-compare-sz) 296 | w-array 297 | giving w-compare-result 298 | exit paragraph 299 | end-if. 300 | 301 | if d-array-compare(w-from:w-compare-sz) < 302 | d-array-compare(w-to:w-compare-sz) 303 | 304 | move -1 to w-compare-result 305 | else 306 | move 1 to w-compare-result 307 | end-if. 308 | compare-array-elements-ex. 309 | exit. 310 | 311 | partition-only-two-elements. 312 | perform compare-array-elements. 313 | if w-compare-result > 0 314 | move w-from to w-swap-idx1 315 | move w-to to w-swap-idx2 316 | perform swap thru swap-ex 317 | move w-from to w-qsort-pivot-idx 318 | else 319 | move w-to to w-qsort-pivot-idx 320 | end-if. 321 | partition-only-two-elements-ex. 322 | exit. 323 | 324 | swap. 325 | if w-swap-idx1 = w-swap-idx2 326 | exit paragraph 327 | end-if. 328 | 329 | move d-array(w-swap-idx1:w-array-element-sz) 330 | to d-swap-tmp(1:w-array-element-sz). 331 | move d-array(w-swap-idx2:w-array-element-sz) 332 | to d-array(w-swap-idx1:w-array-element-sz). 333 | move d-swap-tmp(1:w-array-element-sz) 334 | to d-array(w-swap-idx2:w-array-element-sz). 335 | swap-ex. 336 | exit. 337 | 338 | alloc. 339 | compute w-capacity = w-array-capacity * w-element-sz. 340 | call "m$alloc" using w-capacity w-array-ptr. 341 | alloc-ex. 342 | exit. 343 | 344 | realloc. 345 | if w-array-length < w-array-capacity 346 | exit paragraph 347 | end-if 348 | 349 | compute w-old-capacity = w-array-capacity * w-element-sz. 350 | multiply w-array-capacity by 2 giving w-array-capacity. 351 | move w-array-ptr to w-tmp-ptr. 352 | perform alloc thru alloc-ex. 353 | call "m$copy" using w-array-ptr w-tmp-ptr w-old-capacity. 354 | call "m$free" using w-tmp-ptr. 355 | initialize w-tmp-ptr. 356 | realloc-ex. 357 | exit. 358 | 359 | compute-shift-params. 360 | compute w-offset-ptr = 361 | w-array-ptr + (w-array-element-sz * w-index). 362 | add w-array-element-sz to w-offset-ptr 363 | giving w-where-to-move-ptr. 364 | compute w-bytes-to-shift = 365 | (w-array-length - w-index) * w-array-element-sz 366 | end-compute. 367 | 368 | compute-shift-params-ex. 369 | exit. 370 | 371 | shift-the-array. 372 | perform compute-shift-params thru compute-shift-params-ex. 373 | call "m$copy" 374 | using w-where-to-move-ptr 375 | w-offset-ptr 376 | w-bytes-to-shift. 377 | 378 | shift-the-array-ex. 379 | exit. 380 | 381 | move-linkage-value-to-the-array. 382 | set address of d-array to w-offset-ptr. 383 | if w-NUMERIC-ARRAY-TYPE 384 | perform move-numeric-linkage 385 | thru move-numeric-linkage-ex 386 | else 387 | move l-element(1:w-args-size(2)) 388 | to d-array(1:w-array-element-sz) 389 | end-if. 390 | add 1 to w-array-length. 391 | move-linkage-value-to-the-array-ex. 392 | exit. 393 | 394 | pop-stack. 395 | move w-qsort-stack-from(w-qsort-stack-idx) to w-from. 396 | move w-qsort-stack-to(w-qsort-stack-idx) to w-to. 397 | subtract 1 from w-qsort-stack-idx. 398 | pop-stack-ex. 399 | exit. 400 | 401 | push-right-partition. 402 | add w-step to w-qsort-pivot-idx giving w-from-tmp. 403 | if w-from-tmp >= w-to 404 | exit paragraph 405 | end-if. 406 | 407 | add 1 to w-qsort-stack-idx. 408 | move w-from-tmp to w-qsort-stack-from(w-qsort-stack-idx). 409 | move w-to to w-qsort-stack-to(w-qsort-stack-idx). 410 | push-right-partition-ex. 411 | exit. 412 | 413 | push-left-partition. 414 | subtract w-step from w-qsort-pivot-idx giving w-to-tmp. 415 | if w-from >= w-to-tmp 416 | exit paragraph 417 | end-if. 418 | 419 | add 1 to w-qsort-stack-idx. 420 | move w-from to w-qsort-stack-from(w-qsort-stack-idx). 421 | move w-to-tmp to w-qsort-stack-to(w-qsort-stack-idx). 422 | push-left-partition-ex. 423 | exit. 424 | 425 | initialize-sort. 426 | call "m$alloc" using w-compare-sz w-pivot-value-ptr. 427 | call "m$alloc" using w-array-element-sz w-swap-tmp-ptr. 428 | set address of d-pivot-value to w-pivot-value-ptr. 429 | set address of d-swap-tmp to w-swap-tmp-ptr. 430 | set address of d-array to w-array-ptr. 431 | add w-compare-offset to w-array-ptr 432 | giving w-array-compare-ptr. 433 | set address of d-array-compare to w-array-compare-ptr. 434 | move zeros to w-qsort-stack-tbl. 435 | move w-element-sz to w-step. 436 | multiply w-step by 2 giving w-double-step. 437 | initialize-sort-ex. 438 | exit. 439 | 440 | initialize-stack. 441 | move 1 to w-qsort-stack-idx. 442 | move 1 to w-qsort-stack-from(w-qsort-stack-idx). 443 | compute w-qsort-stack-to(w-qsort-stack-idx) = 444 | ((w-array-length - 1) * w-array-element-sz) + 1 445 | end-compute. 446 | initialize-stack-ex. 447 | exit. 448 | 449 | compute-pivot. 450 | compute w-qsort-pivot-idx = w-from + 451 | function integer-part(w-partition-size / w-double-step) 452 | * w-step 453 | end-compute. 454 | compute-pivot-ex. 455 | exit. 456 | 457 | move-numeric-linkage. 458 | if w-args-size(2) <= w-array-element-sz 459 | move zeros to d-array(1:w-array-element-sz) 460 | move l-element(1:w-args-size(2)) 461 | to d-array(w-array-element-sz - w-args-size(2) + 1 462 | :w-args-size(2)) 463 | else 464 | move l-element(w-args-size(2) - w-array-element-sz + 1: 465 | w-array-element-sz) 466 | to d-array(1:w-array-element-sz) 467 | end-if. 468 | move-numeric-linkage-ex. 469 | exit. 470 | 471 | 472 | 473 | 474 | 475 | 476 | 477 | 478 | 479 | 480 | 481 | 482 | 483 | 484 | -------------------------------------------------------------------------------- /assert-logic.cbl: -------------------------------------------------------------------------------- 1 | identification division. 2 | program-id. assert-logic. 3 | author. Luca Piccinelli. 4 | date-written. 26.04.2020. 5 | environment division. 6 | configuration section. 7 | special-names. 8 | input-output section. 9 | file-control. 10 | data division. 11 | file section. 12 | working-storage section. 13 | copy "definitions.cpy" 14 | replacing ==!MAX-PARAMS-NUM== by ==4==. 15 | 16 | 78 MEMBERS-DIMENSION value 2048. 17 | 18 | 77 w-operator pic x(16) value EQ. 19 | 77 w-expected pic x(MEMBERS-DIMENSION) value spaces. 20 | 77 w-actual pic x(MEMBERS-DIMENSION) value spaces. 21 | 22 | 77 w-array-data-length pic 9(09) value 0. 23 | copy "array.cpy" 24 | replacing ==!PREFIX!== by ==w-==. 25 | 26 | linkage section. 27 | 77 l-operator pic x(MAX-LINKAGE). 28 | 77 l-expected pic x(MAX-LINKAGE). 29 | 77 l-actual pic x(MAX-LINKAGE). 30 | 31 | 77 d-array-data pic x(MAX-LINKAGE). 32 | 33 | procedure division using 34 | l-operator 35 | l-expected 36 | l-actual 37 | 38 | d-array-data 39 | . 40 | 41 | main. 42 | $CATCHPARAMS. 43 | copy "catchx.pdv" replacing 44 | ==!W== by ==operator== 45 | ==!N== by ==1==. 46 | copy "catchx.pdv" replacing 47 | ==!W== by ==expected== 48 | ==!N== by ==2==. 49 | copy "catchx.pdv" replacing 50 | ==!W== by ==actual== 51 | ==!N== by ==3==. 52 | 53 | evaluate w-operator 54 | when EQ 55 | perform equality thru equality-ex 56 | when ARRAY-EQ 57 | perform array-equality thru array-equality-ex 58 | end-evaluate. 59 | 60 | goback giving KO. 61 | 62 | equality. 63 | if w-actual = w-expected 64 | goback giving OK 65 | else 66 | inspect w-actual replacing trailing space by low-value 67 | inspect w-expected replacing trailing space by low-value 68 | copy "movex.pdv" replacing 69 | ==!W== by ==expected== 70 | ==!N== by ==2==. 71 | copy "movex.pdv" replacing 72 | ==!W== by ==actual== 73 | ==!N== by ==3==. 74 | goback giving KO 75 | end-if. 76 | 77 | equality-ex. 78 | exit. 79 | 80 | array-equality. 81 | move w-actual to w-array. 82 | compute w-array-data-length = 83 | w-array-length * w-array-element-sz 84 | end-compute. 85 | set address of d-array-data to w-array-ptr. 86 | 87 | move d-array-data(1:w-array-data-length) to w-actual 88 | move low-value to w-actual(w-array-data-length + 1:1) 89 | copy "movex.pdv" replacing 90 | ==!W== by ==actual== 91 | ==!N== by ==3==.. 92 | 93 | move w-expected(1:w-array-data-length) to w-expected 94 | move low-value to w-expected(w-array-data-length + 1:1) 95 | copy "movex.pdv" replacing 96 | ==!W== by ==expected== 97 | ==!N== by ==2==.. 98 | 99 | if d-array-data(1:w-array-data-length) = 100 | w-expected(1:w-array-data-length) 101 | goback giving OK 102 | else 103 | goback giving KO 104 | end-if. 105 | array-equality-ex. 106 | exit. 107 | -------------------------------------------------------------------------------- /assert.cbl: -------------------------------------------------------------------------------- 1 | identification division. 2 | program-id. assert. 3 | author. Luca Piccinelli. 4 | date-written. 26.04.2020. 5 | environment division. 6 | configuration section. 7 | special-names. 8 | input-output section. 9 | file-control. 10 | data division. 11 | file section. 12 | working-storage section. 13 | copy "definitions.cpy" 14 | replacing ==!MAX-PARAMS-NUM== by ==4==. 15 | 16 | 78 VALUE-DIMENSION value 2048. 17 | 78 DESCRIPTION-DIMENSION value 2048. 18 | 19 | 77 w-operator pic x(16) value EQ. 20 | 77 w-expected pic x(VALUE-DIMENSION) value spaces. 21 | 77 w-actual pic x(VALUE-DIMENSION) value spaces. 22 | 77 w-description pic x(DESCRIPTION-DIMENSION) 23 | value "empty description". 24 | 25 | 77 w-return-value pic 9(02) value 0. 26 | 77 w-display-decription pic x(256) value spaces. 27 | 77 w-string-pointer pic 9(18) value 0. 28 | 29 | 77 w-total-number-of-tests pic 9(09) value 0. 30 | 77 z-total-number-of-tests pic z(04)9. 31 | 32 | 77 w-success-number-of-tests pic 9(09) value 0. 33 | 77 z-success-number-of-tests pic z(04)9. 34 | 35 | 77 w-failed-number-of-tests pic 9(09) value 0. 36 | 77 z-failed-number-of-tests pic z(04)9. 37 | 38 | 77 w-verify-str pic x(256) value spaces. 39 | 40 | linkage section. 41 | 77 l-operator pic x(MAX-LINKAGE). 42 | 77 l-expected pic x(MAX-LINKAGE). 43 | 77 l-actual pic x(MAX-LINKAGE). 44 | 77 l-description pic x(MAX-LINKAGE). 45 | 46 | procedure division using 47 | l-operator 48 | l-expected 49 | l-actual 50 | l-description 51 | . 52 | $CATCHPARAMS. 53 | copy "catchx.pdv" replacing 54 | ==!W== by ==operator== 55 | ==!N== by ==1==. 56 | copy "catchx.pdv" replacing 57 | ==!W== by ==expected== 58 | ==!N== by ==2==. 59 | copy "catchx.pdv" replacing 60 | ==!W== by ==actual== 61 | ==!N== by ==3==. 62 | copy "catchx.pdv" replacing 63 | ==!W== by ==description== 64 | ==!N== by ==4==. 65 | 66 | if w-operator = VERIFY 67 | perform run-verify thru run-verify-ex 68 | goback giving 0 69 | end-if. 70 | 71 | call "assert-logic" 72 | using w-operator w-expected w-actual 73 | giving w-return-value. 74 | 75 | add 1 to w-total-number-of-tests. 76 | 77 | initialize w-display-decription 78 | move 1 to w-string-pointer. 79 | if w-return-value = OK 80 | add 1 to w-success-number-of-tests 81 | string 82 | "OK -- " 83 | into w-display-decription 84 | pointer w-string-pointer 85 | end-string 86 | else 87 | add 1 to w-failed-number-of-tests 88 | string 89 | "KO -- " 90 | into w-display-decription 91 | pointer w-string-pointer 92 | end-string 93 | end-if. 94 | 95 | string 96 | w-description 97 | delimited by STRING-LIMIT 98 | into w-display-decription 99 | pointer w-string-pointer 100 | end-string. 101 | 102 | if w-return-value = KO 103 | string 104 | " -- Expected " 105 | w-expected 106 | ". It was instead " 107 | w-actual 108 | delimited by low-value 109 | into w-display-decription 110 | pointer w-string-pointer 111 | end-string 112 | end-if. 113 | 114 | display w-display-decription upon console. 115 | 116 | goback giving w-return-value. 117 | 118 | run-verify. 119 | move w-total-number-of-tests to z-total-number-of-tests. 120 | move w-success-number-of-tests to z-success-number-of-tests. 121 | move w-failed-number-of-tests to z-failed-number-of-tests. 122 | initialize w-verify-str. 123 | string 124 | "RESULTS:" 125 | z-total-number-of-tests 126 | " were executed." 127 | z-success-number-of-tests 128 | " were OK." 129 | z-failed-number-of-tests 130 | " were KO." 131 | into w-verify-str 132 | end-string. 133 | 134 | display w-verify-str upon console. 135 | if w-failed-number-of-tests = 0 136 | display "Test is OK" upon console 137 | else 138 | display "Test is KO" upon console 139 | end-if. 140 | run-verify-ex. 141 | exit. 142 | 143 | -------------------------------------------------------------------------------- /compile.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | set BIN=bin 3 | 4 | if not exist %BIN% mkdir %BIN% 5 | 6 | for %%f in (*.cbl) do ccbl32.exe -Sp copy -o bin\%%~nf.acu %%f -------------------------------------------------------------------------------- /copy/array.cpy: -------------------------------------------------------------------------------- 1 | 01 !PREFIX!array. 2 | 05 !PREFIX!array-ptr usage pointer. 3 | 05 !PREFIX!array-version pic 9(05). 4 | 05 !PREFIX!array-data. 5 | 07 !PREFIX!array-element-sz pic 9(09) usage comp-4. 6 | 07 !PREFIX!array-length pic 9(09) usage comp-4. 7 | 07 !PREFIX!array-capacity pic 9(09) usage comp-4. 8 | 07 !PREFIX!array-type pic x(32). 9 | 88 !PREFIX!NUMERIC-ARRAY-TYPE value TNUMERIC. 10 | 88 !PREFIX!ALPHANUMERIC-ARRAY-TYPE value TALPHANUMERIC. 11 | 05 filler pic x(100). -------------------------------------------------------------------------------- /copy/catch9.pdv: -------------------------------------------------------------------------------- 1 | if w-narg >= !N and w-args-size(!N) > 0 2 | if length of w-!W >= w-args-size(!N) 3 | initialize w-!W 4 | move l-!W(1:w-args-size(!N)) 5 | to w-!W( 6 | length of w-!W - w-args-size(!N) + 1 7 | :w-args-size(!N)) 8 | else 9 | if w-args-size(!N) <= length of l-!W 10 | move l-!W( 11 | w-args-size(!N) - length of w-!W + 1 12 | :w-args-size(!N)) 13 | to w-!W 14 | else 15 | move l-!W(1:length of l-!W) to w-!W convert 16 | end-if 17 | end-if 18 | end-if -------------------------------------------------------------------------------- /copy/catchx.pdv: -------------------------------------------------------------------------------- 1 | if w-narg >= !N and w-args-size(!N) > 0 2 | if length of l-!W < w-args-size(!N) 3 | move length of l-!W to w-args-size(!N) 4 | end-if 5 | move l-!W(1:w-args-size(!N)) to w-!W 6 | end-if -------------------------------------------------------------------------------- /copy/definitions.cpy: -------------------------------------------------------------------------------- 1 | 78 MAX-LINKAGE value 2000000000. 2 | 78 MAX-NUMBER-SIZE value 18. 3 | 78 OK value 0. 4 | 78 KO value 1. 5 | 78 TNUMERIC value "9". 6 | 78 TALPHANUMERIC value "x". 7 | 8 | 78 EQ value "eq". 9 | 78 NUM-EQ value "numeq". 10 | 78 ARRAY-EQ value "aeq". 11 | 78 VERIFY value "verify". 12 | 78 STRING-LIMIT value " ". 13 | 14 | copy "macros.cpy". 15 | 16 | 78 w78-max-params-num value !MAX-PARAMS-NUM. 17 | 77 w-param-ind pic 9(02) usage comp-1 value 0. 18 | 77 w-param-ind-x-err pic x(02) value spaces. 19 | 77 w-narg pic 9(02) usage comp-1 value 0. 20 | 01 w-args-size-map. 21 | 05 w-args-size pic 9(09) occurs w78-max-params-num. -------------------------------------------------------------------------------- /copy/macros.cpy: -------------------------------------------------------------------------------- 1 | REPLACE 2 | ==!MAX-PARAMS-NUM== by ==1== 3 | ==$RETURN== by ==go post-process== 4 | ==$CATCHPARAMS== by 5 | == 6 | call "c$narg" using w-narg end-call 7 | 8 | perform varying w-param-ind 9 | from 1 by 1 until w-param-ind > w-narg 10 | 11 | call "c$paramsize" 12 | using w-param-ind 13 | giving w-args-size(w-param-ind) 14 | end-perform 15 | ==. -------------------------------------------------------------------------------- /copy/movex.pdv: -------------------------------------------------------------------------------- 1 | if w-narg >= !N and w-args-size(!N) > 0 2 | if w-args-size(!N) >= length of w-!W 3 | move length of w-!W to w-args-size(!N) 4 | end-if 5 | move w-!W(1:w-args-size(!N)) to l-!W(1:w-args-size(!N)) 6 | end-if -------------------------------------------------------------------------------- /test-array.cbl: -------------------------------------------------------------------------------- 1 | identification division. 2 | program-id. test-array. 3 | author. Studiofarma nome autore. 4 | date-written. Data. 5 | environment division. 6 | configuration section. 7 | special-names. 8 | input-output section. 9 | file-control. 10 | data division. 11 | file section. 12 | working-storage section. 13 | copy "definitions.cpy". 14 | 15 | 78 STR-EL-SZ value 10. 16 | 78 NUM-EL-SZ value 9. 17 | 77 w-str-element pic x(STR-EL-SZ). 18 | 77 w-num-element pic 9(NUM-EL-SZ) value 0. 19 | 77 w-num-element2 pic 9(NUM-EL-SZ) value 0. 20 | 77 w-bigger-num-element pic 9(10) value 0. 21 | 77 w-max-elements pic 9(NUM-EL-SZ) value 0. 22 | 77 j pic 9(NUM-EL-SZ) value 0. 23 | 77 i pic 9(NUM-EL-SZ) value 0. 24 | 77 i-d redefines i pic 9v99999999. 25 | 77 w-actual pic x(2048). 26 | 77 w-actual-num pic 9(NUM-EL-SZ). 27 | 77 w-expected pic x(2048). 28 | 77 w-expected-num pic 9(NUM-EL-SZ). 29 | 30 | 31 | copy "array.cpy" replacing ==!PREFIX!== by ==w-==. 32 | copy "array.cpy" replacing ==!PREFIX!== by ==w-expected-==. 33 | 34 | 01 w-expected-array-str-tbl value spaces. 35 | 05 w-expected-array-str-arr pic x(STR-EL-SZ) occurs 100. 36 | 37 | 01 w-expected-array-num-tbl value zeros. 38 | 05 w-expected-array-num-arr pic 9(NUM-EL-SZ) occurs 100. 39 | 40 | 01 w-expected-array-stt-tbl. 41 | 03 w-expected-array-stt-arr occurs 100. 42 | 05 w-expected-array-stt-arr-x pic x(25). 43 | 05 w-expected-array-stt-arr-9 pic 9(08). 44 | 45 | 01 w-stt. 46 | 05 w-stt-x pic x(25) value spaces. 47 | 05 w-stt-9 pic 9(08) value zeros. 48 | 78 STT-SZ value length of w-stt. 49 | 50 | linkage section. 51 | 01 d-array-str-tbl value spaces. 52 | 05 d-array-str-arr 53 | pic x(STR-EL-SZ) 54 | occurs 200000000 55 | depending on w-array-length. 56 | 57 | 01 d-array-num-tbl value spaces. 58 | 05 d-array-num-arr 59 | pic x(NUM-EL-SZ) 60 | occurs 200000000 61 | depending on w-array-length. 62 | 63 | procedure division using 64 | 65 | d-array-str-tbl 66 | . 67 | call "array". 68 | 69 | perform test-allocation 70 | thru test-allocation-ex. 71 | perform test-append1 72 | thru test-append1-ex. 73 | 74 | call "array:free" using w-array. 75 | perform test-append-many 76 | thru test-append-many-ex. 77 | 78 | perform test-element-overflow 79 | thru test-element-overflow-ex. 80 | 81 | perform test-get-of-an-element 82 | thru test-get-of-an-element-ex. 83 | perform test-get-of-an-element-numeric 84 | thru test-get-of-an-element-numeric-ex. 85 | 86 | perform test-insert 87 | thru test-insert-ex. 88 | 89 | perform test-append-and-get-of-a-numeric-value 90 | thru test-append-and-get-of-a-numeric-value-ex. 91 | 92 | perform test-sorting-alphanumerics 93 | thru test-sorting-alphanumerics-ex. 94 | perform test-sorting-numbers 95 | thru test-sorting-numbers-ex. 96 | perform test-sorting 97 | thru test-sorting-ex. 98 | perform test-sorting-parts-of-data-structures 99 | thru test-sorting-parts-of-data-structures-ex. 100 | perform test-sorting-comparators 101 | thru test-sorting-comparators-ex. 102 | 103 | call "assert" using VERIFY. 104 | 105 | cancel "array". 106 | cancel "assert". 107 | goback. 108 | 109 | test-allocation. 110 | move STR-EL-SZ to w-expected-array-element-sz. 111 | move 0 to w-expected-array-length. 112 | move 2 to w-expected-array-capacity. 113 | move "x" to w-expected-array-type. 114 | call "array:new" using w-array length of w-str-element. 115 | call "assert" 116 | using EQ 117 | w-expected-array-data 118 | w-array-data 119 | "array should be allocated as expected". 120 | test-allocation-ex. 121 | exit. 122 | 123 | test-append1. 124 | initialize w-expected-array-str-tbl. 125 | move "bla" to w-expected-array-str-arr(1). 126 | move "bla2" to w-expected-array-str-arr(2). 127 | call "array:append" using w-array "bla". 128 | call "array:append" using w-array "bla2". 129 | call "assert" 130 | using ARRAY-EQ 131 | w-expected-array-str-tbl 132 | w-array 133 | "after appending, array should contain a new element 134 | - "". 135 | move 2 to w-expected-array-length. 136 | call "assert" using EQ w-expected-array-length w-array-length 137 | "after appending, array length should increment". 138 | test-append1-ex. 139 | exit. 140 | 141 | test-append-many. 142 | call "array:new" using w-array length of w-str-element. 143 | initialize w-expected-array-str-tbl. 144 | move "xx" to w-expected-array-str-arr(1). 145 | move "yyyy" to w-expected-array-str-arr(2). 146 | move "zzzzzz" to w-expected-array-str-arr(3). 147 | call "array:append" using w-array "xx". 148 | call "array:append" using w-array "yyyy". 149 | call "array:append" using w-array "zzzzzz". 150 | call "assert" 151 | using ARRAY-EQ 152 | w-expected-array-str-tbl 153 | w-array 154 | "it should continue to append also when it excedees 155 | - "the initial capacity". 156 | move 3 to w-expected-array-length. 157 | call "assert" using EQ w-expected-array-length w-array-length 158 | "after appending, array length should increment". 159 | 160 | call "array:free" using w-array. 161 | test-append-many-ex. 162 | exit. 163 | 164 | test-element-overflow. 165 | call "array:new" using w-array length of w-str-element. 166 | initialize w-expected-array-str-tbl. 167 | move "0123456789" to w-expected-array-str-tbl. 168 | call "array:append" using w-array "01234567891". 169 | call "assert" 170 | using ARRAY-EQ 171 | w-expected-array-str-tbl 172 | w-array 173 | "when you append an element that exceeds the element 174 | - "size, it should be truncated". 175 | 176 | call "array:free" using w-array. 177 | test-element-overflow-ex. 178 | exit. 179 | 180 | test-get-of-an-element. 181 | call "array:new" using w-array length of w-str-element. 182 | move "test" to w-expected. 183 | initialize w-actual. 184 | call "array:append" using w-array w-expected. 185 | call "array:get" using w-array w-actual 0. 186 | 187 | call "assert" 188 | using EQ 189 | w-expected 190 | w-actual 191 | "it should be possible to read an element with 0 bas 192 | - "ed indexing system". 193 | 194 | move "test2" to w-expected. 195 | initialize w-actual. 196 | call "array:append" using w-array w-expected. 197 | call "array:get" using w-array w-actual 1. 198 | 199 | call "assert" 200 | using EQ 201 | w-expected 202 | w-actual 203 | "it should be possible to read elements with 0 based 204 | - "indexing system". 205 | 206 | move "test3" to w-expected. 207 | initialize w-actual. 208 | call "array:append" using w-array w-expected. 209 | call "array:get" using w-array w-actual 2. 210 | 211 | call "assert" 212 | using EQ 213 | w-expected 214 | w-actual 215 | "it should be possible to read elements with 0 based 216 | - "indexing system". 217 | 218 | set address of d-array-str-tbl to w-array-ptr. 219 | call "assert" 220 | using EQ 221 | w-expected 222 | d-array-str-arr(3) 223 | "it should be possible to read elements dereferencin 224 | - "g the array with a linkage table". 225 | 226 | call "array:free" using w-array. 227 | test-get-of-an-element-ex. 228 | exit. 229 | 230 | test-get-of-an-element-numeric. 231 | call "array:new" 232 | using w-array length of w-num-element TNUMERIC. 233 | move 12 to w-expected-num. 234 | initialize w-actual. 235 | call "array:append" using w-array 12. 236 | call "array:get" using w-array w-actual-num 0. 237 | 238 | call "assert" 239 | using EQ 240 | w-expected-num 241 | w-actual-num 242 | "it should be possible to read a numeric element". 243 | 244 | move 15 to w-bigger-num-element. 245 | call "array:append" using w-array w-bigger-num-element. 246 | call "array:get" using w-array w-actual-num 1. 247 | 248 | move w-bigger-num-element to w-expected-num. 249 | call "assert" 250 | using EQ 251 | w-expected-num 252 | w-actual-num 253 | "it should be possible to read a numeric element app 254 | - "ended from a bigger picture". 255 | test-get-of-an-element-numeric-ex. 256 | exit. 257 | 258 | test-insert. 259 | call "array:new" using w-array length of w-str-element. 260 | initialize w-expected-array-str-tbl. 261 | move "bla" to w-expected-array-str-arr(1). 262 | move "bla3" to w-expected-array-str-arr(2). 263 | move "bla2" to w-expected-array-str-arr(3). 264 | call "array:append" using w-array "bla". 265 | call "array:append" using w-array "bla2". 266 | call "array:insert" using w-array "bla3" 1. 267 | call "assert" 268 | using ARRAY-EQ 269 | w-expected-array-str-tbl 270 | w-array 271 | "after insert, array should contain a new element in 272 | - " the right position". 273 | move 3 to w-expected-array-length. 274 | call "assert" using EQ w-expected-array-length w-array-length 275 | "after inserting, array length should increment". 276 | 277 | call "array:insert" using w-array "bla4" 3. 278 | call "assert" 279 | using ARRAY-EQ 280 | w-expected-array-str-tbl 281 | w-array 282 | "after inserting in a position that is greater than 283 | - "current maximum index, it should stay invariate" 284 | move 3 to w-expected-array-length. 285 | call "assert" using EQ w-expected-array-length w-array-length 286 | "after inserting in a position that is greater than curren 287 | - "t maximum index, it should stay invariate also in length" 288 | . 289 | 290 | call "array:free" using w-array. 291 | test-insert-ex. 292 | exit. 293 | 294 | test-append-and-get-of-a-numeric-value. 295 | call "array:new" using w-array length of w-num-element. 296 | move 42 to w-num-element 297 | call "array:append" using w-array w-num-element. 298 | move 43 to w-expected-num 299 | call "array:append" using w-array w-expected-num. 300 | move 44 to w-num-element 301 | call "array:append" using w-array w-num-element. 302 | 303 | call "array:get" using w-array w-actual-num 1 304 | 305 | call "assert" 306 | using EQ 307 | w-expected-num 308 | w-actual-num 309 | "array works also with numbers". 310 | call "array:free" using w-array. 311 | test-append-and-get-of-a-numeric-value-ex. 312 | exit. 313 | 314 | test-sorting. 315 | call "array:new" using w-array length of i. 316 | move 10000 to w-max-elements. 317 | perform fill-the-array-with-random-numbers 318 | thru fill-the-array-with-random-numbers-ex. 319 | 320 | call "array:sort" using w-array 321 | initialize i. 322 | 323 | perform check-that-array-is-sorted 324 | thru check-that-array-is-sorted-ex 325 | 326 | call "assert" 327 | using EQ 328 | w-max-elements 329 | i 330 | "big array is sorted". 331 | 332 | call "array:free" using w-array. 333 | test-sorting-ex. 334 | exit. 335 | 336 | test-sorting-alphanumerics. 337 | call "array:new" using w-array length of w-str-element. 338 | move "aaaaaaaaaa" to w-expected-array-str-arr(1). 339 | move "bbbbbbbbbb" to w-expected-array-str-arr(2). 340 | move "cccccccccc" to w-expected-array-str-arr(3). 341 | move "dddddddddd" to w-expected-array-str-arr(4). 342 | move "eeeeeeeeee" to w-expected-array-str-arr(5). 343 | 344 | call "array:append" using w-array "bbbbbbbbbb". 345 | call "array:append" using w-array "aaaaaaaaaa". 346 | call "array:append" using w-array "eeeeeeeeee". 347 | call "array:append" using w-array "dddddddddd". 348 | call "array:append" using w-array "cccccccccc". 349 | call "array:sort" using w-array. 350 | 351 | call "assert" 352 | using ARRAY-EQ 353 | w-expected-array-str-tbl 354 | w-array 355 | "array of strings is sorted". 356 | 357 | call "array:free" using w-array. 358 | test-sorting-alphanumerics-ex. 359 | exit. 360 | 361 | test-sorting-numbers. 362 | call "array:new" 363 | using w-array length of w-num-element TNUMERIC. 364 | move 1 to w-expected-array-num-arr(1). 365 | move 1 to w-expected-array-num-arr(2). 366 | move 2 to w-expected-array-num-arr(3). 367 | move 3 to w-expected-array-num-arr(4). 368 | move 4 to w-expected-array-num-arr(5). 369 | move 5 to w-expected-array-num-arr(6). 370 | move 11 to w-expected-array-num-arr(7). 371 | 372 | call "array:append" using w-array 3. 373 | call "array:append" using w-array 2. 374 | call "array:append" using w-array 1. 375 | call "array:append" using w-array 4. 376 | call "array:append" using w-array 1. 377 | call "array:append" using w-array 11. 378 | call "array:append" using w-array 5. 379 | 380 | call "array:sort" using w-array. 381 | 382 | call "assert" 383 | using ARRAY-EQ 384 | w-expected-array-num-tbl 385 | w-array 386 | "array of numbers is sorted". 387 | 388 | call "array:free" using w-array. 389 | test-sorting-numbers-ex. 390 | exit. 391 | 392 | test-sorting-parts-of-data-structures. 393 | call "array:new" using w-array length of w-stt. 394 | move 1 to w-expected-array-stt-arr-9(1). 395 | move "z" to w-expected-array-stt-arr-x(1). 396 | move 2 to w-expected-array-stt-arr-9(2). 397 | move "v" to w-expected-array-stt-arr-x(2). 398 | move 3 to w-expected-array-stt-arr-9(3). 399 | move "u" to w-expected-array-stt-arr-x(3). 400 | move 4 to w-expected-array-stt-arr-9(4). 401 | move "t" to w-expected-array-stt-arr-x(4). 402 | move 5 to w-expected-array-stt-arr-9(5). 403 | move "s" to w-expected-array-stt-arr-x(5). 404 | move 11 to w-expected-array-stt-arr-9(6). 405 | move "r" to w-expected-array-stt-arr-x(6). 406 | 407 | call "array:append" 408 | using w-array w-expected-array-stt-arr(5). 409 | call "array:append" 410 | using w-array w-expected-array-stt-arr(3). 411 | call "array:append" 412 | using w-array w-expected-array-stt-arr(2). 413 | call "array:append" 414 | using w-array w-expected-array-stt-arr(4). 415 | call "array:append" 416 | using w-array w-expected-array-stt-arr(6). 417 | call "array:append" 418 | using w-array w-expected-array-stt-arr(1). 419 | 420 | call "array:sort" 421 | using w-array 422 | record-position of w-stt-9 423 | length of w-stt-9 424 | . 425 | 426 | call "assert" 427 | using ARRAY-EQ 428 | w-expected-array-stt-tbl 429 | w-array 430 | "array of data structure is sorted with rules on par 431 | - "t of the structure". 432 | 433 | call "array:free" using w-array. 434 | test-sorting-parts-of-data-structures-ex. 435 | exit. 436 | 437 | test-sorting-comparators. 438 | call "array:new" using w-array length of w-str-element. 439 | move "first" to w-expected-array-str-arr(1). 440 | move "second" to w-expected-array-str-arr(2). 441 | move "third" to w-expected-array-str-arr(3). 442 | move "apple" to w-expected-array-str-arr(4). 443 | move "banana" to w-expected-array-str-arr(5). 444 | 445 | call "array:append" 446 | using w-array w-expected-array-str-arr(2). 447 | call "array:append" 448 | using w-array w-expected-array-str-arr(5). 449 | call "array:append" 450 | using w-array w-expected-array-str-arr(3). 451 | call "array:append" 452 | using w-array w-expected-array-str-arr(1). 453 | call "array:append" 454 | using w-array w-expected-array-str-arr(4). 455 | 456 | call "array:sort" 457 | using w-array 458 | 0 459 | length of w-str-element 460 | "testcomparator" 461 | . 462 | 463 | call "assert" 464 | using ARRAY-EQ 465 | w-expected-array-str-tbl 466 | w-array 467 | "array is sorted with test comparator". 468 | 469 | call "array:free" using w-array. 470 | test-sorting-comparators-ex. 471 | exit. 472 | 473 | 474 | fill-the-array-with-random-numbers. 475 | perform w-max-elements times 476 | move function random() to i-d 477 | call "array:append" using w-array i 478 | end-perform. 479 | fill-the-array-with-random-numbers-ex. 480 | exit. 481 | 482 | 483 | check-that-array-is-sorted. 484 | perform varying i from 1 by 1 until i >= w-max-elements 485 | subtract 1 from i giving j 486 | call "array:get" using w-array w-num-element j 487 | call "array:get" using w-array w-num-element2 i 488 | 489 | if w-num-element > w-num-element2 490 | exit perform 491 | end-if 492 | end-perform. 493 | check-that-array-is-sorted-ex. 494 | exit. 495 | 496 | 497 | -------------------------------------------------------------------------------- /testcomparator.cbl: -------------------------------------------------------------------------------- 1 | identification division. 2 | program-id. testcomparator. 3 | author. Luca Piccinelli. 4 | date-written. 13.05.2020. 5 | environment division. 6 | configuration section. 7 | special-names. 8 | input-output section. 9 | file-control. 10 | data division. 11 | file section. 12 | working-storage section. 13 | copy "definitions.cpy" 14 | replacing ==!MAX-PARAMS-NUM== by ==3== 15 | . 16 | 77 w-first pic x(25). 17 | 77 w-second pic x(25). 18 | copy "array.cpy" replacing ==!PREFIX!== by ==w-==. 19 | 20 | 21 | linkage section. 22 | 77 l-first pic x(MAX-LINKAGE). 23 | 77 l-second pic x(MAX-LINKAGE). 24 | copy "array.cpy" replacing ==!PREFIX!== by ==l-==. 25 | 26 | procedure division using l-first l-second l-array. 27 | $CATCHPARAMS. 28 | copy "catchx.pdv" replacing 29 | ==!W== by ==first== 30 | ==!N== by ==1==. 31 | copy "catchx.pdv" replacing 32 | ==!W== by ==second== 33 | ==!N== by ==2==. 34 | copy "catchx.pdv" replacing 35 | ==!W== by ==array== 36 | ==!N== by ==3==. 37 | 38 | if w-first = w-second goback giving 0. 39 | 40 | if w-first = "first" goback giving -1. 41 | if w-first = "second" and w-second <> "first" 42 | goback giving -1 43 | end-if. 44 | 45 | if w-first = "third" 46 | and w-second <> "first" 47 | and w-second <> "second" 48 | goback giving -1 49 | end-if. 50 | 51 | if w-second = "first" goback giving 1. 52 | if w-second = "second" and w-first <> "first" 53 | goback giving 1 54 | end-if. 55 | 56 | if w-second = "third" 57 | and w-first <> "first" 58 | and w-first <> "second" 59 | goback giving 1 60 | end-if. 61 | 62 | if w-first < w-second goback giving -1. 63 | goback giving 1. 64 | --------------------------------------------------------------------------------