This introduces a RESIZE-FILE-LIMIT

[pforth] / fth / system.fth

diff --git a/fth/system.fth b/fth/system.fth
index 71b778e..48572cf 100644 (file)
--- a/fth/system.fth
+++ b/fth/system.fth
@@ -26,7 +26,7 @@
 \ Based on HMSL Forth
 \
 \ Author: Phil Burk
 \ Based on HMSL Forth
 \
 \ Author: Phil Burk

-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom

 \
 \ The pForth software code is dedicated to the public domain,
 \ and any third party may reproduce, distribute and modify
 \
 \ The pForth software code is dedicated to the public domain,
 \ and any third party may reproduce, distribute and modify


@@ -360,6 +360,18 @@
         2* swap
 ;
 
         2* swap
 ;
 

+: D= ( xd1 xd2 -- flag )
+       rot = -rot = and
+;
+
+: D< ( d1 d2 -- flag )
+    d- nip 0<
+;
+
+: D> ( d1 d2 -- flag )
+    2swap d<
+;
+

 \ define some useful constants ------------------------------
 1 0= constant FALSE
 0 0= constant TRUE
 \ define some useful constants ------------------------------
 1 0= constant FALSE
 0 0= constant TRUE


@@ -596,29 +608,6 @@ ustack 0stackp
         char [compile] literal
 ; immediate
 
         char [compile] literal
 ; immediate
 

-: TOUPPER ( char -- char' )
-       dup [char] a >=
-       IF
-               dup [char] z <= IF [ char A char a - ] literal + THEN
-       THEN
-;
-
-: UPCASE ( c-addr u -- )
-       over + swap ?do
-               i c@ toupper i c!
-       loop
-;
-
-create WORD-SAVE-AREA 257 allot
-
-\ This version performs case-conversion for backward compatibility.
-: WORD ( char -- addr )
-       parse-word
-       word-save-area place
-       word-save-area count upcase
-       word-save-area
-;
-

 : $TYPE  ( $string -- )
         count type
 ;
 : $TYPE  ( $string -- )
         count type
 ;


@@ -739,9 +728,9 @@ create WORD-SAVE-AREA 257 allot
 \ -------------- INCLUDE ------------------------------------------
 variable TRACE-INCLUDE
 
 \ -------------- INCLUDE ------------------------------------------
 variable TRACE-INCLUDE
 

-: INCLUDE.MARK.START  ( $filename -- , mark start of include for FILE?)
+: INCLUDE.MARK.START  ( c-addr u -- , mark start of include for FILE?)

     " ::::"  pad $MOVE
     " ::::"  pad $MOVE

-    count pad $APPEND
+    pad $APPEND

     pad ['] noop (:)
 ;
 
     pad ['] noop (:)
 ;
 


@@ -749,19 +738,18 @@ variable TRACE-INCLUDE
     " ;;;;" ['] noop (:)
 ;
 
     " ;;;;" ['] noop (:)
 ;
 

-: $INCLUDE ( $filename -- )
-\ Print messages.
+: INCLUDED ( c-addr u -- )
+       \ Print messages.

         trace-include @
         IF
         trace-include @
         IF

-                >newline ." Include " dup count type cr
+                >newline ." Include " 2dup type cr

         THEN
         here >r
         THEN
         here >r

-        dup
-        count r/o open-file
-        IF  ( -- $filename bad-fid )
-                drop ." Could not find file " $type cr abort
-        ELSE ( -- $filename good-fid )
-                swap include.mark.start
+        2dup r/o open-file
+        IF  ( -- c-addr u bad-fid )
+                drop ." Could not find file " type cr abort
+        ELSE ( -- c-addr u good-fid )
+               -rot include.mark.start

                 depth >r
                 include-file    \ will also close the file
                 depth 1+ r> -
                 depth >r
                 include-file    \ will also close the file
                 depth 1+ r> -


@@ -780,6 +768,8 @@ variable TRACE-INCLUDE
         rdrop
 ;
 
         rdrop
 ;
 

+: $INCLUDE ( $filename -- ) count included ;
+

 create INCLUDE-SAVE-NAME 128 allot
 : INCLUDE ( <fname> -- )
         BL lword
 create INCLUDE-SAVE-NAME 128 allot
 : INCLUDE ( <fname> -- )
         BL lword