From: Phil Burk <philburk@mobileer.com>
Date: Mon, 16 Jan 2017 04:28:45 +0000 (-0800)
Subject: Merge pull request #36 from ellerh/resize-file-limit
X-Git-Url: http://git.subgeniuskitty.com/pforth/.git/commitdiff_plain/f1994bf609c5b053c5c0d7db2062b570fa9f5ead?hp=0b1e24898c41afa1f07854c295881b23aa2faea6

Merge pull request #36 from ellerh/resize-file-limit

This introduces a RESIZE-FILE-LIMIT
---

diff --git a/fth/file.fth b/fth/file.fth
index a2835bf..59303f0 100644
--- a/fth/file.fth
+++ b/fth/file.fth
@@ -143,4 +143,18 @@ create (LINE-TERMINATOR) \n c,
     ENDCASE
 ; immediate
 
+\ We basically try to open the file in read-only mode.  That seems to
+\ be the best that we can do with ANSI C.  If we ever want to do
+\ something more sophisticated, like calling access(2), we must create
+\ a proper primitive.  (OTOH, portable programs can't assume much
+\ about FILE-STATUS and non-portable programs could create a custom
+\ function for access(2).)
+: FILE-STATUS ( c-addr u -- 0 ior )
+    r/o bin open-file           ( fileid ior1 )
+    ?dup
+    IF   nip 0 swap             ( 0 ior1 )
+    ELSE close-file 0 swap      ( 0 ior2 )
+    THEN
+;
+
 privatize
diff --git a/fth/loadp4th.fth b/fth/loadp4th.fth
index 3d454f0..0973fc9 100644
--- a/fth/loadp4th.fth
+++ b/fth/loadp4th.fth
@@ -26,6 +26,7 @@ include? task-misc2.fth misc2.fth
 include? [if]    condcomp.fth
 include? save-input save-input.fth
 include? read-line  file.fth
+include? require    require.fth
 
 \ load floating point support if basic support is in kernel
 exists? F*
diff --git a/fth/require.fth b/fth/require.fth
new file mode 100644
index 0000000..18a060a
--- /dev/null
+++ b/fth/require.fth
@@ -0,0 +1,34 @@
+\ REQUIRE and REQUIRED
+\
+\ This code is part of pForth.
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license.  The pForth software
+\ code is provided on an "as is" basis without any warranty
+\ of any kind, including, without limitation, the implied
+\ warranties of merchantability and fitness for a particular
+\ purpose and their equivalents under the laws of any jurisdiction.
+
+private{
+
+\ Has the file with name C-ADDR/U already been included?
+\
+\ This searches the "::::<filename>" marker created by INCLUDED.  This
+\ works for now, but may break if pForth ever receives wordlists.
+: INCLUDED? ( c-addr u -- flag )
+    s" ::::" here place         ( c-addr u )
+    here $append                ( )
+    here find nip 0<>           ( found? )
+;
+
+\ FIXME: use real PARSE-NAME when available
+: (PARSE-NAME) ( "word" -- c-addr u ) bl parse-word ;
+
+}private
+
+: REQUIRED ( i*x c-addr u -- j*x ) 2dup included? IF 2drop ELSE included THEN ;
+: REQUIRE ( i*x "name" -- i*x ) (parse-name) required ;
+
+privatize
diff --git a/fth/system.fth b/fth/system.fth
index 48572cf..21200fa 100644
--- a/fth/system.fth
+++ b/fth/system.fth
@@ -729,9 +729,11 @@ ustack 0stackp
 variable TRACE-INCLUDE
 
 : INCLUDE.MARK.START  ( c-addr u -- , mark start of include for FILE?)
-    " ::::"  pad $MOVE
-    pad $APPEND
-    pad ['] noop (:)
+    dup 5 + allocate throw >r
+    " ::::" r@ $move
+    r@ $append
+    r@ ['] noop (:)
+    r> free throw
 ;
 
 : INCLUDE.MARK.END  ( -- , mark end of include )
diff --git a/fth/t_file.fth b/fth/t_file.fth
index 388008c..297f208 100644
--- a/fth/t_file.fth
+++ b/fth/t_file.fth
@@ -60,7 +60,7 @@ include? }T{  t_tools.fth
 
 true fp-require-e !
 
-true value verbose
+false value verbose
 
 : testing
     verbose IF
@@ -73,9 +73,6 @@ true value verbose
 : s= compare 0= ;
 : $" state IF postpone s" else ['] s" execute THEN ; immediate
 
-\ FIXME: stubs for missing definitions
-: file-status 2drop 0 -1 ;
-
 TESTING File Access word set
 
 DECIMAL
@@ -246,6 +243,21 @@ T{ FID1 @ CLOSE-FILE -> 0 }T
 \ Tidy the test folder
 T{ fn3 DELETE-FILE DROP -> }T
 
+\ ------------------------------------------------------------------------------
+TESTING REQUIRED REQUIRE INCLUDED
+\ Tests taken from Forth 2012 RfD
+
+T{ 0 S" t_required_helper1.fth" REQUIRED
+     REQUIRE t_required_helper1.fth
+     INCLUDE t_required_helper1.fth
+     -> 2 }T
+
+T{ 0 INCLUDE t_required_helper2.fth
+     S" t_required_helper2.fth" REQUIRED
+     REQUIRE t_required_helper2.fth
+     S" t_required_helper2.fth" INCLUDED
+     -> 2 }T
+
 \ ----------------------------------------------------------------------------
 TESTING two buffers available for S" and/or S\" (Forth 2012)
 
diff --git a/fth/t_required_helper1.fth b/fth/t_required_helper1.fth
new file mode 100644
index 0000000..910cef4
--- /dev/null
+++ b/fth/t_required_helper1.fth
@@ -0,0 +1,3 @@
+\ For testing REQUIRED etc
+
+1+
diff --git a/fth/t_required_helper2.fth b/fth/t_required_helper2.fth
new file mode 100644
index 0000000..910cef4
--- /dev/null
+++ b/fth/t_required_helper2.fth
@@ -0,0 +1,3 @@
+\ For testing REQUIRED etc
+
+1+