/fth/t_file.fth

https://github.com/philburk/pforth · Forth · 344 lines · 256 code · 77 blank · 11 comment · 7 complexity · c82484d64c3c903ab93f5b7362c2f35c MD5 · raw file

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