Merge pull request #35 from ellerh/implement-require

Implement REQUIRE (Forth 2012)

diff --git a/fth/loadp4th.fth b/fth/loadp4th.fth
index 3d454f0..0973fc9 100644 (file)
--- 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? [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*
 
 \ 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 (file)
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 c1b7f66..5830cce 100644 (file)
--- a/fth/system.fth
+++ b/fth/system.fth
@@ -721,9 +721,11 @@ ustack 0stackp
 variable TRACE-INCLUDE
 
 : INCLUDE.MARK.START  ( c-addr u -- , mark start of include for FILE?)
 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 )
 ;
 
 : INCLUDE.MARK.END  ( -- , mark end of include )

diff --git a/fth/t_file.fth b/fth/t_file.fth
index 018ca58..297f208 100644 (file)
--- a/fth/t_file.fth
+++ b/fth/t_file.fth
@@ -243,6 +243,21 @@ T{ FID1 @ CLOSE-FILE -> 0 }T
 \ Tidy the test folder
 T{ fn3 DELETE-FILE DROP -> }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)
 
 \ ----------------------------------------------------------------------------
 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 (file)
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 (file)
index 0000000..910cef4
--- /dev/null
+++ b/fth/t_required_helper2.fth
@@ -0,0 +1,3 @@
+\ For testing REQUIRED etc
+
+1+