/anstests/filetest.fth

https://github.com/jamesbowman/swapforth · Forth · 232 lines · 175 code · 47 blank · 10 comment · 6 complexity · 2b6cd47511304ee5409d7ff5e45aca78 MD5 · raw file

  1. \ To test the ANS File Access word set and extension words
  2. \ This program was written by Gerry Jackson in 2006, with contributions from
  3. \ others where indicated, and is in the public domain - it can be distributed
  4. \ and/or modified in any way but please retain this notice.
  5. \ This program is distributed in the hope that it will be useful,
  6. \ but WITHOUT ANY WARRANTY; without even the implied warranty of
  7. \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  8. \ The tests are not claimed to be comprehensive or correct
  9. \ ------------------------------------------------------------------------------
  10. \ Version 0.11 25 April 2015 S\" in interpretation mode test added
  11. \ REQUIRED REQUIRE INCLUDE tests added
  12. \ Two S" and/or S\" buffers availability tested
  13. \ 0.5 1 April 2012 Tests placed in the public domain.
  14. \ 0.4 22 March 2009 { and } replaced with T{ and }T
  15. \ 0.3 20 April 2007 ANS Forth words changed to upper case.
  16. \ Removed directory test from the filenames.
  17. \ 0.2 30 Oct 2006 updated following GForth tests to remove
  18. \ system dependency on file size, to allow for file
  19. \ buffering and to allow for PAD moving around.
  20. \ 0.1 Oct 2006 First version released.
  21. \ ------------------------------------------------------------------------------
  22. \ The tests are based on John Hayes test program for the core word set
  23. \ and requires those files to have been loaded
  24. \ Words tested in this file are:
  25. \ ( BIN CLOSE-FILE CREATE-FILE DELETE-FILE FILE-POSITION FILE-SIZE
  26. \ OPEN-FILE R/O R/W READ-FILE READ-LINE REPOSITION-FILE RESIZE-FILE
  27. \ S" SOURCE-ID W/O WRITE-FILE WRITE-LINE
  28. \ FILE-STATUS FLUSH-FILE RENAME-FILE
  29. \ Words not tested:
  30. \ REFILL INCLUDED INCLUDE-FILE (as these will likely have been
  31. \ tested in the execution of the test files)
  32. \ ------------------------------------------------------------------------------
  33. \ Assumptions, dependencies and notes:
  34. \ - tester.fr or ttester.fs has been loaded prior to this file
  35. \ - These tests create files in the current directory, if all goes
  36. \ well these will be deleted. If something fails they may not be
  37. \ deleted. If this is a problem ensure you set a suitable
  38. \ directory before running this test. There is no ANS standard
  39. \ way of doing this. Also be aware of the file names used below
  40. \ which are: fatest1.txt, fatest2.txt and fatest3.txt
  41. \ - TRUE and FALSE are present from the Core extension word set
  42. \ ------------------------------------------------------------------------------
  43. TESTING File Access word set
  44. DECIMAL
  45. \ ------------------------------------------------------------------------------
  46. TESTING CREATE-FILE CLOSE-FILE
  47. : FN1 S" fatest1.txt" ;
  48. VARIABLE FID1
  49. T{ FN1 R/W CREATE-FILE SWAP FID1 ! -> 0 }T
  50. T{ FID1 @ CLOSE-FILE -> 0 }T
  51. \ ------------------------------------------------------------------------------
  52. TESTING OPEN-FILE W/O WRITE-LINE
  53. : LINE1 S" Line 1" ;
  54. T{ FN1 W/O OPEN-FILE SWAP FID1 ! -> 0 }T
  55. T{ LINE1 FID1 @ WRITE-LINE -> 0 }T
  56. T{ FID1 @ CLOSE-FILE -> 0 }T
  57. \ ------------------------------------------------------------------------------
  58. TESTING R/O FILE-POSITION (simple) READ-LINE
  59. 200 CONSTANT BSIZE
  60. CREATE BUF BSIZE ALLOT
  61. VARIABLE #CHARS
  62. T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T
  63. T{ FID1 @ FILE-POSITION -> 0. 0 }T
  64. T{ BUF 100 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 SWAP DROP }T
  65. T{ BUF #CHARS @ LINE1 COMPARE -> 0 }T
  66. T{ FID1 @ CLOSE-FILE -> 0 }T
  67. \ ------------------------------------------------------------------------------
  68. TESTING R/W WRITE-FILE REPOSITION-FILE READ-FILE FILE-POSITION S"
  69. : LINE2 S" Line 2 blah blah blah" ;
  70. : RL1 BUF 100 FID1 @ READ-LINE ;
  71. 2VARIABLE FP
  72. T{ FN1 R/W OPEN-FILE SWAP FID1 ! -> 0 }T
  73. T{ FID1 @ FILE-SIZE DROP FID1 @ REPOSITION-FILE -> 0 }T
  74. T{ FID1 @ FILE-SIZE -> FID1 @ FILE-POSITION }T
  75. T{ LINE2 FID1 @ WRITE-FILE -> 0 }T
  76. T{ 10. FID1 @ REPOSITION-FILE -> 0 }T
  77. T{ FID1 @ FILE-POSITION -> 10. 0 }T
  78. T{ 0. FID1 @ REPOSITION-FILE -> 0 }T
  79. T{ RL1 -> LINE1 SWAP DROP TRUE 0 }T
  80. T{ RL1 ROT DUP #CHARS ! -> TRUE 0 LINE2 SWAP DROP }T
  81. T{ BUF #CHARS @ LINE2 COMPARE -> 0 }T
  82. T{ RL1 -> 0 FALSE 0 }T
  83. T{ FID1 @ FILE-POSITION ROT ROT FP 2! -> 0 }T
  84. T{ FP 2@ FID1 @ FILE-SIZE DROP D= -> TRUE }T
  85. T{ S" " FID1 @ WRITE-LINE -> 0 }T
  86. T{ S" " FID1 @ WRITE-LINE -> 0 }T
  87. T{ FP 2@ FID1 @ REPOSITION-FILE -> 0 }T
  88. T{ RL1 -> 0 TRUE 0 }T
  89. T{ RL1 -> 0 TRUE 0 }T
  90. T{ RL1 -> 0 FALSE 0 }T
  91. T{ FID1 @ CLOSE-FILE -> 0 }T
  92. \ ------------------------------------------------------------------------------
  93. TESTING BIN READ-FILE FILE-SIZE
  94. : CBUF BUF BSIZE 0 FILL ;
  95. : FN2 S" FATEST2.TXT" ;
  96. VARIABLE FID2
  97. : SETPAD PAD 50 0 DO I OVER C! CHAR+ LOOP DROP ;
  98. SETPAD \ If anything else is defined setpad must be called again
  99. \ as pad may move
  100. T{ FN2 R/W BIN CREATE-FILE SWAP FID2 ! -> 0 }T
  101. T{ PAD 50 FID2 @ WRITE-FILE FID2 @ FLUSH-FILE -> 0 0 }T
  102. T{ FID2 @ FILE-SIZE -> 50. 0 }T
  103. T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
  104. T{ CBUF BUF 29 FID2 @ READ-FILE -> 29 0 }T
  105. T{ PAD 29 BUF 29 COMPARE -> 0 }T
  106. T{ PAD 30 BUF 30 COMPARE -> 1 }T
  107. T{ CBUF BUF 29 FID2 @ READ-FILE -> 21 0 }T
  108. T{ PAD 29 + 21 BUF 21 COMPARE -> 0 }T
  109. T{ FID2 @ FILE-SIZE DROP FID2 @ FILE-POSITION DROP D= -> TRUE }T
  110. T{ BUF 10 FID2 @ READ-FILE -> 0 0 }T
  111. T{ FID2 @ CLOSE-FILE -> 0 }T
  112. \ ------------------------------------------------------------------------------
  113. TESTING RESIZE-FILE
  114. T{ FN2 R/W BIN OPEN-FILE SWAP FID2 ! -> 0 }T
  115. T{ 37. FID2 @ RESIZE-FILE -> 0 }T
  116. T{ FID2 @ FILE-SIZE -> 37. 0 }T
  117. T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
  118. T{ CBUF BUF 100 FID2 @ READ-FILE -> 37 0 }T
  119. T{ PAD 37 BUF 37 COMPARE -> 0 }T
  120. T{ PAD 38 BUF 38 COMPARE -> 1 }T
  121. T{ 500. FID2 @ RESIZE-FILE -> 0 }T
  122. T{ FID2 @ FILE-SIZE -> 500. 0 }T
  123. T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
  124. T{ CBUF BUF 100 FID2 @ READ-FILE -> 100 0 }T
  125. T{ PAD 37 BUF 37 COMPARE -> 0 }T
  126. T{ FID2 @ CLOSE-FILE -> 0 }T
  127. \ ------------------------------------------------------------------------------
  128. TESTING DELETE-FILE
  129. T{ FN2 DELETE-FILE -> 0 }T
  130. T{ FN2 R/W BIN OPEN-FILE SWAP DROP 0= -> FALSE }T
  131. T{ FN2 DELETE-FILE 0= -> FALSE }T
  132. \ ------------------------------------------------------------------------------
  133. TESTING multi-line ( comments
  134. T{ ( 1 2 3
  135. 4 5 6
  136. 7 8 9 ) 11 22 33 -> 11 22 33 }T
  137. \ ------------------------------------------------------------------------------
  138. TESTING SOURCE-ID (can only test it does not return 0 or -1)
  139. T{ SOURCE-ID DUP -1 = SWAP 0= OR -> FALSE }T
  140. \ ------------------------------------------------------------------------------
  141. TESTING RENAME-FILE FILE-STATUS FLUSH-FILE
  142. : FN3 S" fatest3.txt" ;
  143. : >END FID1 @ FILE-SIZE DROP FID1 @ REPOSITION-FILE ;
  144. T{ FN3 DELETE-FILE DROP -> }T
  145. T{ FN1 FN3 RENAME-FILE 0= -> TRUE }T
  146. T{ FN1 FILE-STATUS SWAP DROP 0= -> FALSE }T
  147. T{ FN3 FILE-STATUS SWAP DROP 0= -> TRUE }T \ Return value is undefined
  148. T{ FN3 R/W OPEN-FILE SWAP FID1 ! -> 0 }T
  149. T{ >END -> 0 }T
  150. T{ S" Final line" fid1 @ WRITE-LINE -> 0 }T
  151. T{ FID1 @ FLUSH-FILE -> 0 }T \ Can only test FLUSH-FILE doesn't fail
  152. T{ FID1 @ CLOSE-FILE -> 0 }T
  153. \ Tidy the test folder
  154. T{ fn3 DELETE-FILE DROP -> }T
  155. \ ------------------------------------------------------------------------------
  156. TESTING REQUIRED REQUIRE INCLUDED
  157. \ Tests taken from Forth 2012 RfD
  158. T{ 0
  159. S" required-helper1.fth" REQUIRED
  160. REQUIRE required-helper1.fth
  161. INCLUDE required-helper1.fth
  162. -> 2 }T
  163. T{ 0
  164. INCLUDE required-helper2.fth
  165. S" required-helper2.fth" REQUIRED
  166. REQUIRE required-helper2.fth
  167. S" required-helper2.fth" INCLUDED
  168. -> 2 }T
  169. \ ------------------------------------------------------------------------------
  170. TESTING S\" (Forth 2012 interpretation mode)
  171. \ S\" in compilation mode already tested in Core Extension tests
  172. T{ : SSQ10 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T
  173. T{ S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" SSQ10 COMPARE -> 0 }T
  174. \ ------------------------------------------------------------------------------
  175. TESTING two buffers available for S" and/or S\"
  176. : SSQ11 S" abcd" ; : SSQ12 S" 1234" ;
  177. T{ S" abcd" S" 1234" SSQ12 COMPARE ROT ROT SSQ11 COMPARE -> 0 0 }T
  178. T{ S\" abcd" S\" 1234" SSQ12 COMPARE ROT ROT SSQ11 COMPARE -> 0 0 }T
  179. T{ S" abcd" S\" 1234" SSQ12 COMPARE ROT ROT SSQ11 COMPARE -> 0 0 }T
  180. T{ S\" abcd" S" 1234" SSQ12 COMPARE ROT ROT SSQ11 COMPARE -> 0 0 }T
  181. \ ------------------------------------------------------------------------------
  182. FILE-ERRORS SET-ERROR-COUNT
  183. CR .( End of File-Access word set tests) CR