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