r522 - ofw/core

Author: wmb
Date: 2007-08-03 02:57:32 +0200 (Fri, 03 Aug 2007)
New Revision: 522

Modified:
   ofw/core/filecmds.fth
   ofw/core/ofwfw.fth
Log:
Integrated OFW device tree "$create-file" into the Forthmacs file interface
wordset so you can say, e.g. "writing <device_specifier>".

Modified: ofw/core/filecmds.fth
===================================================================
--- ofw/core/filecmds.fth	2007-08-03 00:55:32 UTC (rev 521)
+++ ofw/core/filecmds.fth	2007-08-03 00:57:32 UTC (rev 522)
@@ -297,6 +297,13 @@

public

+: $delete1  ( path$ -- )
+   open-directory ?dup 0= abort" Can't open directory"      ( name$ dir-ih )
+   >r  " $delete!" r@ $call-method  abort" Can't delete file"  ( r: dir-ih ) 
+   r> close-dev   
+;
+' $delete1 to _ofdelete
+
 : $delete-all  ( pattern-adr pattern-len -- )
    begin-search  begin  another-match?  while           ( 8*attributes name$ )
       \ Check attributes to see if this is a directory
@@ -438,6 +445,7 @@
    r> close-dev                                            ( path$2 )
    $open-file
 ;
+' $create-file to _ofcreate

internal

Modified: ofw/core/ofwfw.fth
===================================================================
--- ofw/core/ofwfw.fth	2007-08-03 00:55:32 UTC (rev 521)
+++ ofw/core/ofwfw.fth	2007-08-03 00:57:32 UTC (rev 522)
@@ -76,10 +76,30 @@
 \ succeeds, returns the addresses of routines to perform I/O on the
 \ open file and true.  If the operation fails, returns false.

+
+defer _ofcreate
+: null-create  ( name -- 0 )  2drop 0  ;
+' null-create to _ofcreate
+
+defer _ofdelete
+' 2drop to _ofdelete
+
 : _ofopen
    ( name mode -- [ fid mode sizeop alignop closeop writeop readop ] okay? )
-   >r count open-dev
-   dup 0=  if  r> 2drop  false exit  then   ( fid )
+   >r count                                     ( name$  r: mode )
+   r@ create-flag and  if                       ( name$  r: mode )
+      2dup ['] _ofdelete catch  if  2drop  then ( name$  r: mode )
+   then                                         ( name$  r: mode )
+
+   2dup open-dev  ?dup  0=  if                  ( name$    r: mode )
+      r@ r/o =  if                              ( name$    r: mode )
+         0                                      ( name$ 0  r: mode )
+      else                                      ( name$    r: mode )
+         2dup _ofcreate                         ( name$ ih r: mode )
+      then                                      ( name$ ih r: mode )
+      ?dup 0=  if  r> 3drop  false exit  then   ( name$ ih r: mode )
+   then                                         ( name$ ih r: mode )
+   nip nip                                      ( ih       r: mode )
    r@   ['] _ofsize   ['] _dfalign   ['] _ofclose   ['] _ofseek
    r@ r/o  =  if  ['] nullwrite  else  ['] _ofwrite  then
    r> w/o  =  if  ['] nullread   else  ['] _ofread   then