new feature "include"

this was the subject of a bunch of thought. in most languages, we'd argue against having a text-based "include" feature, because there should also be a module system, and textual include subverts the module system because you can't assume everyone will use it.

however, Evocation already very strongly encourages thinking of a program as a sequence of operations (this is after all the definition of a catenative language), and in particular the transformation system already relies very heavily on programs-as-text. so, it seems appropriate for Forth in general and for Evocation in particular.

plus it was easy to implement, because all the infrastructure for it already existed to support the transformation system

Force-Push: yes
Change-Id: I76f778e44b8189ac7052890c881654d971e43c8d

1 files changed, 161 insertions, 0 deletions

diff --git a/files.e b/files.e
new file mode 100644
index 0000000..5bafd9a
--- /dev/null
+++ b/files.e
@@ -0,0 +1,161 @@
+~ ~~~~~~~~~~~~~~~~~~~~~~~
+~ ~~ 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 } { interpret } while
+
+  main-input-buffer buffer-file-descriptor @ sys-close drop
+  ~ Ignore a failed close.
+
+  main-input-buffer pop-input-buffer 0 ;
+