Implement FLUSH-FILE

* csrc/pf_guts.h (cforth_primitive_ids): Add ID_FILE_FLUSH, remove
ID_RESERVED13.
(THROW_FLUSH_FILE): New.

* csrc/pf_inner.c (pfCatch): Add case for ID_FILE_FLUSH.
* csrc/pfcompil.c (pfBuildDictionary): Add FLUSH-FILE.
* fth/t_file.fth (FLUSH-FILE): Remove stub definition.

diff --git a/csrc/pf_guts.h b/csrc/pf_guts.h
index 8f5e11f..4fa4bd0 100644 (file)
--- a/csrc/pf_guts.h
+++ b/csrc/pf_guts.h
@@ -281,6 +281,7 @@ enum cforth_primitive_ids
     ID_CELLS,
     /* DELETE-FILE */
     ID_FILE_DELETE,
     ID_CELLS,
     /* DELETE-FILE */
     ID_FILE_DELETE,

+    ID_FILE_FLUSH,             /* FLUSH-FILE */

 /* If you add a word here, take away one reserved word below. */
 #ifdef PF_SUPPORT_FP
 /* Only reserve space if we are adding FP so that we can detect
 /* If you add a word here, take away one reserved word below. */
 #ifdef PF_SUPPORT_FP
 /* Only reserve space if we are adding FP so that we can detect


@@ -298,7 +299,6 @@ enum cforth_primitive_ids
     ID_RESERVED10,
     ID_RESERVED11,
     ID_RESERVED12,
     ID_RESERVED10,
     ID_RESERVED11,
     ID_RESERVED12,

-    ID_RESERVED13,

     ID_FP_D_TO_F,
     ID_FP_FSTORE,
     ID_FP_FTIMES,
     ID_FP_D_TO_F,
     ID_FP_FSTORE,
     ID_FP_FTIMES,


@@ -368,6 +368,7 @@ enum cforth_primitive_ids
 #define THROW_PAIRS           (-22)
 #define THROW_FLOAT_STACK_UNDERFLOW  ( -45)
 #define THROW_QUIT            (-56)
 #define THROW_PAIRS           (-22)
 #define THROW_FLOAT_STACK_UNDERFLOW  ( -45)
 #define THROW_QUIT            (-56)

+#define THROW_FLUSH_FILE      (-68)

 
 /* THROW codes unique to pForth */
 #define THROW_BYE            (-256) /* Exit program. */
 
 /* THROW codes unique to pForth */
 #define THROW_BYE            (-256) /* Exit program. */

diff --git a/csrc/pf_inner.c b/csrc/pf_inner.c
index dcf12c6..06466c7 100644 (file)
--- a/csrc/pf_inner.c
+++ b/csrc/pf_inner.c
@@ -1091,6 +1091,13 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));
             TOS = TOS | PF_FAM_BINARY_FLAG;
             endcase;
 
             TOS = TOS | PF_FAM_BINARY_FLAG;
             endcase;
 

+       case ID_FILE_FLUSH: /* ( fileid -- ior ) */
+           {
+               FileStream *Stream = (FileStream *) TOS;
+               TOS = (sdFlushFile( Stream ) == 0) ? 0 : THROW_FLUSH_FILE;
+           }
+           endcase;
+

         case ID_FILL: /* ( caddr num charval -- ) */
             {
                 register char *DstPtr;
         case ID_FILL: /* ( caddr num charval -- ) */
             {
                 register char *DstPtr;

diff --git a/csrc/pfcompil.c b/csrc/pfcompil.c
index 467d1e8..8a147b9 100644 (file)
--- a/csrc/pfcompil.c
+++ b/csrc/pfcompil.c
@@ -258,6 +258,7 @@ PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize )
     CreateDicEntryC( ID_FILE_WRITE, "WRITE-FILE",  0 );
     CreateDicEntryC( ID_FILE_POSITION, "FILE-POSITION",  0 );
     CreateDicEntryC( ID_FILE_REPOSITION, "REPOSITION-FILE",  0 );
     CreateDicEntryC( ID_FILE_WRITE, "WRITE-FILE",  0 );
     CreateDicEntryC( ID_FILE_POSITION, "FILE-POSITION",  0 );
     CreateDicEntryC( ID_FILE_REPOSITION, "REPOSITION-FILE",  0 );

+    CreateDicEntryC( ID_FILE_FLUSH, "FLUSH-FILE",  0 );

     CreateDicEntryC( ID_FILE_RO, "R/O",  0 );
     CreateDicEntryC( ID_FILE_RW, "R/W",  0 );
     CreateDicEntryC( ID_FILE_WO, "W/O",  0 );
     CreateDicEntryC( ID_FILE_RO, "R/O",  0 );
     CreateDicEntryC( ID_FILE_RW, "R/W",  0 );
     CreateDicEntryC( ID_FILE_WO, "W/O",  0 );

diff --git a/fth/t_file.fth b/fth/t_file.fth
index 5f9e325..328ae7f 100644 (file)
--- a/fth/t_file.fth
+++ b/fth/t_file.fth
@@ -73,14 +73,11 @@ true value verbose
 : s= compare 0= ;
 : $" state IF postpone s" else ['] s" execute THEN ; immediate
 
 : s= compare 0= ;
 : $" state IF postpone s" else ['] s" execute THEN ; immediate
 

-
-\ FIXME: stubs for missing definition
-: flush-file drop -1 ;
+\ FIXME: stubs for missing definitions

 : resize-file drop 2drop -1 ;
 : rename-file 2drop 2drop -1 ;
 : file-status 2drop 0 -1 ;
 
 : resize-file drop 2drop -1 ;
 : rename-file 2drop 2drop -1 ;
 : file-status 2drop 0 -1 ;
 

-

 TESTING File Access word set
 
 DECIMAL
 TESTING File Access word set
 
 DECIMAL