X-Git-Url: http://git.subgeniuskitty.com/pforth/.git/blobdiff_plain/02bd1b5ec2f24b6f3d30ac7c2fb9af2836919ee7..8d2c2052594284dc08a548589d63b6bcaf28f653:/fth/file.fth

diff --git a/fth/file.fth b/fth/file.fth
index bc81f3a..0017942 100644
--- a/fth/file.fth
+++ b/fth/file.fth
@@ -50,6 +50,26 @@ private{
 create (LINE-TERMINATOR) \n c,
 : LINE-TERMINATOR ( -- c-addr u ) (line-terminator) 1 ;
 
+\ Standard throw code
+\ See: http://lars.nocrew.org/forth2012/exception.html#table:throw
+-72 constant THROW_RENAME_FILE
+
+\ Copy the string C-ADDR/U1 to C-ADDR2 and append a NUL.
+: PLACE-CSTR  ( c-addr1 u1 c-addr2 -- )
+    2dup 2>r          ( c-addr1 u1 c-addr2 )  ( r: u1 c-addr2 )
+    swap cmove        ( ) ( r: u1 c-addr2 )
+    0 2r> + c!        ( )
+;
+
+: MULTI-LINE-COMMENT ( "comment<rparen>" -- )
+    BEGIN
+        >in @ ')' parse         ( >in c-addr len )
+        nip + >in @ =           ( delimiter-not-found? )
+    WHILE                       ( )
+        refill 0= IF EXIT THEN  ( )
+    REPEAT
+;
+
 }private
 
 \ This treats \n, \r\n, and \r as line terminator.  Reading is done
@@ -85,4 +105,40 @@ 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.
+    a1 u1 here place-cstr
+    here u1 1+ chars + to new
+    a2 u2 new place-cstr
+    here new (rename-file) 0=
+    IF 0
+    ELSE throw_rename_file
+    THEN
+;
+
+: (  ( "comment<rparen>"  -- )
+    source-id
+    CASE
+        -1 OF postpone ( ENDOF
+        0  OF postpone ( ENDOF
+        \ for input from files
+        multi-line-comment
+    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 -- x ior )
+    r/o bin open-file           ( fileid ior1 )
+    ?dup
+    IF                          ( fileid ior1 )
+    ELSE close-file 0 swap      ( 0 ior2 )
+    THEN
+;
+
 privatize