PACKET dos fat and dir DEFINES (* Copyright (C) 1985, 86 *)
(* Frank Klapper *)
open disk, (* 30.05.86 *)
close disk,
format disk,
disk changed,
open fetch,
next fetch cluster no,
open save,
next save cluster no,
close save,
erase table entrys,
(*COND TEST
dump fat,
ENDCOND*)
dir all,
dir list,
dir contains:
LET fat row size = 16384, (* 32 KB *)
max fat blocks = 25,
first fat entry no = 2,
last entry of fat chain = 4088,
dir entrys per block = 16,
max dir entrys = 1600, (* 100 KB *)
archive byte = " ";
LET FAT = BOUND STRUCT (ALIGN dummy,
ROW 256 INT block row,
ROW fat row size INT fat row);
LET LOCATION = STRUCT (INT msdos block no,
block entry no),
FILEENTRY = STRUCT (TEXT date and time,
REAL size,
INT first cluster,
LOCATION location),
DIRENTRY = INT,
FILELIST = STRUCT (THESAURUS thes,
ROW max dir entrys FILEENTRY entry,
INT no of entrys),
DIRLIST = STRUCT (THESAURUS thes,
ROW max dir entrys DIRENTRY entry,
INT no of entrys),
FREELIST = STRUCT (ROW max dir entrys LOCATION stack,
INT stacktop,
LOCATION begin of free area,
end of dir,
INT dir chain root),
DIR = BOUND STRUCT (FILELIST filelist,
DIRLIST dirlist,
FREELIST freelist,
TEXT disklabel,
path);
INITFLAG VAR this packet := FALSE;
DATASPACE VAR fat space,
dir ds,
block ds;
BOOL VAR dataspaces open;
FAT VAR fat struct;
ROW max fat blocks BOOL VAR write access;
INT VAR first possible available fat entry;
DIR VAR dir;
CLUSTER VAR block;
INT VAR akt file cluster no,
first file cluster no;
BOOL VAR no cluster saved;
TEXT VAR save name;
INT VAR count;
TEXT VAR convert buffer := " ",
name,
dir entry;
.fat:
fat struct.fat row.
PROC open disk (TEXT CONST subdir path):
disable stop;
enable open disk (subdir path);
IF is error
THEN close action
FI
END PROC open disk;
PROC enable open disk (TEXT CONST subdir path):
enable stop;
init dataspaces;
open fat;
open dir.
open fat:
reset disk attributes;
read first fat block;
set disk attributes (fat byte (0));
read other fat blocks;
define write access table (FALSE);
first possible available fat entry := first fat entry no.
read first fat block:
read fat block (0, FALSE).
read other fat blocks:
INT VAR block no;
FOR block no FROM 1 UPTO number of fat sectors - 1 REP
read fat block (block no, FALSE)
PER.
open dir:
init dir struct (subdir path, -1);
load main dir blocks;
load subdirs if necessary.
load main dir blocks:
BOOL VAR last block;
store end of dir (loc (end of main dir, dir entrys per block - 1));
FOR block no FROM begin of dir UPTO end of main dir REP
load dir block (block no, last block);
UNTIL last block
PER.
end of main dir:
begin of dir + number of dir sectors - 1.
load subdirs if necessary:
TEXT VAR path := subdir path;
WHILE path <> "" REP
load next subdir if possible
PER.
load next subdir if possible:
INT VAR cluster no;
get next subdir name;
get first cluster no of subdir table;
clear dir entrys (cluster no);
WHILE cluster no >= 0 REP
load subdir entrys of cluster;
cluster no := next fetch cluster no
UNTIL last block
PER.
get next subdir name:
TEXT VAR subdir name;
IF (path SUB 1) <> "\"
THEN error stop ("ungültige Pfadbezeichnung")
FI;
INT VAR backslash pos := pos (path, "\", "\", 2);
IF backslash pos = 0
THEN subdir name := subtext (path, 2);
path := ""
ELSE subdir name := subtext (path, 2, backslash pos - 1);
path := subtext (path, backslash pos)
FI;
subdir name := adapted name (subdir name, TRUE).
get first cluster no of subdir table:
IF dir thes CONTAINS subdir name
THEN open fetch subdir (subdir name, cluster no);
ELSE error stop ("Subdirectory existiert nicht")
FI.
load subdir entrys of cluster:
store end of dir (loc (last block no of cluster, dir entrys per block - 1));
FOR block no FROM 0 UPTO (sectors per cluster - 1) REP
load dir block (first block no of cluster (cluster no) + block no, last block)
UNTIL last block
PER.
last block no of cluster:
first block no of cluster (cluster no) + sectors per cluster - 1.
END PROC enable open disk;
PROC init dataspaces:
enable stop;
IF NOT initialized (this packet)
THEN dataspaces open := FALSE
FI;
IF NOT dataspaces open
THEN disable stop;
dataspaces open := TRUE;
fat space := nilspace;
dir ds := nilspace;
block ds := nilspace;
fat struct := fat space;
dir := dir ds;
block := block ds
FI.
END PROC init dataspaces;
PROC init dir struct (TEXT CONST path string, INT CONST root):
clear dir entrys (root);
dir.path := path string;
dir.disk label := "".
END PROC init dir struct;
PROC clear dir entrys (INT CONST root):
init file list;
init dir list;
init free list (root).
init file list:
dir.file list.thes := empty thesaurus;
dir.file list.no of entrys := 0.
init dir list:
dir.dir list.thes := empty thesaurus;
dir.dir list.no of entrys := 0.
END PROC clear dir entrys;
PROC close disk:
enable stop;
IF NOT initialized (this packet)
THEN dataspaces open := FALSE
FI;
IF dataspaces open
THEN forget (dir ds);
forget (block ds);
forget (fat space);
dataspaces open := FALSE
FI.
END PROC close disk;
(*COND FLOPPY*)
PROC format disk:
enable stop;
init dataspaces;
format fat;
format dir.
format fat:
write first four fat bytes;
write other fat bytes;
define write access table (TRUE);
copy fat to disk.
write first four fat bytes:
fat [1] := word (first fat byte, 255);
fat [2] := word (255, 0).
write other fat bytes:
FOR count FROM 3 UPTO fat length REP
fat [count] := 0
PER.
fat length:
INT VAR len := number of fat entrys + number of fat entrys DIV 2
+ number of fat entrys MOD 2;
len DIV 2 + len MOD 2.
format dir:
init dir struct ("", -1);
store begin of free area (loc (begin of dir, 0));
store end of dir (loc (end of dir, dir entrys per block - 1));
FOR count FROM 0 UPTO dir entrys per block - 1 REP
write text 32 (block, ""0"" + 31 * ""246"", count)
PER;
disable stop;
FOR count FROM begin of dir UPTO end of dir REP
write disk block (block ds, count);
PER.
end of dir:
begin of dir + number of dir sectors - 1.
END PROC format disk;
(*ENDCOND*)
(*COND HDU
PROC disk clear:
error stop ("nicht implementiert")
END PROC disk clear;
PROC format disk:
error stop ("nicht implementiert")
END PROC format disk;
ENDCOND*)
INT PROC word (INT CONST low byte, high byte):
convert buffer := code (low byte) + code (high byte);
convert buffer ISUB 1.
END PROC word;
BOOL PROC disk changed:
(*COND FLOPPY*)
disable stop;
NOT first fat block ok COR is error (* must be COR *)
(*ENDCOND*)
(*COND HDU
FALSE
ENDCOND*)
END PROC disk changed;
BOOL PROC first fat block ok:
enable stop;
read fat block (0, TRUE);
FOR count FROM 1 UPTO 256 REP
compare word
PER;
TRUE.
compare word:
IF fat struct.fat row [count] <> fat struct.block row [count]
THEN LEAVE first fat block ok WITH FALSE
FI.
END PROC first fat block ok;
PROC open fetch (TEXT CONST name, REAL VAR size, INT VAR first cluster no):
enable stop;
first cluster no := dir.file list.entry [link index].first cluster;
size := dir.file list.entry [link index].size;
IF first cluster no >= 4088
THEN first cluster no := -1
FI;
akt file cluster no := first cluster no.
link index:
link (file thes, name).
END PROC open fetch;
PROC open fetch subdir (TEXT CONST subdir name, INT VAR first cluster no):
first cluster no := dir.dir list.entry [link index];
IF first cluster no >= 4088
THEN first cluster no := -1
FI;
akt file cluster no := first cluster no.
link index:
link (dir thes, subdir name).
END PROC open fetch subdir;
INT PROC next fetch cluster no:
enable stop;
akt file cluster no := fat entry (akt file cluster no);
IF akt file cluster no < 4088 (*ff8h *)
THEN akt file cluster no
ELSE -1
FI.
END PROC next fetch cluster no;
PROC open save (TEXT CONST file name):
enable stop;
save name := file name;
IF dir full
THEN error stop ("Directory voll")
FI;
IF dir thes CONTAINS file name
THEN error stop ("Subdirectory mit gleichem Namen existiert bereits")
FI;
IF file thes CONTAINS file name
THEN error stop ("Datei mit gleichem Namen existiert bereits")
FI;
no cluster saved := TRUE.
END PROC open save;
INT PROC next save cluster no:
enable stop;
IF no cluster saved
THEN akt file cluster no := available fat entry;
first file cluster no := akt file cluster no;
no cluster saved := FALSE
ELSE INT VAR old cluster no := akt file cluster no;
akt file cluster no := available fat entry;
write fat entry (old cluster no, akt file cluster no)
FI;
write fat entry (akt file cluster no, last entry of fat chain);
akt file cluster no.
END PROC next save cluster no;
PROC close save (REAL CONST size):
enable stop;
IF no cluster saved
THEN insert dir entry (save name, 4088, 0.0)
ELSE copy fat to disk;
insert dir entry (save name, first file cluster no, size)
FI.
END PROC close save;
PROC erase table entrys (TEXT CONST name):
enable stop;
INT VAR first file cluster := first cluster;
delete dir entry (name);
erase fat chain (first file cluster);
copy fat to disk.
first cluster:
dir.file list.entry [link index].first cluster.
link index:
link (file thes, name).
END PROC erase table entrys;
INT PROC fat entry (INT CONST entry no):
fix bytes;
construct value.
fix bytes:
INT VAR first byte no := entry no + entry no DIV 2.
construct value:
IF entry no MOD 2 = 0
THEN (right byte MOD 16) * 256 + left byte
ELSE right byte * 16 + left byte DIV 16
FI.
left byte:
fat byte (first byte no).
right byte:
fat byte (first byte no + 1).
END PROC fat entry;
INT PROC available fat entry:
FOR count FROM first possible available fat entry UPTO number of fat entrys - 1 REP
IF is available entry (count)
THEN first possible available fat entry := count;
LEAVE available fat entry WITH count
FI;
PER;
close action; error stop ("MS-DOS Datentraeger voll"); maxint.
END PROC available fat entry;
BOOL PROC is available entry (INT CONST entry no):
is zero entry.
is zero entry:
IF entry no MOD 2 = 0
THEN (left byte = 0) CAND ((right byte MOD 16) = 0)
ELSE (right byte = 0) CAND ((left byte DIV 16) = 0)
FI.
left byte:
fat byte (first byte no).
right byte:
fat byte (first byte no + 1).
first byte no:
entry no + entry no DIV 2.
END PROC is available entry;
PROC erase fat chain (INT CONST first entry):
INT VAR akt entry no := first entry,
entry := fat entry (akt entry no);
WHILE akt entry no not last chain entry no REP
erase akt entry;
akt entry no := entry;
entry := fat entry (akt entry no)
PER;
erase akt entry.
akt entry no not last chain entry no:
(entry < last entry of fat chain) AND (entry > 1).
erase akt entry:
write fat entry (akt entry no, 0).
END PROC erase fat chain;
PROC write fat entry (INT CONST entry no, value):
fix bytes;
remark write access (fat block of first byte);
remark write access (fat block of second byte);
write value;
update first possible available entry.
fix bytes:
INT VAR first byte no := entry no + entry no DIV 2.
fat block of first byte:
first byte no DIV 512.
fat block of second byte:
second byte no DIV 512.
write value:
IF even entry no
THEN write fat byte (first byte no, value MOD 256);
write fat byte (second byte no,
(right byte DIV 16) * 16 + value DIV 256)
ELSE write fat byte (first byte no,
(left byte MOD 16) + 16 * (value MOD 16));
write fat byte (second byte no, value DIV 16)
FI.
even entry no:
entry no MOD 2 = 0.
second byte no:
first byte no + 1.
left byte:
fat byte (first byte no).
right byte:
fat byte (second byte no).
update first possible available entry:
IF value = 0
THEN first possible available fat entry :=
min (first possible available fat entry, entry no)
FI.
END PROC write fat entry;
INT PROC fat byte (INT CONST no):
replace (convert buffer, 1, word);
IF even byte no
THEN code (convert buffer SUB 1)
ELSE code (convert buffer SUB 2)
FI.
even byte no:
no MOD 2 = 0.
word:
fat [no DIV 2 + 1].
END PROC fat byte;
PROC write fat byte (INT CONST byte no, new value):
read old word;
change byte;
write new word.
read old word:
replace (convert buffer, 1, word).
write new word:
word := convert buffer ISUB 1.
word:
fat [byte no DIV 2 + 1].
change byte:
replace (convert buffer, byte pos, code (new value)).
byte pos:
byte no MOD 2 + 1.
END PROC write fat byte;
PROC copy fat to disk:
INT VAR block no;
FOR block no FROM 0 UPTO number of fat sectors - 1 REP
IF was write access (block no)
THEN write fat block (block no)
FI
PER.
END PROC copy fat to disk;
PROC write fat block (INT CONST fat block no):
INT VAR fat copy no;
INT VAR return code;
disable stop;
FOR fat copy no FROM 0 UPTO number of fat copies -1 REP
write disk block (fat space, ds page no, block no, return code);
IF return code > 0
THEN close action
FI
PER;
remark no write access (block no);
enable stop.
ds page no:
first non dummy ds page + fat block no + 1.
block no:
begin of fat (fat copy no) + fat block no.
END PROC write fat block;
PROC read fat block (INT CONST fat block, BOOL CONST test block):
INT VAR fat copy no;
disable stop;
FOR fat copy no FROM 0 UPTO number of fat copies - 1 REP
clear error;
read disk block (fat space, ds page no, fat block no)
UNTIL NOT is error
PER;
IF is error
THEN close action
FI;
enable stop.
ds page no:
IF test block
THEN first non dummy ds page
ELSE fat block + first non dummy ds page + 1
FI.
fat block no:
begin of fat (fat copy no) + fat block.
END PROC read fat block;
PROC define write access table (BOOL CONST status):
FOR count FROM 1 UPTO number of fat sectors REP
write access [count] := status
PER.
END PROC define write access table;
PROC remark write access (INT CONST fat block no):
write access [fat block no + 1] := TRUE
END PROC remark write access;
PROC remark no write access (INT CONST fat block no):
write access [fat block no + 1] := FALSE
END PROC remark no write access;
BOOL PROC was write access (INT CONST fat block no):
write access [fat block no + 1]
END PROC was write access;
(*COND TEST
PROC dump fat:
IF NOT exists ("fat dump")
THEN open file
FI;
DATASPACE VAR ds := nilspace;
FILE VAR in := sequential file (input, "fat dump"),
out := sequential file (output, ds);
INT VAR i;
TEXT VAR line;
FOR i FROM 0 UPTO number of fat entrys - 1 REP
dump fat entry
PER;
forget ("fat dump", quiet);
copy (ds, "fat dump");
forget (ds).
open file:
in := sequential file (output, "fat dump");
FOR i FROM 0 UPTO number of fat entrys - 1 REP
putline (in, text (i, 4) + ": ")
PER.
dump fat entry:
cout (i);
getline (in, line);
putline (out, line + " " + text (fat entry (i), 4)).
END PROC dump fat;
ENDCOND*)
PROC load dir block (INT CONST block no, BOOL VAR last block):
last block := FALSE;
INT VAR return code;
read disk block (block ds, first non dummy ds page, block no, return code);
IF return code > 0
THEN close action;
io error (return code)
FI;
INT VAR entry no,
thes index;
FOR entry no FROM 0 UPTO dir entrys per block - 1 REP
dir entry := text 32 (block, entry no);
process entry
PER.
process entry:
SELECT pos (""0"."229"", dir entry SUB 1) OF
CASE 1: end of dir search
CASE 2: main dir entry
CASE 3: free entry
OTHERWISE file entry
END SELECT.
end of dir search:
last block := TRUE;
store begin of free area (loc (block no, entry no));
LEAVE load dir block.
main dir entry:
(* no operation *).
free entry:
store in free list (loc (block no, entry no)).
file entry:
SELECT code (dir entry SUB 12) OF
CASE 8: volume label
CASE 16: sub dir entry
OTHERWISE dos file entry
END SELECT.
volume label:
dir.disk label := text (dir entry, 1, 11).
sub dir entry:
dir.dir list.no of entrys INCR 1;
insert (dir thes, name, thes index);
dir list entry := first cluster no.
dos file entry:
IF dir.file list.no of entrys >= max dir entrys
THEN error stop ("Directorytabelle voll")
FI;
dir.file list.no of entrys INCR 1;
insert (file thes, name, thes index);
file list entry.first cluster := first cluster no;
file list entry.date and time := dos date + " " + dos time;
file list entry.size := dos storage;
file list entry.location.msdos block no := block no;
file list entry.location.block entry no := entry no.
name:
IF name post <> ""
THEN name pre + "." + name post
ELSE name pre
FI.
name pre:
compress (subtext (dir entry, 1, 8)).
name post:
compress (subtext (dir entry, 9, 11)).
file list entry:
dir.file list.entry [thes index].
dir list entry:
dir.dir list.entry [thes index].
first cluster no:
code (dir entry SUB 27) + 256 * code (dir entry SUB 28).
dos storage:
real (code (dir entry SUB 29)) +
real (code (dir entry SUB 30)) * 256.0 +
real (code (dir entry SUB 31)) * 65536.0 +
real (code (dir entry SUB 32)) * 16777216.0.
dos date:
day + "." + month + "." + year.
day:
IF code (dir entry SUB 25) MOD 32 < 10
THEN "0" + text (code (dir entry SUB 25) MOD 32)
ELSE text (code (dir entry SUB 25) MOD 32)
FI.
month:
INT VAR dummy := code (dir entry SUB 25) DIV 32 + 8 * (code (dir entry SUB 26) MOD 2);
IF dummy < 10
THEN "0" + text (dummy)
ELSE text (dummy)
FI.
year:
text (80 + code (dir entry SUB 26) DIV 2, 2).
dos time:
hour + ":" + minute.
hour:
dummy := code (dir entry SUB 24) DIV 8;
IF dummy < 10
THEN "0" + text (dummy)
ELSE text (dummy)
FI.
minute:
dummy := code (dir entry SUB 23) DIV 32 + 8 * (code (dir entry SUB 24) MOD 8);
IF dummy < 10
THEN "0" + text (dummy)
ELSE text (dummy)
FI.
END PROC load dir block;
PROC insert dir entry (TEXT CONST name, INT CONST start cluster, REAL CONST used storage):
(* name must be a dos name *)
LOCATION VAR ins pos := free location;
TEXT VAR akt date := date (clock (1)),
akt time := time of day (clock (1));
write disk entry;
write dir struct entry.
write disk entry:
INT VAR return code;
read disk block (block ds, first non dummy ds page, ins pos.msdos block no, return code);
IF return code > 0
THEN close action;
io error (return code)
FI;
prepare name;
dir entry := name pre + name post + archive byte + (10 * ""0"") + dos time +
dos date + starting cluster + storage;
write text 32 (block, dir entry, ins pos.block entry no);
write disk block (block ds, first non dummy ds page,ins pos.msdos block no, return code);
IF return code > 0
THEN close action;
io error (return code)
FI.
prepare name:
TEXT VAR name pre, name post;
IF point pos > 0
THEN name pre := subtext (name, 1, point pos - 1);
name post := subtext (name, point pos + 1);
name pre CAT (8 - LENGTH name pre) * " ";
name post CAT (3 - LENGTH name post) * " "
ELSE name pre := name + (8 - LENGTH name) * " ";
name post := " "
FI.
point pos:
pos (name, ".").
dos time:
code ((minute MOD 8) * 32) + code (8 * hour + minute DIV 8).
hour:
int (subtext (akt time, 1, 2)).
minute:
int (subtext (akt time, 4, 5)).
dos date:
code (32 * (month MOD 8) + day) + code ((year - 80) * 2 + month DIV 8).
day:
int (subtext (akt date, 1, 2)).
month:
int (subtext (akt date, 4, 5)).
year:
int (subtext (akt date, 7, 8)).
starting cluster:
code (start cluster MOD 256) + code (start cluster DIV 256).
storage:
code (int (round (256.0 * frac (used storage / 256.0), 0))) +
code (int (round (frac (floor (used storage / 256.0) / 256.0) * 256.0, 0))) +
code (int (floor (used storage / 65536.0))) +
code (0). (* maximal 16384 K *********************************)
write dir struct entry:
INT VAR thes link;
insert (file thes, name, thes link);
file list entry.location := ins pos;
file list entry.first cluster := start cluster;
file list entry.date and time := akt date + " " + akt time;
file list entry.size := used storage.
file list entry:
dir.filelist.entry [thes link].
END PROC insert dir entry;
PROC delete dir entry (TEXT CONST name):
LOCATION VAR del pos;
get del pos;
erase dir struct entry;
erase disk entry;
store in free list (del pos).
get del pos:
del pos := dir.filelist.entry [link index].location.
link index:
link (file thes, name).
erase dir struct entry:
INT VAR i;
delete (file thes, name, i).
erase disk entry:
INT VAR return code;
read disk block (block ds, first non dummy ds page, del pos.msdos block no, return code);
IF return code > 0
THEN close action;
io error (return code)
FI;
dir entry := text 32 (block, del pos.block entry no);
replace (dir entry, 1, ""229"");
write text 32 (block, dir entry, del pos.block entry no);
write disk block (block ds, first non dummy ds page, del pos.msdos block no, return code);
IF return code > 0
THEN close action;
io error (return code)
FI.
END PROC delete dir entry;
.
file thes:
dir.filelist.thes.
dir thes:
dir.dir list.thes.
(*********************** dir information ******************************)
THESAURUS PROC dir all:
file thes.
END PROC dir all;
BOOL PROC dir contains (TEXT CONST name):
file thes CONTAINS name
END PROC dir contains;
PROC dir list (DATASPACE VAR ds):
enable stop;
open list file;
list files;
list dirs;
write list head.
open list file:
forget (ds);
ds := nilspace;
FILE VAR list file := sequential file (output, ds);
putline (list file, "").
list files:
INT VAR number := 0;
get (file thes, name, number);
WHILE number > 0 REP
generate file list line;
get (file thes, name, number)
PER.
generate file list line:
write (list file, centered name);
write (list file, " ");
write (list file, text (act file entry.size, 11, 0));
write (list file, " Bytes belegt ");
write (list file, act file entry.date and time);
(*COND TEST
write (list file, " +++ ");
write (list file, text (act file entry.first cluster));
ENDCOND*)
line (list file).
list dirs:
number := 0;
get (dir thes, name, number);
WHILE number > 0 REP
generate dir list line;
get (dir thes, name, number)
PER.
generate dir list line:
write (list file, centered name);
write (list file, " <DIR>");
(*COND TEST
write (list file, " +++ ");
write (list file, text (dir.dir list.entry [number]));
ENDCOND*)
line (list file).
centered name:
INT VAR point pos := pos (name, ".");
IF point pos > 0
THEN name pre + "." + name post
ELSE text (name, 12)
FI.
name pre:
text (subtext (name, 1, point pos - 1), 8).
name post:
text (subtext (name, point pos + 1, point pos + 4), 3).
act file entry:
dir.file list.entry [number].
write list head:
head line (list file, head).
head:
"DOS" + disk label string + path string.
disk label string:
IF dir.disk label <> ""
THEN ": " + dir.disk label
ELSE ""
FI.
path string:
IF dir.path <> ""
THEN " PATH: " + dir.path
ELSE ""
FI.
END PROC dir list;
(************ free list handling ******************************************)
LOCATION PROC loc (INT CONST block, entry):
LOCATION : (block, entry)
END PROC loc;
BOOL OP > (LOCATION CONST l, r):
l.msdos block no > r.msdos block no
OR ((l.msdos block no = r.msdos block no) AND
(l.block entry no > r.block entry no) )
END OP >;
OP INCR (LOCATION VAR l):
IF l.block entry no = dir entrys per block -1
THEN l.block entry no := 0;
l.msdos block no INCR 1
ELSE l.block entry no INCR 1
FI.
END OP INCR;
PROC init free list (INT CONST dir root):
dir.freelist.stacktop := 0;
dir.freelist.begin of free area.msdos block no := maxint;
dir.freelist.end of dir.msdos block no := -1;
dir.freelist.dir chain root := dir root.
END PROC init free list;
BOOL PROC dir full:
stack empty AND free area empty AND NOT expansion alloweded.
stack empty:
dir.freelist.stacktop < 1.
free area empty:
dir.freelist.begin of free area > dir.freelist.end of dir.
expansion alloweded:
dir.freelist.dir chain root >= 0.
END PROC dir full;
PROC store in free list (LOCATION CONST free):
dir.freelist.stacktop INCR 1;
dir.freelist.stack [top] := free.
top:
dir.freelist.stacktop.
END PROC store in free list;
PROC store begin of free area (LOCATION CONST begin):
dir.freelist.begin of free area := begin
END PROC store begin of free area;
PROC store end of dir (LOCATION CONST end):
dir.freelist.end of dir := end
END PROC store end of dir;
LOCATION PROC free location:
LOCATION VAR result;
IF dir.freelist.stacktop > 0
THEN pop
ELIF NOT free area empty
THEN first of free area
ELIF expansion alloweded
THEN allocate new dir space;
result := free location
ELSE error stop ("Directorytabelle voll")
FI;
result.
pop:
result := dir.freelist.stack [top];
top DECR 1.
top:
dir.freelist.stack top.
free area empty:
dir.freelist.begin of free area > dir.freelist.end of dir.
first of free area:
result := dir.freelist.begin of free area;
INCR dir.freelist.begin of free area.
expansion alloweded:
dir.freelist.dir chain root >= 0.
END PROC free location;
PROC allocate new dir space:
enable stop;
INT VAR new cluster no := available fat entry;
IF new cluster no < 0
THEN error stop ("MS-DOS Datentraeger voll")
FI;
INT VAR last entry no;
search last entry of fat chain;
write fat entry (new cluster no, 4095);
write fat entry (last entry no, new cluster no);
copy fat to disk;
store begin of free area (loc (first new block, 0));
store end of dir (loc (last new block, dir entrys per block - 1));
init new dir cluster.
search last entry of fat chain:
last entry no := dir.freelist.dir chain root;
WHILE fat entry (last entry no) < last entry of fat chain REP
last entry no := fat entry (last entry no)
PER.
init new dir cluster:
FOR count FROM 0 UPTO dir entrys per block - 1 REP
write text 32 (block, ""0"" + 31 * ""246"", count)
PER;
disable stop;
FOR count FROM first new block UPTO last new block REP
write disk block (block ds, count);
PER.
first new block:
firstblock no of cluster (new cluster no).
last new block:
first block no of cluster (new cluster no) + sectors per cluster - 1.
END PROC allocate new dir space;
(*COND TEST
PROC dump freelist:
command dialogue (FALSE);
FILE VAR f := sequential file (output, "freelistdump");
INT VAR i;
putline (f, "STACKTOP: " + text (fl.stacktop));
putline (f, "STACK:");
FOR i FROM 1 UPTO 16 * number of dir sectors REP
putline (f, " " + text (i, 4) + ": " +
text (fl.stack [i].msdos block no) + ", " +
text (fl.stack [i].block entry no))
PER;
line (f);
putline (f, "BEGIN OF FREE: " + text (fl.begin of free area.msdos block no) +
", " + text (fl.begin of free area.block entry no));
putline (f, "END OF DIR: " + text (fl.end of dir.msdos block no) +
", " + text (fl.end of dir.block entry no)).
fl:
dir.freelist.
END PROC dump free list;
ENDCOND*)
END PACKET dos fat and dir;