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
|
PACKET dos get put DEFINES (* Copyright (C) 1986, 87 *)
(* Frank Klapper *)
(* 11.12.87 *)
log modus,
open dos disk,
close dos disk,
access dos disk,
open fetch dos file,
close fetch dos file,
cat next fetch dos cluster,
read next fetch dos cluster,
was last fetch cluster,
open save dos file,
write next save dos cluster,
close save dos file,
erase dos file,
all dosfiles,
all dossubdirs,
dosfile exists,
dos list,
clear dos disk,
format dos disk:
BOOL VAR log flag := FALSE;
PROC log modus (BOOL CONST status):
log flag := status
END PROC log modus;
(*-------------------------------------------------------------------------*)
LET max cluster size = 8192, (* 8192 * 8 = 64 KB *)
reals per sector = 64;
LET CLUSTER = BOUND STRUCT (ALIGN dummy,
ROW max cluster size REAL cluster row);
CLUSTER VAR cluster;
DATASPACE VAR cluster ds;
INITFLAG VAR cluster ds used := FALSE;
TEXT VAR convert buffer;
INT VAR convert buffer length;
PROC init cluster handle:
IF initialized (cluster ds used)
THEN forget (cluster ds)
FI;
cluster ds := nilspace;
cluster := cluster ds;
convert buffer := "";
convert buffer length := 0.
END PROC init cluster handle;
PROC cat cluster text (REAL CONST cluster no, TEXT VAR destination, INT CONST to):
read disk cluster (cluster ds, 2, cluster no);
init convert buffer;
INT VAR i;
FOR i FROM 1 UPTO sectors per cluster * reals per sector REP
replace (convert buffer, i, cluster.cluster row [i])
PER;
destination CAT subtext (convert buffer, 1, to).
init convert buffer:
IF convert buffer length < cluster size
THEN convert buffer CAT (cluster size - convert buffer length) * "*";
convert buffer length := cluster size
FI.
END PROC cat cluster text;
PROC write text to cluster (REAL CONST cluster no, TEXT CONST string):
IF LENGTH string < cluster size
THEN execute write text (text (string, cluster size))
ELSE execute write text (string)
FI;
write disk cluster (cluster ds, 2, cluster no).
END PROC write text to cluster;
PROC execute write text (TEXT CONST string):
INT VAR i;
FOR i FROM 1 UPTO sectors per cluster * reals per sector REP
cluster.cluster row [i] := string RSUB i
PER.
END PROC execute write text;
(*-------------------------------------------------------------------------*)
BOOL VAR disk open := FALSE;
TEXT VAR act path;
REAL VAR last access time;
PROC open dos disk (TEXT CONST path):
IF log flag THEN dump ("open dos disk", path) FI;
enable stop;
close work;
init cluster handle;
act path := path;
disk open := TRUE
END PROC open dos disk;
PROC close dos disk:
IF log flag THEN dump ("close dos disk", "") FI;
enable stop;
disk open := FALSE;
close work;
init cluster handle; (* Datenraumespeicher freigeben *)
clear fat ds;
init dir ds.
END PROC close dos disk;
PROC access dos disk:
enable stop;
IF NOT disk open
THEN error stop ("DOS-Arbeit nicht eröffnet")
FI;
IF work closed COR (last access more than 5 seconds ago CAND disk changed)
THEN open eu disk; (* hier wird der RERUN Check initialisiert *)
open dos disk;
read fat;
open dir (act path);
last access time := clock (1);
open work
FI.
last access more than 5 seconds ago:
abs (clock (1) - last access time) > 5.0.
disk changed:
IF hd version
THEN FALSE
ELSE last access time := clock (1);
NOT first fat block ok
FI.
END PROC access dos disk;
(*-------------------------------------------------------------------------*)
REAL VAR next fetch cluster,
fetch rest; (* in Bytes *)
PROC open fetch dos file (TEXT CONST file name):
IF log flag THEN dump ("open fetch dos file", file name) FI;
enable stop;
access dos disk;
file info (file name, next fetch cluster, fetch rest).
END PROC open fetch dos file;
BOOL PROC was last fetch cluster:
IF log flag THEN dump ("was last fetch cluster", "") FI;
is last fat chain entry (next fetch cluster) OR fetch rest <= 0.0.
END PROC was last fetch cluster;
PROC cat next fetch dos cluster (TEXT VAR buffer):
IF log flag THEN dump ("cat next fetch dos cluster", "") FI;
enable stop;
IF was last fetch cluster
THEN error stop ("fetch nach Dateiende")
FI;
IF fetch rest < real (cluster size)
THEN cat cluster text (next fetch cluster, buffer, int (fetch rest));
fetch rest := 0.0
ELSE cat cluster text (next fetch cluster, buffer, cluster size);
fetch rest DECR real (cluster size)
FI;
last access time := clock (1);
next fetch cluster := fat entry (next fetch cluster).
END PROC cat next fetch dos cluster;
PROC read next fetch dos cluster (DATASPACE VAR read ds, INT VAR start page):
IF log flag THEN dump ("read next fetch dos cluster", start page) FI;
enable stop;
IF was last fetch cluster
THEN error stop ("fetch nach Dateiende")
FI;
read disk cluster (read ds, start page, next fetch cluster);
last access time := clock (1);
start page INCR sectors per cluster;
next fetch cluster := fat entry (next fetch cluster);
IF fetch rest < real (cluster size)
THEN fetch rest := 0.0
ELSE fetch rest DECR real (cluster size)
FI.
END PROC read next fetch dos cluster;
PROC close fetch dos file:
IF log flag THEN dump ("close fetch dos file", "") FI;
END PROC close fetch dos file;
(*-------------------------------------------------------------------------*)
TEXT VAR save name;
REAL VAR first save cluster,
last save cluster,
save size;
PROC open save dos file (TEXT CONST file name):
IF log flag THEN dump ("open save dos file", file name) FI;
enable stop;
access dos disk;
IF file exists (file name) OR subdir exists (file name)
THEN error stop ("die Datei """ + file name + """ gibt es schon")
FI;
save name := file name;
first save cluster := -1.0;
save size := 0.0.
END PROC open save dos file;
PROC write next save dos cluster (TEXT CONST buffer):
IF log flag THEN dump ("write next save dos cluster", "") FI;
enable stop;
REAL CONST save cluster := available fat entry;
write text to cluster (save cluster, buffer);
last access time := clock (1);
save size INCR real (LENGTH buffer);
IF first save cluster < 2.0
THEN first save cluster := save cluster
ELSE fat entry (last save cluster, save cluster)
FI;
fat entry (save cluster, last fat chain entry);
last save cluster := save cluster.
END PROC write next save dos cluster;
PROC write next save dos cluster (DATASPACE CONST save ds, INT VAR start page):
IF log flag THEN dump ("write next save dos cluster", start page) FI;
enable stop;
REAL CONST save cluster := available fat entry;
write disk cluster (save ds, start page, save cluster);
last access time := clock (1);
start page INCR sectors per cluster;
save size INCR real (cluster size);
IF first save cluster < 2.0
THEN first save cluster := save cluster
ELSE fat entry (last save cluster, save cluster)
FI;
fat entry (save cluster, last fat chain entry);
last save cluster := save cluster.
END PROC write next save dos cluster;
PROC close save dos file:
IF log flag THEN dump ("close save dos file", "") FI;
enable stop;
IF first save cluster < 2.0
THEN LEAVE close save dos file
FI;
fat entry (last save cluster, last fat chain entry);
write fat;
insert dir entry (save name, first save cluster, save size);
last access time := clock (1).
END PROC close save dos file;
(*-------------------------------------------------------------------------*)
PROC erase dos file (TEXT CONST file name):
IF log flag THEN dump ("erase dos file", file name) FI;
enable stop;
access dos disk;
REAL VAR first cluster, size;
file info (file name, first cluster, size);
delete dir entry (file name);
erase fat chain (first cluster);
write fat;
last access time := clock (1).
END PROC erase dos file;
(*-------------------------------------------------------------------------*)
THESAURUS PROC all dosfiles:
IF log flag THEN dump ("all dosfile", "") FI;
enable stop;
access dos disk;
all files.
END PROC all dosfiles;
THESAURUS PROC all dossubdirs:
IF log flag THEN dump ("all subdirs", "") FI;
enable stop;
access dos disk;
all subdirs.
END PROC all dossubdirs;
BOOL PROC dos file exists (TEXT CONST file name):
IF log flag THEN dump ("dos file exists", file name) FI;
enable stop;
access dos disk;
file exists (file name).
END PROC dos file exists;
PROC dos list (DATASPACE VAR list ds):
IF log flag THEN dump ("dos list", "") FI;
enable stop;
access dos disk;
dir list (list ds).
END PROC dos list;
(*-------------------------------------------------------------------------*)
PROC clear dos disk:
IF log flag THEN dump ("clear dos disk", "") FI;
enable stop;
IF hd version
THEN error stop ("nicht implementiert")
ELSE access dos disk;
format dir;
format fat;
last access time := clock (1)
FI.
END PROC clear dos disk;
PROC format dos disk (INT CONST format code):
IF log flag THEN dump ("format dos disk (" + text (format code) + ")", "") FI;
enable stop;
IF NOT disk open
THEN error stop ("DOS-Arbeit nicht eröffnet")
FI;
IF hd version
THEN error stop ("nicht implementiert")
ELSE do format
FI.
do format:
IF bpb exists (format code)
THEN close work;
format archive (format code);
open eu disk;
write bpb (format code);
open dos disk;
format dir; (* enthält 'open dir' *)
format fat; (* enthält 'read fat' *)
open work
ELSE error stop ("Format unzulässig")
FI;
last access time := clock (1).
END PROC format dos disk;
END PACKET dos get put;
|
