From: Helmut Eller <eller.helmut@gmail.com>
Date: Mon, 2 Jan 2017 18:28:25 +0000 (+0100)
Subject: Implement RENAME-FILE
X-Git-Url: http://git.subgeniuskitty.com/pforth/.git/commitdiff_plain/6f3de3962bb26f4e1be714dfefc78de0fc16b376

Implement RENAME-FILE

This introduces a primitive (RENAME-FILE) which takes C-strings as
arguments.  The conversion from Forth-strings to C-strings is done in
Forth code as it doesn't seem to be any easier to do it in C.

* csrc/pf_io.h (sdRenameFile): New.  It has the same semantics as
rename(2) from <stdio.h>

* csrc/pf_io.c (sdRenameFile): New stub.

* csrc/pf_guts.h (cforth_primitive_ids): ID_FILE_RENAME added,
ID_RESERVED12 removed

* csrc/pf_inner.c: Add case for ID_FILE_RENAME.

* csrc/pfcompil.c (pfBuildDictionary): Create entry for (RENAME-FILE).

* fth/file.fth (RENAME-FILE): New.
(THROW_RENAME_FILE): New constant.

* fth/t_file.fth: Remove stub and uncomment some tests.
---

diff --git a/csrc/pf_guts.h b/csrc/pf_guts.h
index 4fa4bd0..5339294 100644
--- a/csrc/pf_guts.h
+++ b/csrc/pf_guts.h
@@ -282,6 +282,7 @@ enum cforth_primitive_ids
     /* DELETE-FILE */
     ID_FILE_DELETE,
     ID_FILE_FLUSH,		/* FLUSH-FILE */
+    ID_FILE_RENAME,		/* (RENAME-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
@@ -298,7 +299,6 @@ enum cforth_primitive_ids
     ID_RESERVED09,
     ID_RESERVED10,
     ID_RESERVED11,
-    ID_RESERVED12,
     ID_FP_D_TO_F,
     ID_FP_FSTORE,
     ID_FP_FTIMES,
diff --git a/csrc/pf_inner.c b/csrc/pf_inner.c
index 06466c7..0a6c003 100644
--- a/csrc/pf_inner.c
+++ b/csrc/pf_inner.c
@@ -1098,6 +1098,14 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));
 	    }
 	    endcase;
 
+	case ID_FILE_RENAME: /* ( oldName newName -- ior ) */
+	    {
+		char *New = (char *) TOS;
+		char *Old = (char *) M_POP;
+		TOS = sdRenameFile( Old, New );
+	    }
+	    endcase;
+
         case ID_FILL: /* ( caddr num charval -- ) */
             {
                 register char *DstPtr;
diff --git a/csrc/pf_io.c b/csrc/pf_io.c
index 3aedb49..643178b 100644
--- a/csrc/pf_io.c
+++ b/csrc/pf_io.c
@@ -221,5 +221,13 @@ FileStream *sdDeleteFile( const char *FileName )
     TOUCH(FileName);
     return NULL;
 }
+
+int sdRenameFile( const char *OldName, const char *NewName )
+{
+    UNIMPLEMENTED("sdRenameFile");
+    TOUCH(OldName);
+    TOUCH(NewName);
+    return -1;
+}
 #endif
 
diff --git a/csrc/pf_io.h b/csrc/pf_io.h
index 8af1667..7cf4310 100644
--- a/csrc/pf_io.h
+++ b/csrc/pf_io.h
@@ -85,6 +85,7 @@ void ioTerm( void );
     cell_t sdReadFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream  );
     cell_t sdWriteFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream  );
     cell_t sdSeekFile( FileStream * Stream, off_t Position, int32_t Mode );
+    cell_t sdRenameFile( const char *OldName, const char *NewName );
     off_t sdTellFile( FileStream * Stream );
     cell_t sdCloseFile( FileStream * Stream );
     cell_t sdInputChar( FileStream *stream );
@@ -127,6 +128,7 @@ void ioTerm( void );
             #define sdTellFile      ftello
         #endif
         #define sdCloseFile     fclose
