\                                                                    vandys
\ Block filesystem
only extensions also   fs definitions
$FFEEEEDD constant FSMAGIC   32 constant #NAMECHARS
struct meta   int32 magic   int32 type   int32 fence   int32 here   endstruct
enum FST   enumval dir   enumval file
   enumval dir_free   enumval file_free   endenum
: (magic) ( ptr -- )   FSMAGIC swap   meta>magic !   update ;
: ((>meta))   BASESIZ + ;
: (>meta) ( ptr -- ptr' )   ((>meta))
   dup meta>magic @ FSMAGIC - abort" Corrupt block" ;
: (initfree) ( blk type -- )   swap buffer   dup BLKSIZ erase
   ((>meta))   tuck meta>type !   (magic) ;
: (inithead) ( #blk blk type -- )   >r   dup buffer   dup BLKSIZ erase
   ((>meta))   r> over meta>type !   >r tuck + r> tuck meta>fence !
   swap 1+ over meta>here !   (magic) ;
: (initbody) ( #blk blk type -- blk )   -rot tuck tuck + swap 1+ do
      over i swap (initfree)   loop nip ;
: mkfs ( base #blk -- )   2dup swap FST_dir (inithead)
   swap FST_dir_free (initbody)   drop ;





\                                                                    vandys
struct dir   #NAMECHARS bytes name   int32 base   endstruct
BASESIZ dir.size /   constant #DIRFILES
: (cwd@) ( -- blk )   cwd @ dup 0= abort" No CWD" ;
: (cwd>) ( -- ptr )   (cwd@) block ;
: (cwd>meta) ( -- ptr )   (cwd>) (>meta) ;
: (block>meta) ( blk -- ptr )   block (>meta) ;
: root   cwd cell+ ;
: ($dirent) ( str -- dirent | 0 )   (cwd>)
   #DIRFILES 0 do   dup dir>base @ 0= if   unloop 2drop 0 exit then
      2dup dir>name $strcmp 0= if   unloop nip exit   then
   dir.size + loop   2drop 0 ;
: ($lookup) ( str -- block | 0 )   ($dirent) dup 0= if   exit   then
   dir>base @ ;
: cwd! ( blk -- )   dup (block>meta)
   meta>type @ FST_dir - abort" Not dir"
   root @ 0= if dup root ! then   cwd ! ;
: found? ( blk -- blk )   dup 0= abort" Not found" ;
: $cd ( s -- )   ($lookup) found?   cwd! ;
: cd ( <name> )   token $cd ;
: cd/ ( -- )   root @ dup 0= abort" No root"   cwd! ;
: root!   dup cwd!   root ! ;



\                                                                    vandys
: (slot) ( blkptr -- dirptr )   #DIRFILES 0 do
      dup dir>base @ 0= if   unloop exit   then
   dir.size + loop   1 abort" Dir full" ;
: (blkallot) ( nblk metaptr -- )   tuck meta>here @ +
   over meta>fence @ over < abort" Out of space"
   swap meta>here ! ;
: ($mkent) ( nblk name -- nblk blk )
   over 0< abort" Bad size"   dup ($dirent) abort" Exists"
   swap tuck (cwd>)   ( nblk name nblk blkptr )   dup (>meta) >r
   (slot) rot over dir>name swap $strcpy   ( nblk dirent R: metaptr )
   r@ meta>here @ -rot   swap r> (blkallot)   ( nblk here dirent )
   over -rot dir>base !   update ;
: (blankbod) ( blk -- )   buffer   dup BASESIZ blank   [char] \ swap c! ;
: (initfile) ( nblk block -- )   tuck   FST_file (inithead)
   (blankbod)   update ;
: $creat ( nblk name -- block )   ($mkent)   2dup (initfile)
   FST_file_free (initbody) ;
: creat   token $creat ;






\                                                                    vandys

: (.type) ( u -- )   dup FST_dir = if ."  Dir   " drop exit then
   dup FST_file = if ." File   " drop exit then
   dup FST_dir_free = if ." (dfree)" drop exit then
   dup FST_file_free = if ." (free) " drop exit then   5 u.r ;

: entriesDo ( arg 'fn -- )   #DIRFILES 0 do   2dup
      (cwd>) i dir.size * +   ( arg 'fn arg 'fn dirent )
      dup dir>base @ 0= if   3drop 2drop unloop exit   then
      swap execute   loop 2drop ;

: .entry ( dirent blkno meta -- )   swap >r ( dirent meta R: blkno )
   dup meta>type @ (.type)   r@ 6 u.r   space
   dup meta>here @ r@ - 4 u.r   ." /"
   meta>fence @ r> - 4 u.r   space   dir>name .id   cr ;
: (.ls) ( 0 dirent -- )   nip   dup dir>base @   dup (block>meta)
   ( dirent blkno meta )
   dup meta>type @ FST_file_free = if   3drop   exit then   .entry ;

: .head ( -- )   cr ." Type  Start   Length  Name" cr ;
: .ls ( -- )   .head   0   ['] (.ls)   entriesDo ;
: ls   .ls ;


\                                                                    vandys
\ Return "open" file
: ($open) ( type str -- blk )   ($lookup) found? ( type blk )
   dup (block>meta) meta>type @ rot - abort" Wrong type of entry" ;
: $open ( str -- blk )   FST_file swap ($open) ;
: open ( -- blk )   token $open ;
: open# ( -- blklow blkhigh )   open   dup (block>meta) meta>here @ 1- ;

\ Load source from file
: load   open# thru ;















\                                                                    vandys

\ NOTE: loading continues here from boostrap build of filesystem
only extensions also   fs definitions

\ Create directory
: (initdir) ( nblk block -- )   FST_dir (inithead) ;
: $mkdir ( nblk name -- )   ($mkent)   2dup (initdir)
   FST_dir_free (initbody)    drop ;
: mkdir ( -- )   token $mkdir ;

: (file>meta) ( blkptr -- meta )   (>meta)
   dup meta>type @ FST_file - abort" Not a file" ;












\                                                                    vandys
: (initfilemeta) ( blkptr -- )   ((>meta))   dup BLKRESID erase
   FST_file over meta>type !   (magic) ;
: (initfilebod) ( blk -- )   dup (blankbod)   block (initfilemeta) ;
: (tagdelta) ( oldhere newhere -- )   2dup = if   2drop exit   then
   2dup < if   swap do   i (initfilebod)   loop
   else   do   i FST_file_free (initfree)   loop   then ;
: size! ( nblk block -- )   over 1 < abort" Bad size"
   tuck +  >r   block (file>meta)
   dup meta>fence @ dup 0= abort" Not head of file"
   r@ < abort" Out of space" ( meta -- R: newhere )
   dup meta>here @ r@ rot   ( oldhere newhere meta R: newhere )
   r> swap meta>here !   update
   (tagdelta) ;
: copy ( from to -- )   swap block swap block   BASESIZ move update ;
: (copy-1st) ( dest high low -- dest+1 high low+1 )
   dup 3 pick fs.copy   1+ rot 1+ -rot ;
: copy-blocks ( low high dest -- )   >r 2dup swap - 1+   r@ size!
   1+ swap r> -rot   (copy-1st)
   do   i over copy   dup block (initfilemeta)
   1+ loop   drop sync ;




\ Insertion of a block into a file                                   vandys

: (file?) ( blk -- <bool> )   (block>meta) meta>type @
   dup FST_file =   swap FST_file_free =   or ;

: file>head ( blk -- blkhead )   dup (file?) not abort" Not file"
   begin   dup (block>meta)
      dup meta>type @ FST_file <>   swap meta>fence @ 0=   or
   while   1-   repeat ;

: file>tail ( blk -- blktail )   file>head (block>meta) meta>here @ 1- ;

: (grow1) ( blk -- )   dup (block>meta) meta>here @   over - 1+
   swap size! ;











\ Insertion of a block into a file                                   vandys

\ Move blocks up by one in file; block at top already allocated
: (moveup) ( blkpoint blkhead -- )   (block>meta) meta>here @ 2 -
   begin   2dup <=   while   dup dup 1+ fs.copy   1-   repeat   2drop ;

\ Insert block in file, moving named block forward.  It is legal for
\  this to be the first block beyond the end of the file; this simply
\  grows the file one block.
: insblock ( blk -- )   dup dup file>head   dup (grow1)   (moveup)
   (blankbod) update ;














\ Deletion of a block from a file                                    vandys

: (movedown) ( blkpoint blkhead -- )   (block>meta) meta>here @ 2 -
   begin   2dup <= while   over dup 1+ swap fs.copy   swap 1+ swap
   repeat   2drop ;
: (shrink1) ( blkhead -- )   dup (block>meta) meta>here @   over - 1-
   swap size! ;
: delblock ( blk -- )   dup file>head   tuck (movedown)
   (shrink1) ;
















\ Deletion and rename of a file                                      vandys

\ TBD: free space allocator should do a first-fit scan
\ But for now, just mask the file's existence for "fs.ls" purposes
: (type!) ( new old str -- )   ($open) ( blk )
   (block>meta) meta>type !   update ;
: $rm ( str -- )   FST_file_free FST_file rot (type!) ;
: rm ( -- )   token $rm ;
: $unrm ( str -- )   FST_file FST_file_free rot (type!) ;
: unrm ( -- )   token $unrm ;
: (.lsrm) ( 0 dirent -- )   nip   dup dir>base @   dup (block>meta)
   ( dirent blkno meta) dup meta>type @ FST_file_free - if
      3drop exit then   .entry ;
: lsrm ( -- )   .head   0   ['] (.lsrm)   entriesDo ;

\ Rename
: rename ( -- )   token ($dirent) found?   dir>name ( 'dirname )
   token $strcpy   update ;

All filesystem words go in the "fs" vocabulary
Magic # for metadata         Name length for filename
Shape of metadata, which is located in the last 96 bytes of a 4k block
Block types: file, directory, and free blocks in each

: (magic) Tag metadata with magic # and flag block changed
: ((>meta)) Convert base pointer without sanity check
: (>meta) Convert base block pointer to metadata
   Verifies that metadata magic # is present
: (initfree) Zero whole block, sign with magic #

: (inithead) Initialize header of file or directory; records allocation
 of blocks to the object.

: (initbody) Initialize contents of file or directory

: mkfs New filesystem     Init 1st block as directory
   Init all blocks but initial directory one





                                                                     vandys
Shape of an entry in a directory block
# filename entries in a given dir block
: (cwd@) Return CWD, applying sanity check
: (cwd>) Return block containing CWD
: (cwd>meta) Metadata of CWD
: (block>meta) Convert block number to metadata pointer
: root Second cell of "cwd" user space is root of filesystem
: ($dirent) Return pointer to matching dirent in CWD, or 0
                    Check for end of valid entries
      Compare name
   Walk along to next directory entry
: ($lookup) Look up in dir by name

: cwd! Set block # for current working directory
   Sanity check
   Make root if first CWD set     ...and set CWD
: found? Abort if block # was 0 (not found)
: $cd Set CWD to subdir of current
: cd Interactive set CWD
: cd/ Set CWD to root of filesystem
: root! Set root along with CWD, with sanity checking



                                                                     vandys
: (slot) Find next open slot in directory


: (blkallot) Allocate some blocks from current directory


: ($mkent) Create new entry in current directory.  Its actual type
 and initialization is handled by the caller.




: (blankbod) Fill in body of file with initial contents
: (initfile) Initialize file contents

: $creat Create a new file

: creat Create a new file interactively








: (.type) Display type of entry




: entriesDo Iterate across all non-empty directory entries
      Access next slot in CWD
      When we reach a zeroed one, there are no more to display
      Invote our iterator

: .entry Display a single directory entry



: (.ls) Iterator for .ls, displays only directories and files



: .head Display the heading for a .ls output
: .ls Display all (non-deleted) entries
: ls Alias for .ls, so "fs.ls" works like you'd expect




: ($open) Open a file, enforcing the indicated type

: $open Open filename passed as counted string
: open Interactive file open
: open# Interactive open returning range of valid blocks


: load fs.load (as opposed to forth.load), load all blocks in
 a (presumably source) file














                                                                     vandys





: (initdir) Initialize meta information for directory block
: $mkdir Create directory from passed counted string (along with
 size)
: mkdir Interactive make directory

: (file>meta) Return metadata for block of file, verify that it *is*
 a file.












                                                                     vandys
: (initfilemeta) Initiliaze contents of metadata portion of file body

: (initfilebod) Set contents of a new block in the file's body
: (tagdelta) Mark blocks with new file type, FST_file_free if the file
 shrank, or FS_file if it grew.  New storage blocks get blanked, whereas
 entries on the freelist are zeroed.
: size! Set size of file   Sanity
   Calc new size, get file metadata
   Verify head of file (meta>here is 0 in body blocks of file)
   Verify room                                Save old, new "here"
   Set "here" to new end of file
   Now mark affected block range to their new value

: copy Copy only data contents, leaving metadata alone
: (copy-1st) Copy first block of file, preserving metadata

: copy-blocks Put a range of blocks into a file, setting the file
 length to reflect this as its contents.








: (file?) Tell if block is part of a file (body or unused extents)


: file>head Move from body of a file back to its first block
 TBD: should we just keep a back-pointer?



: file>tail Move from body of file to last valid block in it (i.e.,
 not an unallocated block at its end)
: (grow1) Grow file by one block







































: (movedown) Ripple down blocks, closing over the "blkpoint" block.


: (shrink1) Trime size of file by one block

: delblock Delete a block from a file





















: (type!) Assert current type, then change type to indicated one

: $rm "delete" entry named by string; set its filetype to "file deleted"
: rm Delete file named by next token
: $unrm "undelete" previously deleted entry
: unrm Interactive version
: (.lsrm) Iterator, displays only deleted entries


: lsrm List deleted entries


: rename Change file's name