git.gag.com Git - debian/pforth/blob - fth/t_file.fth

   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 true 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
  77 \ FIXME: stubs for missing definition
  78 : flush-file drop -1 ;
  79 : resize-file drop 2drop -1 ;
  80 : rename-file 2drop 2drop -1 ;
  81 : file-status 2drop 0 -1 ;
  82
  83
  84 TESTING File Access word set
  85
  86 DECIMAL
  87
  88 TEST{
  89
  90 \ ----------------------------------------------------------------------------
  91 TESTING CREATE-FILE CLOSE-FILE
  92
  93 : FN1 S" fatest1.txt" ;
  94 VARIABLE FID1
  95
  96 T{ FN1 R/W CREATE-FILE SWAP FID1 ! -> 0 }T
  97 T{ FID1 @ CLOSE-FILE -> 0 }T
  98
  99 \ ----------------------------------------------------------------------------
 100 TESTING OPEN-FILE W/O WRITE-LINE
 101
 102 : LINE1 S" Line 1" ;
 103
 104 T{ FN1 W/O OPEN-FILE SWAP FID1 ! -> 0 }T
 105 T{ LINE1 FID1 @ WRITE-LINE -> 0 }T
 106 T{ FID1 @ CLOSE-FILE -> 0 }T
 107
 108 \ ----------------------------------------------------------------------------
 109 TESTING R/O FILE-POSITION (simple)  READ-LINE
 110
 111 200 CONSTANT BSIZE
 112 CREATE BUF BSIZE ALLOT
 113 VARIABLE #CHARS
 114
 115 T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T
 116 T{ FID1 @ FILE-POSITION -> 0. 0 }T
 117 T{ BUF 100 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 SWAP DROP }T
 118 T{ BUF #CHARS @ LINE1 S= -> TRUE }T
 119 T{ FID1 @ CLOSE-FILE -> 0 }T
 120
 121 \ Test with buffer shorter than line.
 122 T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T
 123 T{ FID1 @ FILE-POSITION -> 0. 0 }T
 124 T{ BUF 0 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 0 }T
 125 T{ BUF 3 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 3 }T
 126 T{ BUF #CHARS @ LINE1 DROP 3 S= -> TRUE }T
 127 T{ BUF 100 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 NIP 3 - }T
 128 T{ BUF #CHARS @ LINE1 3 /STRING S= -> TRUE }T
 129 T{ FID1 @ CLOSE-FILE -> 0 }T
 130
 131 \ Test with buffer exactly as long as the line.
 132 T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T
 133 T{ FID1 @ FILE-POSITION -> 0. 0 }T
 134 T{ BUF LINE1 NIP FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 NIP }T
 135 T{ BUF #CHARS @ LINE1 S= -> TRUE }T
 136 T{ FID1 @ CLOSE-FILE -> 0 }T
 137
 138 \ ----------------------------------------------------------------------------
 139 TESTING S" in interpretation mode (compile mode tested in Core tests)
 140
 141 T{ S" abcdef" $" abcdef" S= -> TRUE }T
 142 T{ S" " $" " S= -> TRUE }T
 143 T{ S" ghi"$" ghi" S= -> TRUE }T
 144
 145 \ ----------------------------------------------------------------------------
 146 TESTING R/W WRITE-FILE REPOSITION-FILE READ-FILE FILE-POSITION S"
 147
 148 : LINE2 S" Line 2 blah blah blah" ;
 149 : RL1 BUF 100 FID1 @ READ-LINE ;
 150 2VARIABLE FP
 151
 152 T{ FN1 R/W OPEN-FILE SWAP FID1 ! -> 0 }T
 153 T{ FID1 @ FILE-SIZE DROP FID1 @ REPOSITION-FILE -> 0 }T
 154 T{ FID1 @ FILE-SIZE -> FID1 @ FILE-POSITION }T
 155 T{ LINE2 FID1 @ WRITE-FILE -> 0 }T
 156 T{ 10. FID1 @ REPOSITION-FILE -> 0 }T
 157 T{ FID1 @ FILE-POSITION -> 10. 0 }T
 158 T{ 0. FID1 @ REPOSITION-FILE -> 0 }T
 159 T{ RL1 -> LINE1 SWAP DROP TRUE 0 }T
 160 T{ RL1 ROT DUP #CHARS ! -> TRUE 0 LINE2 SWAP DROP }T
 161 T{ BUF #CHARS @ LINE2 S= -> TRUE }T
 162 T{ RL1 -> 0 FALSE 0 }T
 163 T{ FID1 @ FILE-POSITION ROT ROT FP 2! -> 0 }T
 164 T{ FP 2@ FID1 @ FILE-SIZE DROP D= -> TRUE }T
 165 T{ S" " FID1 @ WRITE-LINE -> 0 }T
 166 T{ S" " FID1 @ WRITE-LINE -> 0 }T
 167 T{ FP 2@ FID1 @ REPOSITION-FILE -> 0 }T
 168 T{ RL1 -> 0 TRUE 0 }T
 169 T{ RL1 -> 0 TRUE 0 }T
 170 T{ RL1 -> 0 FALSE 0 }T
 171 T{ FID1 @ CLOSE-FILE -> 0 }T
 172
 173 \ ----------------------------------------------------------------------------
 174 TESTING BIN READ-FILE FILE-SIZE
 175
 176 : CBUF BUF BSIZE 0 FILL ;
 177 : FN2 S" FATEST2.TXT" ;
 178 VARIABLE FID2
 179 : SETPAD PAD 50 0 DO I OVER C! CHAR+ LOOP DROP ;
 180
 181 SETPAD   \ If anything else is defined setpad must be called again
 182          \ as pad may move
 183
 184 T{ FN2 R/W BIN CREATE-FILE SWAP FID2 ! -> 0 }T
 185 T{ PAD 50 FID2 @ WRITE-FILE FID2 @ FLUSH-FILE -> 0 0 }T
 186 T{ FID2 @ FILE-SIZE -> 50. 0 }T
 187 T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
 188 T{ CBUF BUF 29 FID2 @ READ-FILE -> 29 0 }T
 189 T{ PAD 29 BUF 29 S= -> TRUE }T
 190 T{ PAD 30 BUF 30 S= -> FALSE }T
 191 T{ CBUF BUF 29 FID2 @ READ-FILE -> 21 0 }T
 192 T{ PAD 29 + 21 BUF 21 S= -> TRUE }T
 193 T{ FID2 @ FILE-SIZE DROP FID2 @ FILE-POSITION DROP D= -> TRUE }T
 194 T{ BUF 10 FID2 @ READ-FILE -> 0 0 }T
 195 T{ FID2 @ CLOSE-FILE -> 0 }T
 196
 197 \ ----------------------------------------------------------------------------
 198 TESTING RESIZE-FILE
 199
 200 T{ FN2 R/W BIN OPEN-FILE SWAP FID2 ! -> 0 }T
 201 T{ 37. FID2 @ RESIZE-FILE -> 0 }T
 202 T{ FID2 @ FILE-SIZE -> 37. 0 }T
 203 T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
 204 T{ CBUF BUF 100 FID2 @ READ-FILE -> 37 0 }T
 205 T{ PAD 37 BUF 37 S= -> TRUE }T
 206 T{ PAD 38 BUF 38 S= -> FALSE }T
 207 T{ 500. FID2 @ RESIZE-FILE -> 0 }T
 208 T{ FID2 @ FILE-SIZE -> 500. 0 }T
 209 T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
 210 T{ CBUF BUF 100 FID2 @ READ-FILE -> 100 0 }T
 211 T{ PAD 37 BUF 37 S= -> TRUE }T
 212 T{ FID2 @ CLOSE-FILE -> 0 }T
 213
 214 \ ----------------------------------------------------------------------------
 215 TESTING DELETE-FILE
 216
 217 T{ FN2 DELETE-FILE -> 0 }T
 218 T{ FN2 R/W BIN OPEN-FILE SWAP DROP 0= -> FALSE }T
 219 T{ FN2 DELETE-FILE 0= -> FALSE }T
 220
 221 \ ----------------------------------------------------------------------------
 222 \ TESTING multi-line ( comments
 223 \
 224 \ T{ ( 1 2 3
 225 \ 4 5 6
 226 \ 7 8 9 ) 11 22 33 -> 11 22 33 }T
 227 \
 228 \ ----------------------------------------------------------------------------
 229 TESTING SOURCE-ID (can only test it does not return 0 or -1)
 230
 231 T{ SOURCE-ID DUP -1 = SWAP 0= OR -> FALSE }T
 232
 233 \ ----------------------------------------------------------------------------
 234 TESTING RENAME-FILE FILE-STATUS FLUSH-FILE
 235
 236 : FN3 S" fatest3.txt" ;
 237 : >END FID1 @ FILE-SIZE .s DROP FID1 @ REPOSITION-FILE ;
 238
 239
 240 T{ FN3 DELETE-FILE DROP -> }T
 241 T{ FN1 FN3 RENAME-FILE 0= -> TRUE }T
 242 T{ FN1 FILE-STATUS SWAP DROP 0= -> FALSE }T
 243 T{ FN3 FILE-STATUS SWAP DROP 0= -> TRUE }T  \ Return value is undefined
 244 T{ FN3 R/W OPEN-FILE SWAP FID1 ! -> 0 }T
 245 \ nyi T{ >END -> 0 }T
 246 \ nyi T{ S" Final line" fid1 @ WRITE-LINE -> 0 }T
 247
 248 \ nyi T{ FID1 @ FLUSH-FILE -> 0 }T      \ Can only test FLUSH-FILE doesn't fail
 249 \ nyi T{ FID1 @ CLOSE-FILE -> 0 }T
 250
 251 \ Tidy the test folder
 252 T{ fn3 DELETE-FILE DROP -> }T
 253
 254 \ ----------------------------------------------------------------------------
 255 TESTING two buffers available for S" and/or S\" (Forth 2012)
 256
 257 : SSQ12 S" abcd" ;   : SSQ13 S" 1234" ;
 258 T{ S" abcd"  S" 1234" SSQ13  S= ROT ROT SSQ12 S= -> TRUE TRUE }T
 259 \ nyi T{ S\" abcd" S\" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T
 260 \ nyi T{ S" abcd"  S\" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T
 261 \ nyi T{ S\" abcd" S" 1234" SSQ13  S= ROT ROT SSQ12 S= -> TRUE TRUE }T
 262
 263
 264 \ -----------------------------------------------------------------------------
 265 TESTING SAVE-INPUT and RESTORE-INPUT with a file source
 266
 267 VARIABLE SIV -1 SIV !
 268
 269 : NEVEREXECUTED
 270    CR ." This should never be executed" CR
 271 ;
 272
 273 T{ 11111 SAVE-INPUT
 274
 275 SIV @
 276
 277 [IF]
 278    TESTING the -[IF]- part is executed
 279    0 SIV !
 280    RESTORE-INPUT
 281    NEVEREXECUTED
 282    33333
 283 [ELSE]
 284
 285   TESTING the -[ELSE]- part is executed
 286   22222
 287
 288 [THEN]
 289
 290    -> 11111 0 22222 }T   \ 0 comes from RESTORE-INPUT
 291
 292 TESTING nested SAVE-INPUT, RESTORE-INPUT and REFILL from a file
 293
 294 : READ_A_LINE
 295    REFILL 0=
 296    ABORT" REFILL FAILED"
 297 ;
 298
 299 VARIABLE SI_INC 0 SI_INC !
 300
 301 : SI1
 302    SI_INC @ >IN +!
 303    15 SI_INC !
 304 ;
 305
 306 : S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ;
 307
 308 CREATE 2RES -1 , -1 ,   \ Don't use 2VARIABLE from Double number word set
 309
 310 : SI2
 311    READ_A_LINE
 312    READ_A_LINE
 313    SAVE-INPUT
 314    READ_A_LINE
 315    READ_A_LINE
 316    S$ EVALUATE 2RES 2!
 317    RESTORE-INPUT
 318 ;
 319
 320 \ WARNING: do not delete or insert lines of text after si2 is called
 321 \ otherwise the next test will fail
 322
 323 T{ SI2
 324 33333               \ This line should be ignored
 325 2RES 2@ 44444      \ RESTORE-INPUT should return to this line
 326
 327 55555
 328 TESTING the nested results
 329  -> 0 0 2345 44444 55555 }T
 330
 331 \ End of warning
 332
 333 \ ----------------------------------------------------------------------------
 334
 335 \ CR .( End of File-Access word set tests) CR
 336
 337 }TEST