| 1 | \ Test PForth FILE wordset |
| 2 | |
| 3 | \ To test the ANS File Access word set and extension words |
| 4 | |
| 5 | \ This program was written by Gerry Jackson in 2006, with contributions from |
| 6 | \ others where indicated, and is in the public domain - it can be distributed |
| 7 | \ and/or modified in any way but please retain this notice. |
| 8 | |
| 9 | \ This program is distributed in the hope that it will be useful, |
| 10 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 11 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. |
| 12 | |
| 13 | \ The tests are not claimed to be comprehensive or correct |
| 14 | |
| 15 | \ ---------------------------------------------------------------------------- |
| 16 | \ Version 0.13 S" in interpretation mode tested. |
| 17 | \ Added SAVE-INPUT RESTORE-INPUT REFILL in a file, (moved from |
| 18 | \ coreexttest.fth). |
| 19 | \ Calls to COMPARE replaced with S= (in utilities.fth) |
| 20 | \ 0.11 25 April 2015 S\" in interpretation mode test added |
| 21 | \ REQUIRED REQUIRE INCLUDE tests added |
| 22 | \ Two S" and/or S\" buffers availability tested |
| 23 | \ 0.5 1 April 2012 Tests placed in the public domain. |
| 24 | \ 0.4 22 March 2009 { and } replaced with T{ and }T |
| 25 | \ 0.3 20 April 2007 ANS Forth words changed to upper case. |
| 26 | \ Removed directory test from the filenames. |
| 27 | \ 0.2 30 Oct 2006 updated following GForth tests to remove |
| 28 | \ system dependency on file size, to allow for file |
| 29 | \ buffering and to allow for PAD moving around. |
| 30 | \ 0.1 Oct 2006 First version released. |
| 31 | |
| 32 | \ ---------------------------------------------------------------------------- |
| 33 | \ The tests are based on John Hayes test program for the core word set |
| 34 | \ and requires those files to have been loaded |
| 35 | |
| 36 | \ Words tested in this file are: |
| 37 | \ ( BIN CLOSE-FILE CREATE-FILE DELETE-FILE FILE-POSITION FILE-SIZE |
| 38 | \ OPEN-FILE R/O R/W READ-FILE READ-LINE REPOSITION-FILE RESIZE-FILE |
| 39 | \ S" S\" SOURCE-ID W/O WRITE-FILE WRITE-LINE |
| 40 | \ FILE-STATUS FLUSH-FILE RENAME-FILE SAVE-INPUT RESTORE-INPUT |
| 41 | \ REFILL |
| 42 | |
| 43 | \ Words not tested: |
| 44 | \ INCLUDED INCLUDE-FILE (as these will likely have been |
| 45 | \ tested in the execution of the test files) |
| 46 | \ ---------------------------------------------------------------------------- |
| 47 | \ Assumptions, dependencies and notes: |
| 48 | \ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been |
| 49 | \ included prior to this file |
| 50 | \ - the Core word set is available and tested |
| 51 | \ - These tests create files in the current directory, if all goes |
| 52 | \ well these will be deleted. If something fails they may not be |
| 53 | \ deleted. If this is a problem ensure you set a suitable |
| 54 | \ directory before running this test. There is no ANS standard |
| 55 | \ way of doing this. Also be aware of the file names used below |
| 56 | \ which are: fatest1.txt, fatest2.txt and fatest3.txt |
| 57 | \ ---------------------------------------------------------------------------- |
| 58 | |
| 59 | include? }T{ t_tools.fth |
| 60 | |
| 61 | true fp-require-e ! |
| 62 | |
| 63 | false value verbose |
| 64 | |
| 65 | : testing |
| 66 | verbose IF |
| 67 | source >in @ /string ." TESTING: " type cr |
| 68 | THEN |
| 69 | source nip >in ! |
| 70 | ; immediate |
| 71 | |
| 72 | : -> }T{ ; |
| 73 | : s= compare 0= ; |
| 74 | : $" state IF postpone s" else ['] s" execute THEN ; immediate |
| 75 | |
| 76 | TESTING File Access word set |
| 77 | |
| 78 | DECIMAL |
| 79 | |
| 80 | TEST{ |
| 81 | |
| 82 | \ ---------------------------------------------------------------------------- |
| 83 | TESTING CREATE-FILE CLOSE-FILE |
| 84 | |
| 85 | : FN1 S" fatest1.txt" ; |
| 86 | VARIABLE FID1 |
| 87 | |
| 88 | T{ FN1 R/W CREATE-FILE SWAP FID1 ! -> 0 }T |
| 89 | T{ FID1 @ CLOSE-FILE -> 0 }T |
| 90 | |
| 91 | \ ---------------------------------------------------------------------------- |
| 92 | TESTING OPEN-FILE W/O WRITE-LINE |
| 93 | |
| 94 | : LINE1 S" Line 1" ; |
| 95 | |
| 96 | T{ FN1 W/O OPEN-FILE SWAP FID1 ! -> 0 }T |
| 97 | T{ LINE1 FID1 @ WRITE-LINE -> 0 }T |
| 98 | T{ FID1 @ CLOSE-FILE -> 0 }T |
| 99 | |
| 100 | \ ---------------------------------------------------------------------------- |
| 101 | TESTING R/O FILE-POSITION (simple) READ-LINE |
| 102 | |
| 103 | 200 CONSTANT BSIZE |
| 104 | CREATE BUF BSIZE ALLOT |
| 105 | VARIABLE #CHARS |
| 106 | |
| 107 | T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T |
| 108 | T{ FID1 @ FILE-POSITION -> 0. 0 }T |
| 109 | T{ BUF 100 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 SWAP DROP }T |
| 110 | T{ BUF #CHARS @ LINE1 S= -> TRUE }T |
| 111 | T{ FID1 @ CLOSE-FILE -> 0 }T |
| 112 | |
| 113 | \ Test with buffer shorter than line. |
| 114 | T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T |
| 115 | T{ FID1 @ FILE-POSITION -> 0. 0 }T |
| 116 | T{ BUF 0 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 0 }T |
| 117 | T{ BUF 3 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 3 }T |
| 118 | T{ BUF #CHARS @ LINE1 DROP 3 S= -> TRUE }T |
| 119 | T{ BUF 100 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 NIP 3 - }T |
| 120 | T{ BUF #CHARS @ LINE1 3 /STRING S= -> TRUE }T |
| 121 | T{ FID1 @ CLOSE-FILE -> 0 }T |
| 122 | |
| 123 | \ Test with buffer exactly as long as the line. |
| 124 | T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T |
| 125 | T{ FID1 @ FILE-POSITION -> 0. 0 }T |
| 126 | T{ BUF LINE1 NIP FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 NIP }T |
| 127 | T{ BUF #CHARS @ LINE1 S= -> TRUE }T |
| 128 | T{ FID1 @ CLOSE-FILE -> 0 }T |
| 129 | |
| 130 | \ ---------------------------------------------------------------------------- |
| 131 | TESTING S" in interpretation mode (compile mode tested in Core tests) |
| 132 | |
| 133 | T{ S" abcdef" $" abcdef" S= -> TRUE }T |
| 134 | T{ S" " $" " S= -> TRUE }T |
| 135 | T{ S" ghi"$" ghi" S= -> TRUE }T |
| 136 | |
| 137 | \ ---------------------------------------------------------------------------- |
| 138 | TESTING R/W WRITE-FILE REPOSITION-FILE READ-FILE FILE-POSITION S" |
| 139 | |
| 140 | : LINE2 S" Line 2 blah blah blah" ; |
| 141 | : RL1 BUF 100 FID1 @ READ-LINE ; |
| 142 | 2VARIABLE FP |
| 143 | |
| 144 | T{ FN1 R/W OPEN-FILE SWAP FID1 ! -> 0 }T |
| 145 | T{ FID1 @ FILE-SIZE DROP FID1 @ REPOSITION-FILE -> 0 }T |
| 146 | T{ FID1 @ FILE-SIZE -> FID1 @ FILE-POSITION }T |
| 147 | T{ LINE2 FID1 @ WRITE-FILE -> 0 }T |
| 148 | T{ 10. FID1 @ REPOSITION-FILE -> 0 }T |
| 149 | T{ FID1 @ FILE-POSITION -> 10. 0 }T |
| 150 | T{ 0. FID1 @ REPOSITION-FILE -> 0 }T |
| 151 | T{ RL1 -> LINE1 SWAP DROP TRUE 0 }T |
| 152 | T{ RL1 ROT DUP #CHARS ! -> TRUE 0 LINE2 SWAP DROP }T |
| 153 | T{ BUF #CHARS @ LINE2 S= -> TRUE }T |
| 154 | T{ RL1 -> 0 FALSE 0 }T |
| 155 | T{ FID1 @ FILE-POSITION ROT ROT FP 2! -> 0 }T |
| 156 | T{ FP 2@ FID1 @ FILE-SIZE DROP D= -> TRUE }T |
| 157 | T{ S" " FID1 @ WRITE-LINE -> 0 }T |
| 158 | T{ S" " FID1 @ WRITE-LINE -> 0 }T |
| 159 | T{ FP 2@ FID1 @ REPOSITION-FILE -> 0 }T |
| 160 | T{ RL1 -> 0 TRUE 0 }T |
| 161 | T{ RL1 -> 0 TRUE 0 }T |
| 162 | T{ RL1 -> 0 FALSE 0 }T |
| 163 | T{ FID1 @ CLOSE-FILE -> 0 }T |
| 164 | |
| 165 | \ ---------------------------------------------------------------------------- |
| 166 | TESTING BIN READ-FILE FILE-SIZE |
| 167 | |
| 168 | : CBUF BUF BSIZE 0 FILL ; |
| 169 | : FN2 S" FATEST2.TXT" ; |
| 170 | VARIABLE FID2 |
| 171 | : SETPAD PAD 50 0 DO I OVER C! CHAR+ LOOP DROP ; |
| 172 | |
| 173 | SETPAD \ If anything else is defined setpad must be called again |
| 174 | \ as pad may move |
| 175 | |
| 176 | T{ FN2 R/W BIN CREATE-FILE SWAP FID2 ! -> 0 }T |
| 177 | T{ PAD 50 FID2 @ WRITE-FILE FID2 @ FLUSH-FILE -> 0 0 }T |
| 178 | T{ FID2 @ FILE-SIZE -> 50. 0 }T |
| 179 | T{ 0. FID2 @ REPOSITION-FILE -> 0 }T |
| 180 | T{ CBUF BUF 29 FID2 @ READ-FILE -> 29 0 }T |
| 181 | T{ PAD 29 BUF 29 S= -> TRUE }T |
| 182 | T{ PAD 30 BUF 30 S= -> FALSE }T |
| 183 | T{ CBUF BUF 29 FID2 @ READ-FILE -> 21 0 }T |
| 184 | T{ PAD 29 + 21 BUF 21 S= -> TRUE }T |
| 185 | T{ FID2 @ FILE-SIZE DROP FID2 @ FILE-POSITION DROP D= -> TRUE }T |
| 186 | T{ BUF 10 FID2 @ READ-FILE -> 0 0 }T |
| 187 | T{ FID2 @ CLOSE-FILE -> 0 }T |
| 188 | |
| 189 | \ ---------------------------------------------------------------------------- |
| 190 | TESTING RESIZE-FILE |
| 191 | |
| 192 | T{ FN2 R/W BIN OPEN-FILE SWAP FID2 ! -> 0 }T |
| 193 | T{ 37. FID2 @ RESIZE-FILE -> 0 }T |
| 194 | T{ FID2 @ FILE-SIZE -> 37. 0 }T |
| 195 | T{ 0. FID2 @ REPOSITION-FILE -> 0 }T |
| 196 | T{ CBUF BUF 100 FID2 @ READ-FILE -> 37 0 }T |
| 197 | T{ PAD 37 BUF 37 S= -> TRUE }T |
| 198 | T{ PAD 38 BUF 38 S= -> FALSE }T |
| 199 | T{ 500. FID2 @ RESIZE-FILE -> 0 }T |
| 200 | T{ FID2 @ FILE-SIZE -> 500. 0 }T |
| 201 | T{ 0. FID2 @ REPOSITION-FILE -> 0 }T |
| 202 | T{ CBUF BUF 100 FID2 @ READ-FILE -> 100 0 }T |
| 203 | T{ PAD 37 BUF 37 S= -> TRUE }T |
| 204 | T{ FID2 @ CLOSE-FILE -> 0 }T |
| 205 | |
| 206 | \ ---------------------------------------------------------------------------- |
| 207 | TESTING DELETE-FILE |
| 208 | |
| 209 | T{ FN2 DELETE-FILE -> 0 }T |
| 210 | T{ FN2 R/W BIN OPEN-FILE SWAP DROP 0= -> FALSE }T |
| 211 | T{ FN2 DELETE-FILE 0= -> FALSE }T |
| 212 | |
| 213 | \ ---------------------------------------------------------------------------- |
| 214 | TESTING multi-line ( comments |
| 215 | |
| 216 | T{ ( 1 2 3 |
| 217 | 4 5 6 |
| 218 | 7 8 9 ) 11 22 33 -> 11 22 33 }T |
| 219 | |
| 220 | \ ---------------------------------------------------------------------------- |
| 221 | TESTING SOURCE-ID (can only test it does not return 0 or -1) |
| 222 | |
| 223 | T{ SOURCE-ID DUP -1 = SWAP 0= OR -> FALSE }T |
| 224 | |
| 225 | \ ---------------------------------------------------------------------------- |
| 226 | TESTING RENAME-FILE FILE-STATUS FLUSH-FILE |
| 227 | |
| 228 | : FN3 S" fatest3.txt" ; |
| 229 | : >END FID1 @ FILE-SIZE DROP FID1 @ REPOSITION-FILE ; |
| 230 | |
| 231 | |
| 232 | T{ FN3 DELETE-FILE DROP -> }T |
| 233 | T{ FN1 FN3 RENAME-FILE 0= -> TRUE }T |
| 234 | T{ FN1 FILE-STATUS SWAP DROP 0= -> FALSE }T |
| 235 | T{ FN3 FILE-STATUS SWAP DROP 0= -> TRUE }T \ Return value is undefined |
| 236 | T{ FN3 R/W OPEN-FILE SWAP FID1 ! -> 0 }T |
| 237 | T{ >END -> 0 }T |
| 238 | T{ S" Final line" fid1 @ WRITE-LINE -> 0 }T |
| 239 | |
| 240 | T{ FID1 @ FLUSH-FILE -> 0 }T \ Can only test FLUSH-FILE doesn't fail |
| 241 | T{ FID1 @ CLOSE-FILE -> 0 }T |
| 242 | |
| 243 | \ Tidy the test folder |
| 244 | T{ fn3 DELETE-FILE DROP -> }T |
| 245 | |
| 246 | \ ------------------------------------------------------------------------------ |
| 247 | TESTING REQUIRED REQUIRE INCLUDED |
| 248 | \ Tests taken from Forth 2012 RfD |
| 249 | |
| 250 | T{ 0 S" t_required_helper1.fth" REQUIRED |
| 251 | REQUIRE t_required_helper1.fth |
| 252 | INCLUDE t_required_helper1.fth |
| 253 | -> 2 }T |
| 254 | |
| 255 | T{ 0 INCLUDE t_required_helper2.fth |
| 256 | S" t_required_helper2.fth" REQUIRED |
| 257 | REQUIRE t_required_helper2.fth |
| 258 | S" t_required_helper2.fth" INCLUDED |
| 259 | -> 2 }T |
| 260 | |
| 261 | \ ---------------------------------------------------------------------------- |
| 262 | TESTING two buffers available for S" and/or S\" (Forth 2012) |
| 263 | |
| 264 | : SSQ12 S" abcd" ; : SSQ13 S" 1234" ; |
| 265 | T{ S" abcd" S" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T |
| 266 | \ nyi T{ S\" abcd" S\" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T |
| 267 | \ nyi T{ S" abcd" S\" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T |
| 268 | \ nyi T{ S\" abcd" S" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T |
| 269 | |
| 270 | |
| 271 | \ ----------------------------------------------------------------------------- |
| 272 | TESTING SAVE-INPUT and RESTORE-INPUT with a file source |
| 273 | |
| 274 | VARIABLE SIV -1 SIV ! |
| 275 | |
| 276 | : NEVEREXECUTED |
| 277 | CR ." This should never be executed" CR |
| 278 | ; |
| 279 | |
| 280 | T{ 11111 SAVE-INPUT |
| 281 | |
| 282 | SIV @ |
| 283 | |
| 284 | [IF] |
| 285 | TESTING the -[IF]- part is executed |
| 286 | 0 SIV ! |
| 287 | RESTORE-INPUT |
| 288 | NEVEREXECUTED |
| 289 | 33333 |
| 290 | [ELSE] |
| 291 | |
| 292 | TESTING the -[ELSE]- part is executed |
| 293 | 22222 |
| 294 | |
| 295 | [THEN] |
| 296 | |
| 297 | -> 11111 0 22222 }T \ 0 comes from RESTORE-INPUT |
| 298 | |
| 299 | TESTING nested SAVE-INPUT, RESTORE-INPUT and REFILL from a file |
| 300 | |
| 301 | : READ_A_LINE |
| 302 | REFILL 0= |
| 303 | ABORT" REFILL FAILED" |
| 304 | ; |
| 305 | |
| 306 | VARIABLE SI_INC 0 SI_INC ! |
| 307 | |
| 308 | : SI1 |
| 309 | SI_INC @ >IN +! |
| 310 | 15 SI_INC ! |
| 311 | ; |
| 312 | |
| 313 | : S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ; |
| 314 | |
| 315 | CREATE 2RES -1 , -1 , \ Don't use 2VARIABLE from Double number word set |
| 316 | |
| 317 | : SI2 |
| 318 | READ_A_LINE |
| 319 | READ_A_LINE |
| 320 | SAVE-INPUT |
| 321 | READ_A_LINE |
| 322 | READ_A_LINE |
| 323 | S$ EVALUATE 2RES 2! |
| 324 | RESTORE-INPUT |
| 325 | ; |
| 326 | |
| 327 | \ WARNING: do not delete or insert lines of text after si2 is called |
| 328 | \ otherwise the next test will fail |
| 329 | |
| 330 | T{ SI2 |
| 331 | 33333 \ This line should be ignored |
| 332 | 2RES 2@ 44444 \ RESTORE-INPUT should return to this line |
| 333 | |
| 334 | 55555 |
| 335 | TESTING the nested results |
| 336 | -> 0 0 2345 44444 55555 }T |
| 337 | |
| 338 | \ End of warning |
| 339 | |
| 340 | \ ---------------------------------------------------------------------------- |
| 341 | |
| 342 | \ CR .( End of File-Access word set tests) CR |
| 343 | |
| 344 | }TEST |