summaryrefslogtreecommitdiff
path: root/system/dos/1986/src/fat and dir.dos.fd
blob: 35cf118c4bae37c3d224247af7476951b524b6f4 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
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 ("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;