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
|
PACKET disk manager DEFINES (* Copyright (C) 1986 *)
(* Frank Klapper *)
disk fetch, (* 07.05.86 *)
disk check,
disk save first phase,
disk save second phase,
disk clear,
disk format,
disk erase,
disk exists,
disk list,
disk all,
disk reserve,
disk free:
LET ascii = 1,
ascii german = 2,
transparent = 3,
ebcdic = 4,
row text = 5,
ds = 6,
atari st = 10;
TEXT VAR file name;
INT VAR mode := 0;
TEXT VAR mode extension;
REAL VAR last access time := 0.0;
PROC disk fetch (TEXT CONST name, DATASPACE VAR file ds):
enable stop;
access disk;
file name := adapted name (name, TRUE);
IF dir contains (file name)
THEN do fetch
ELSE errorstop ("die Datei """ + file name + """ gibt es nicht")
FI;
last access time := clock (1).
do fetch:
SELECT mode OF
CASE ascii, ascii german, atari st, ebcdic, transparent: fetch filemode (file ds, filename, mode)
CASE row text : fetch row textmode (file ds, filename)
CASE ds : fetch dsmode (file ds, filename)
OTHERWISE error stop ("Unzulssige Betriebsart")
END SELECT.
END PROC disk fetch;
PROC disk check (TEXT CONST name):
enable stop;
access disk;
file name := adapted name (name, TRUE);
IF dir contains (file name)
THEN disable stop;
check file (file name);
IF is error
THEN clear error;
error stop ("Fehler beim Prflesen der Datei """ + file name + """")
FI;
ELSE error stop ("""" + file name + """ gibt es nicht")
FI;
last access time := clock (1).
END PROC disk check;
PROC disk save first phase (TEXT CONST name, BOOL VAR overwrite question):
enable stop;
overwrite question := FALSE;
access disk;
file name := adapted name (name, FALSE);
IF dir contains (file name)
THEN overwrite question := TRUE
FI;
last access time := clock (1).
END PROC disk save first phase;
PROC disk save second phase (DATASPACE CONST file ds):
enable stop;
access disk;
erase file if necessary;
do save;
last access time := clock (1).
erase file if necessary:
IF dir contains (file name)
THEN erase table entrys (file name)
FI.
do save:
SELECT mode OF
CASE ascii, ascii german,atari st, ebcdic, transparent: save filemode (file ds, filename, mode)
CASE row text : save row textmode (file ds, filename)
CASE ds : save dsmode (file ds, filename)
OTHERWISE error stop ("Unzulssige Betriebsart")
END SELECT.
END PROC disk save second phase;
(* DOS bekommt die Tabellenparameter von der Diskette
CPM bekommt die Tabellenparameter ber 'reserve' *)
PROC disk clear:
enable stop;
(*COND DOS*)
access disk;
(*ENDCOND*)
(*COND CPM
open eu disk;
open action;
ENDCOND*)
format disk;
last access time := clock (1).
END PROC disk clear;
PROC disk erase (TEXT CONST name):
enable stop;
access disk;
file name := adapted name (name, TRUE);
IF NOT dir contains (file name)
THEN errorstop ("die Datei """ + file name + """ gibt es nicht")
ELSE erase table entrys (file name);
FI;
last access time := clock (1).
END PROC disk erase;
BOOL PROC disk exists (TEXT CONST name):
enable stop;
access disk;
last access time := clock (1);
dir contains (adapted name (name, TRUE)).
END PROC disk exists;
PROC disk list (DATASPACE VAR list ds):
enable stop;
access disk;
dir list (list ds);
last access time := clock (1).
END PROC disk list;
THESAURUS PROC disk all:
enable stop;
access disk;
last access time := clock (1);
dir all.
END PROC disk all;
PROC disk format:
(*COND DOS*)
error stop ("nicht implementiert")
(*ENDCOND*)
(*COND CPM
enable stop;
open eu disk;
open action;
format archive (eu disk format no);
format disk;
last access time := clock (1).
ENDCOND*)
END PROC disk format;
PROC disk reserve (TEXT CONST reserve string):
enable stop;
close action;
last access time := clock (1);
get mode.
get mode:
TEXT VAR mode text;
IF pos (reserve string, ":") = 0
THEN mode text := reserve string;
mode extension := ""
ELSE mode text := subtext (reserve string, 1, pos (reserve string, ":") - 1);
mode extension := subtext (reserve string, pos (reserve string, ":") + 1)
FI;
prepare modetext;
IF mode text = "FILEASCII"
THEN mode := ascii
ELIF mode text = "FILEASCIIGERMAN"
THEN mode := asciigerman
ELIF mode text = "FILEATARIST"
THEN mode := atari st
ELIF modetext = "FILEEBCDIC"
THEN mode := ebcdic
ELIF modetext = "FILETRANSPARENT"
THEN mode := transparent
ELIF mode text = "ROWTEXT"
THEN mode := row text
ELIF mode text = "DS"
THEN mode := ds
ELSE error stop ("Unzulssige Betriebsart")
FI.
prepare modetext:
change all (mode text, " ", "");
INT VAR i;
FOR i FROM 1 UPTO LENGTH mode text REP
IF is lower case
THEN replace (mode text, i, upper case char)
FI
PER.
is lower case:
code (mode text SUB i) > 96 AND code (mode text SUB i) < 123.
upper case char:
code (code (mode text SUB i) - 32).
END PROC disk reserve;
PROC disk free:
disable stop;
close action;
close disk;
reduce cluster buffer.
END PROC disk free;
PROC access disk:
IF action closed COR (last access more than two seconds ago CAND disk changed)
THEN open disk archive
FI.
open disk archive:
close action;
open eu disk;
open disk (mode extension);
open action.
last access more than two seconds ago:
abs (clock (1) - last access time) > 2.0.
END PROC access disk;
END PACKET disk manager;
|