+        #define sdRenameFile    rename
         #define sdInputChar     fgetc
 
         #define PF_STDIN  ((FileStream *) stdin)
diff --git a/csrc/pfcompil.c b/csrc/pfcompil.c
index 8a147b9..a3f0121 100644
--- a/csrc/pfcompil.c
+++ b/csrc/pfcompil.c
@@ -259,6 +259,7 @@ PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize )
     CreateDicEntryC( ID_FILE_POSITION, "FILE-POSITION",  0 );
     CreateDicEntryC( ID_FILE_REPOSITION, "REPOSITION-FILE",  0 );
     CreateDicEntryC( ID_FILE_FLUSH, "FLUSH-FILE",  0 );
+    CreateDicEntryC( ID_FILE_RENAME, "(RENAME-FILE)",  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/file.fth b/fth/file.fth
index bc81f3a..5393392 100644
--- a/fth/file.fth
+++ b/fth/file.fth
@@ -50,6 +50,8 @@ private{
 create (LINE-TERMINATOR) \n c,
 : LINE-TERMINATOR ( -- c-addr u ) (line-terminator) 1 ;
 
+-72 constant THROW_RENAME_FILE
+
 }private
 
 \ This treats \n, \r\n, and \r as line terminator.  Reading is done
@@ -85,4 +87,19 @@ create (LINE-TERMINATOR) \n c,
     THEN
 ;
 
+: RENAME-FILE ( c-addr1 u1 c-addr2 u2 -- ior )
+    { a1 u1 a2 u2 | new }
+    \ Convert the file-names to C-strings by copying them after HERE
+    \ with trailing zeros added.
+    a1 here u1 move
+    0 here u1 chars + c!
+    here u1 1+ chars + to new
+    a2 new u2 move
+    0 new u2 chars + c!
+    here new (rename-file) 0=
+    IF 0
+    ELSE throw_rename_file
+    THEN
+;
+
 privatize
diff --git a/fth/t_file.fth b/fth/t_file.fth
index 328ae7f..f024926 100644
--- a/fth/t_file.fth
+++ b/fth/t_file.fth
@@ -75,7 +75,6 @@ true value verbose
 
 \ FIXME: stubs for missing definitions
 : resize-file drop 2drop -1 ;
-: rename-file 2drop 2drop -1 ;
 : file-status 2drop 0 -1 ;
 
 TESTING File Access word set
@@ -231,7 +230,7 @@ T{ SOURCE-ID DUP -1 = SWAP 0= OR -> FALSE }T
 TESTING RENAME-FILE FILE-STATUS FLUSH-FILE
 
 : FN3 S" fatest3.txt" ;
-: >END FID1 @ FILE-SIZE .s DROP FID1 @ REPOSITION-FILE ;
+: >END FID1 @ FILE-SIZE DROP FID1 @ REPOSITION-FILE ;
 
 
 T{ FN3 DELETE-FILE DROP -> }T
@@ -239,11 +238,11 @@ T{ FN1 FN3 RENAME-FILE 0= -> TRUE }T
 T{ FN1 FILE-STATUS SWAP DROP 0= -> FALSE }T
 T{ FN3 FILE-STATUS SWAP DROP 0= -> TRUE }T  \ Return value is undefined
 T{ FN3 R/W OPEN-FILE SWAP FID1 ! -> 0 }T
-\ nyi T{ >END -> 0 }T
-\ nyi T{ S" Final line" fid1 @ WRITE-LINE -> 0 }T
+T{ >END -> 0 }T
+T{ S" Final line" fid1 @ WRITE-LINE -> 0 }T
 
-\ nyi T{ FID1 @ FLUSH-FILE -> 0 }T      \ Can only test FLUSH-FILE doesn't fail
-\ nyi T{ FID1 @ CLOSE-FILE -> 0 }T
+T{ FID1 @ FLUSH-FILE -> 0 }T      \ Can only test FLUSH-FILE doesn't fail
+T{ FID1 @ CLOSE-FILE -> 0 }T
 
 \ Tidy the test folder
 T{ fn3 DELETE-FILE DROP -> }T