![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fat-files.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Qemu by Fabrice Bellard] / qemu / roms / SLOF / slof / fs / packages|
Return to fat-files.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / SLOF / slof / fs / packages |
1.1 root 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 ." slash " 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> ." more... " RECURSE EXIT THEN
118: 2r> 2drop true ." got it " ;
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: cr ." FAT" base @ decimal fat-type @ . 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: dup >r BEGIN dup WHILE 2dup read dup 0= ABORT" fat-files: read failed"
179: /string ( tuck - >r + r> ) REPEAT 2drop r> ;
180: : load ( adr -- len )
181: file-len @ read dup file-len @ <> ABORT" fat-files: failed loading file" ;
182:
183: : close free-data ;
184: : open
185: do-super
186: 0 my-args find-path 0= IF close false EXIT THEN
187: file-len ! file-cluster ! 0 0 seek 0= ;
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.