evocation/files.e

~ ~~~~~~~~~~~~~~~~~~~~~~~
~ ~~ File manipulation ~~
~ ~~~~~~~~~~~~~~~~~~~~~~~
~
~   This file has high-level features for working with files and the
~ filesystem. There's a tension as to what belongs here vs. what belongs in
~ input.e or output.e, and it's likely there will be some refactoring as the
~ boundaries become clear.


~ (output point, filename -- output point)
: pack-file-contents
  dup 0 0 sys-open
  ~ (output point, filename, open result code or file descriptor)
  dup 0 > {
    ." Couldn't open " swap emitstring space
    ." because " space . ." ." newline
    2 ndrop exit
  } if

  ~ (output point, filename, file descriptor)
  {
    dup 3 pick 1024 sys-read
    ~ (output point, filename, file descriptor, read result code or length)

    dup 0 > {
      over sys-close drop
      ~ Ignore a failed close.

      ." Error while reading from " 3roll emitstring
      ." because " space . ." ." newline
      drop exit
    } if

    dup 0 = {
      over sys-close drop
      ~ Ignore a failed close.

      3 ndrop exit
    } if

    4 roll + 3unroll
  } forever ;


~ TODO probably make this more similar to pack-file-contents
~ (delimiter pointer, buffer size -- buffer address)
: read-to-buffer
  dup allocate dup dup
  ~ (buffer size, buffer address, word start, output point)
  { key
    ~ Exit if it's a zero byte.
    dup not {
      ~ Make sure to pack the zero to serve as a null terminator.
      pack8
      drop drop swap drop swap drop exit } if

    ~   If it's a space character, we need to check if we just consumed the
    ~ magic word, and do some handling to reset the word tracking.
    dup is-space
      { ~ (buffer size, buffer address, word start, output point, key)
        ~ Tuck the key out of the way until we've done some stuff.
        3unroll

        ~ Add a null terminator so we can use stringcmp
        dup 0 swap 8!

        ~ Check for the magic word.
        over 6 pick stringcmp 0 =
        { ~ It's magic, so exit.
          ~ Make sure to pack a zero to serve as a null terminator.
          0 pack8
          drop drop drop swap drop swap drop exit }
        { ~ It's not magic, so reset the word start. Of course whitespace is
          ~ not a word but this will help us keep track of things.
          3roll pack8
          swap drop dup } if-else }
      { ~ (buffer size, buffer address, word start, output point, key)
        ~ Tuck the key out of the way again.
        3unroll
        ~ Check if the word just started and the previous character is space.
        2dup = dup { drop dup @ is-space } if
          { ~ If so, this is the actual first character of the word.
            drop swap pack8 dup }
          { ~ If not, leave the word start alone.
            3roll pack8 } if-else } if-else } forever ;


~   In logical terms, this modifies an input buffer metadata structure
~ in-place to push a new, zeroed one into the start of the linked list formed
~ through the next-source field.
~
~   In physical terms, it works by allocating a new structure, copying the
~ fields of the existing one into it, and zeroing the existing one. That's
~ necessary because otherwise we'd need a mutable handle (a pointer to a
~ pointer) to update the start of the list, and there's no way to do that with
~ the main-input-buffer variable working the way it presently does.
~
~ (input buffer metadata pointer --)
: push-input-buffer
  allocate-input-buffer-metadata
  ~ (original metadata pointer, new metadata pointer)
  2dup 7 8 * memcopy
  ~ (original metadata pointer, new metadata pointer)
  swap dup zero-input-buffer-metadata
  input-buffer-next-source ! ;


~   This does the inverse of push-input-buffer. In the event that the
~ next-source field is null, it zeroes the buffer.
~
~   Note, however, that it doesn't deallocate the memory, because that's not
~ how memory allocation on the log works. If necessary, it can be deallocated
~ with "forget", though as usual that requires careful planning.
~
~ (input buffer metadata pointer --)
: pop-input-buffer
  dup input-buffer-next-source @
  ~ (original metadata pointer, next source metadata pointer)
  dup { swap 7 8 * memcopy }
      { drop zero-input-buffer-metadata } if-else ;


: default-buffer-size 1024 ;

~ (input buffer metadata pointer, file descriptor --)
: attach-input-buffer-to-file-descriptor
  over buffer-file-descriptor !
  ~ (metadata pointer)
  default-buffer-size allocate dup 2 pick buffer-physical-start !
  ~ (metadata pointer, buffer pointer)
  over buffer-logical-start !
  ~ (metadata pointer)
  default-buffer-size over buffer-physical-length !
  0 over buffer-logical-length !
  ' refill-input-buffer-from-stream entry-to-execution-token
  swap input-buffer-refill ! ;


~   Zero indicates success, nonzero indicates failure.
~
~ (filename -- *, success)
: include
  dup 0 0 sys-open
  dup 0 > {
    ." Couldn't open " swap emitstring space
    ." because " space . ." ." newline
    drop 1 exit
  } if
  ~ (file descriptor)

  main-input-buffer dup push-input-buffer
  swap attach-input-buffer-to-file-descriptor

  { peek -1 != } { interpret } while

  main-input-buffer buffer-file-descriptor @ sys-close drop
  ~ Ignore a failed close.

  main-input-buffer pop-input-buffer 0 ;