/fth/file.fth

https://github.com/philburk/pforth · Forth · 163 lines · 139 code · 16 blank · 8 comment · 5 complexity · 90976971b608be2ba25de448b8180d39 MD5 · raw file

  1. \ READ-LINE and WRITE-LINE
  2. \
  3. \ This code is part of pForth.
  4. \
  5. \ Permission to use, copy, modify, and/or distribute this
  6. \ software for any purpose with or without fee is hereby granted.
  7. \
  8. \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  9. \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  10. \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  11. \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  12. \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  13. \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  14. \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  15. \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  16. private{
  17. 10 constant \N
  18. 13 constant \R
  19. \ Unread one char from file FILEID.
  20. : UNREAD { fileid -- ior }
  21. fileid file-position ( ud ior )
  22. ?dup
  23. IF nip nip \ IO error
  24. ELSE 1 s>d d- fileid reposition-file
  25. THEN
  26. ;
  27. \ Read the next available char from file FILEID and if it is a \n then
  28. \ skip it; otherwise unread it. IOR is non-zero if an error occured.
  29. \ C-ADDR is a buffer that can hold at least one char.
  30. : SKIP-\N { c-addr fileid -- ior }
  31. c-addr 1 fileid read-file ( u ior )
  32. ?dup
  33. IF \ Read error?
  34. nip
  35. ELSE ( u )
  36. 0=
  37. IF \ End of file?
  38. 0
  39. ELSE
  40. c-addr c@ \n = ( is-it-a-\n? )
  41. IF 0
  42. ELSE fileid unread
  43. THEN
  44. THEN
  45. THEN
  46. ;
  47. \ This is just s\" \n" but s\" isn't yet available.
  48. create (LINE-TERMINATOR) \n c,
  49. : LINE-TERMINATOR ( -- c-addr u ) (line-terminator) 1 ;
  50. \ Standard throw code
  51. \ See: http://lars.nocrew.org/forth2012/exception.html#table:throw
  52. -72 constant THROW_RENAME_FILE
  53. \ Copy the string C-ADDR/U1 to C-ADDR2 and append a NUL.
  54. : PLACE-CSTR ( c-addr1 u1 c-addr2 -- )
  55. 2dup 2>r ( c-addr1 u1 c-addr2 ) ( r: u1 c-addr2 )
  56. swap cmove ( ) ( r: u1 c-addr2 )
  57. 0 2r> + c! ( )
  58. ;
  59. : MULTI-LINE-COMMENT ( "comment<rparen>" -- )
  60. BEGIN
  61. >in @ ')' parse ( >in c-addr len )
  62. nip + >in @ = ( delimiter-not-found? )
  63. WHILE ( )
  64. refill 0= IF EXIT THEN ( )
  65. REPEAT
  66. ;
  67. }private
  68. \ This treats \n, \r\n, and \r as line terminator. Reading is done
  69. \ one char at a time with READ-FILE hence READ-FILE should probably do
  70. \ some form of buffering for good efficiency.
  71. : READ-LINE ( c-addr u1 fileid -- u2 flag ior )
  72. { a u f }
  73. u 0 ?DO
  74. a i chars + 1 f read-file ( u ior' )
  75. ?dup IF nip i false rot UNLOOP EXIT THEN \ Read error? ( u )
  76. 0= IF i i 0<> 0 UNLOOP EXIT THEN \ End of file? ( )
  77. a i chars + c@
  78. CASE
  79. \n OF i true 0 UNLOOP EXIT ENDOF
  80. \r OF
  81. \ Detect \r\n
  82. a i chars + f skip-\n ( ior )
  83. ?dup IF i false rot UNLOOP EXIT THEN \ IO Error? ( )
  84. i true 0 UNLOOP EXIT
  85. ENDOF
  86. ENDCASE
  87. LOOP
  88. \ Line doesn't fit in buffer
  89. u true 0
  90. ;
  91. : WRITE-LINE ( c-addr u fileid -- ior )
  92. { f }
  93. f write-file ( ior )
  94. ?dup
  95. IF \ IO error
  96. ELSE line-terminator f write-file
  97. THEN
  98. ;
  99. : RENAME-FILE ( c-addr1 u1 c-addr2 u2 -- ior )
  100. { a1 u1 a2 u2 | new }
  101. \ Convert the file-names to C-strings by copying them after HERE.
  102. a1 u1 here place-cstr
  103. here u1 1+ chars + to new
  104. a2 u2 new place-cstr
  105. here new (rename-file) 0=
  106. IF 0
  107. ELSE throw_rename_file
  108. THEN
  109. ;
  110. \ A limit used to perform a sanity check on the size argument for
  111. \ RESIZE-FILE.
  112. 2variable RESIZE-FILE-LIMIT
  113. 10000000 0 resize-file-limit 2! \ 10MB is somewhat arbitrarily chosen
  114. : RESIZE-FILE ( ud fileid -- ior )
  115. -rot 2dup resize-file-limit 2@ d> ( fileid ud big? )
  116. IF
  117. ." Argument (" 0 d.r ." ) is larger then RESIZE-FILE-LIMIT." cr
  118. ." (You can increase RESIZE-FILE-LIMIT with 2!)" cr
  119. abort
  120. ELSE
  121. rot (resize-file)
  122. THEN
  123. ;
  124. : ( ( "comment<rparen>" -- )
  125. source-id
  126. CASE
  127. -1 OF postpone ( ENDOF
  128. 0 OF postpone ( ENDOF
  129. \ for input from files
  130. multi-line-comment
  131. ENDCASE
  132. ; immediate
  133. \ We basically try to open the file in read-only mode. That seems to
  134. \ be the best that we can do with ANSI C. If we ever want to do
  135. \ something more sophisticated, like calling access(2), we must create
  136. \ a proper primitive. (OTOH, portable programs can't assume much
  137. \ about FILE-STATUS and non-portable programs could create a custom
  138. \ function for access(2).)
  139. : FILE-STATUS ( c-addr u -- 0 ior )
  140. r/o bin open-file ( fileid ior1 )
  141. ?dup
  142. IF nip 0 swap ( 0 ior1 )
  143. ELSE close-file 0 swap ( 0 ior2 )
  144. THEN
  145. ;
  146. privatize