qemu/roms/SLOF/slof/fs/packages/fat-files.fs

   1 \ *****************************************************************************
   2 \ * Copyright (c) 2004, 2008 IBM Corporation
   3 \ * All rights reserved.
   4 \ * This program and the accompanying materials
   5 \ * are made available under the terms of the BSD License
   6 \ * which accompanies this distribution, and is available at
   7 \ * http://www.opensource.org/licenses/bsd-license.php
   8 \ *
   9 \ * Contributors:
  10 \ *     IBM Corporation - initial implementation
  11 \ ****************************************************************************/
  12
  13
  14 s" fat-files" device-name
  15
  16 INSTANCE VARIABLE bytes/sector
  17 INSTANCE VARIABLE sectors/cluster
  18 INSTANCE VARIABLE #reserved-sectors
  19 INSTANCE VARIABLE #fats
  20 INSTANCE VARIABLE #root-entries
  21 INSTANCE VARIABLE total-#sectors
  22 INSTANCE VARIABLE media-descriptor
  23 INSTANCE VARIABLE sectors/fat
  24 INSTANCE VARIABLE sectors/track
  25 INSTANCE VARIABLE #heads
  26 INSTANCE VARIABLE #hidden-sectors
  27
  28 INSTANCE VARIABLE fat-type
  29 INSTANCE VARIABLE bytes/cluster
  30 INSTANCE VARIABLE fat-offset
  31 INSTANCE VARIABLE root-offset
  32 INSTANCE VARIABLE cluster-offset
  33 INSTANCE VARIABLE #clusters
  34
  35 : seek  s" seek" $call-parent ;
  36 : read  s" read" $call-parent ;
  37
  38 INSTANCE VARIABLE data
  39 INSTANCE VARIABLE #data
  40
  41 : free-data
  42   data @ ?dup IF #data @ free-mem  0 data ! THEN ;
  43 : read-data ( offset size -- )
  44   free-data  dup #data ! alloc-mem data !
  45   xlsplit seek            -2 and ABORT" fat-files read-data: seek failed"
  46   data @ #data @ read #data @ <> ABORT" fat-files read-data: read failed" ;
  47
  48 CREATE fat-buf 8 allot
  49 : read-fat ( cluster# -- data )
  50   fat-buf 8 erase
  51   1 #split fat-type @ * 2/ 2/ fat-offset @ +
  52   xlsplit seek -2 and ABORT" fat-files read-fat: seek failed"
  53   fat-buf 8 read 8 <> ABORT" fat-files read-fat: read failed"
  54   fat-buf 8c@ bxjoin fat-type @ dup >r 2* #split drop r> #split
  55   rot IF swap THEN drop ;
  56
  57 INSTANCE VARIABLE next-cluster
  58
  59 : read-cluster ( cluster# -- )
  60   dup bytes/cluster @ * cluster-offset @ + bytes/cluster @ read-data
  61   read-fat dup #clusters @ >= IF drop 0 THEN next-cluster ! ;
  62 : read-dir ( cluster# -- )
  63   ?dup 0= IF root-offset @ #root-entries @ 20 * read-data 0 next-cluster !
  64   ELSE read-cluster THEN ;
  65
  66 : .time ( x -- )
  67   base @ >r decimal
  68   b #split 2 0.r [char] : emit  5 #split 2 0.r [char] : emit  2* 2 0.r
  69   r> base ! ;
  70 : .date ( x -- )
  71   base @ >r decimal
  72   9 #split 7bc + 4 0.r [char] - emit  5 #split 2 0.r [char] - emit  2 0.r
  73   r> base ! ;
  74 : .attr ( attr -- )
  75   6 0 DO dup 1 and IF s" RHSLDA" drop i + c@ ELSE bl THEN emit u2/ LOOP drop ;
  76 : .dir-entry ( adr -- )
  77   dup 0b + c@ 8 and IF drop EXIT THEN \ volume label, not a file
  78   dup c@ e5 = IF drop EXIT THEN \ deleted file
  79   cr
  80   dup 1a + 2c@ bwjoin [char] # emit 4 0.r space \ starting cluster
  81   dup 18 + 2c@ bwjoin .date space
  82   dup 16 + 2c@ bwjoin .time space
  83   dup 1c + 4c@ bljoin base @ decimal swap a .r base ! space \ size in bytes
  84   dup 0b + c@ .attr space
  85   dup 8 BEGIN 2dup 1- + c@ 20 = over and WHILE 1- REPEAT type
  86   dup 8 + 3 BEGIN 2dup 1- + c@ 20 = over and WHILE 1- REPEAT dup IF
  87   [char] . emit type ELSE 2drop THEN
  88   drop ;
  89 : .dir-entries ( adr n -- )
  90   0 ?DO dup i 20 * + dup c@ 0= IF drop LEAVE THEN .dir-entry LOOP drop ;
  91 : .dir ( cluster# -- )
  92   read-dir BEGIN data @ #data @ 20 / .dir-entries next-cluster @ WHILE
  93   next-cluster @ read-cluster REPEAT ;
  94
  95 : str-upper ( str len adr -- ) \ Copy string to adr, uppercase
  96   -rot bounds ?DO i c@ upc over c! char+ LOOP drop ;
  97 CREATE dos-name b allot
  98 : make-dos-name ( str len -- )
  99   dos-name b bl fill
 100   2dup [char] . findchar IF
 101   3dup 1+ /string 3 min dos-name 8 + str-upper nip THEN
 102   8 min dos-name str-upper ;
 103
 104 : (find-file) ( -- cluster file-len is-dir? true | false )
 105   data @ BEGIN dup data @ #data @ + < WHILE
 106   dup dos-name b comp WHILE 20 + REPEAT
 107   dup 1a + 2c@ bwjoin swap dup 1c + 4c@ bljoin swap 0b + c@ 10 and 0<> true
 108   ELSE drop false THEN ;
 109 : find-file ( dir-cluster name len -- cluster file-len is-dir? true | false )
 110   make-dos-name read-dir BEGIN (find-file) 0= WHILE next-cluster @ WHILE
 111   next-cluster @ read-cluster REPEAT false ELSE true THEN ;
 112 : find-path ( dir-cluster name len -- cluster file-len true | false )
 113   dup 0= IF 3drop false ."  empty name " EXIT THEN
 114   over c@ [char] \ = IF 1 /string  RECURSE EXIT THEN
 115   [char] \ split 2>r find-file 0= IF 2r> 2drop false ."  not found " EXIT THEN
 116   r@ 0<> <> IF 2drop 2r> 2drop false ."  no dir<->file match " EXIT THEN
 117   r@ 0<> IF drop 2r> RECURSE EXIT THEN
 118   2r> 2drop true ;
 119
 120 : do-super ( -- )
 121   0 200 read-data
 122   data @ 0b + 2c@ bwjoin bytes/sector !
 123   data @ 0d + c@ sectors/cluster !
 124   bytes/sector @ sectors/cluster @ * bytes/cluster !
 125   data @ 0e + 2c@ bwjoin #reserved-sectors !
 126   data @ 10 + c@ #fats !
 127   data @ 11 + 2c@ bwjoin #root-entries !
 128   data @ 13 + 2c@ bwjoin total-#sectors !
 129   data @ 15 + c@ media-descriptor !
 130   data @ 16 + 2c@ bwjoin sectors/fat !
 131   data @ 18 + 2c@ bwjoin sectors/track !
 132   data @ 1a + 2c@ bwjoin #heads !
 133   data @ 1c + 2c@ bwjoin #hidden-sectors !
 134
 135   \ For FAT16 and FAT32:
 136   total-#sectors @ 0= IF data @ 20 + 4c@ bljoin total-#sectors ! THEN
 137
 138   \ For FAT32:
 139   sectors/fat @ 0= IF data @ 24 + 4c@ bljoin sectors/fat ! THEN
 140
 141   \ XXX add other FAT32 stuff (offsets 28, 2c, 30)
 142
 143   \ Compute the number of data clusters, decide what FAT type we are.
 144   total-#sectors @ #reserved-sectors @ - sectors/fat @ #fats @ * -
 145   #root-entries @ 20 * bytes/sector @ // - sectors/cluster @ /
 146   dup #clusters !
 147   dup ff5 < IF drop c ELSE fff5 < IF 10 ELSE 20 THEN THEN fat-type !
 148   base @ decimal base !
 149
 150   \ Starting offset of first fat.
 151   #reserved-sectors @ bytes/sector @ * fat-offset !
 152
 153   \ Starting offset of root dir.
 154   #fats @ sectors/fat @ * bytes/sector @ * fat-offset @ + root-offset !
 155
 156   \ Starting offset of "cluster 0".
 157   #root-entries @ 20 * bytes/sector @ tuck // * root-offset @ +
 158   bytes/cluster @ 2* - cluster-offset ! ;
 159
 160
 161 INSTANCE VARIABLE file-cluster
 162 INSTANCE VARIABLE file-len
 163 INSTANCE VARIABLE current-pos
 164 INSTANCE VARIABLE pos-in-data
 165
 166 : seek ( lo hi -- status )
 167   lxjoin dup current-pos ! file-cluster @ read-cluster
 168   \ Read and skip blocks until we are where we want to be.
 169   BEGIN dup #data @ >= WHILE #data @ - next-cluster @ dup 0= IF
 170   2drop true EXIT THEN read-cluster REPEAT pos-in-data ! false ;
 171 : read ( adr len -- actual )
 172   file-len @ current-pos @ - min \ can't go past end of file
 173   #data @ pos-in-data @ - min >r \ length for this transfer
 174   data @ pos-in-data @ + swap r@ move \ move the data
 175   r@ pos-in-data +!  r@ current-pos +!  pos-in-data @ #data @ = IF
 176   next-cluster @ ?dup IF read-cluster 0 pos-in-data ! THEN THEN r> ;
 177 : read ( adr len -- actual )
 178   file-len @ min                \ len cannot be greater than file size
 179   dup >r BEGIN dup WHILE 2dup read dup 0= ABORT" fat-files: read failed"
 180   /string ( tuck - >r + r> ) REPEAT 2drop r> ;
 181 : load ( adr -- len )
 182   file-len @ read dup file-len @ <> ABORT" fat-files: failed loading file" ;
 183
 184 : close  free-data ;
 185 : open
 186   do-super
 187   0 my-args find-path 0= IF close false EXIT THEN
 188   file-len !  file-cluster !  0 0 seek 0= ;