← Back to branch summary

~pmdj/ubuntu/trusty/qemu/2.9+applesmc+fadtv3

« back to all changes in this revision

Viewing changes to roms/SLOF/slof/fs/packages/fat-files.fs

  • Committer: Phil Dennis-Jordan
  • Date: 2017-07-21 08:03:43 UTC
  • mfrom: (1.1.1)
  • Revision ID: phil@philjordan.eu-20170721080343-2yr2vdj7713czahv
New upstream release 2.9.0.

Show diffs side-by-side

added added

removed removed

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