diff options
Diffstat (limited to 'system/dos/1986/src/fat and dir.dos.hd')
| -rw-r--r-- | system/dos/1986/src/fat and dir.dos.hd | 1190 |
1 files changed, 1190 insertions, 0 deletions
diff --git a/system/dos/1986/src/fat and dir.dos.hd b/system/dos/1986/src/fat and dir.dos.hd new file mode 100644 index 0000000..7d53f41 --- /dev/null +++ b/system/dos/1986/src/fat and dir.dos.hd @@ -0,0 +1,1190 @@ +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 ("ungltige 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;
|