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
|
PACKET dos single DEFINES (* Copyright (C) 1985 *)
(* Frank Klapper *)
(* 11.09.87 *)
/,
dos,
provide dos channel,
archive,
reserve,
release,
save,
fetch,
erase,
check,
exists,
ALL,
SOME,
clear,
list,
format:
LET std archive channel = 31,
main channel = 1;
INT VAR dos channel := std archive channel;
INT VAR fetch save modus;
TYPE DOSTASK = TEXT;
DOSTASK CONST dos := "DOS";
OP := (DOSTASK VAR d, TEXT CONST t):
CONCR (d) := t
END OP :=;
DOSTASK OP / (TEXT CONST text):
DOSTASK VAR d;
CONCR (d) := text;
d
END OP /;
BOOL PROC is dostask (DOSTASK CONST d):
CONCR (d) = "DOS"
END PROC is dos task;
PROC provide dos channel (INT CONST channel no):
dos channel := channel no
END PROC provide dos channel;
DATASPACE VAR space := nilspace;
forget (space);
PROC reserve (TEXT CONST string, DOSTASK CONST task):
IF is dostask (task)
THEN fetch save modus := save fetch mode (string);
open dos disk (path (string))
ELSE error stop ("die angesprochene Task existiert nicht")
FI.
END PROC reserve;
PROC archive (TEXT CONST string, DOSTASK CONST task):
reserve (string, task)
END PROC archive;
PROC release (DOSTASK CONST task):
IF is dos task (task)
THEN close dos disk
ELSE error stop ("die angesprochene Task existiert nicht")
FI.
END PROC release;
PROC fetch (TEXT CONST name, DOSTASK CONST from):
IF is dostask (from)
THEN fetch from dos disk
ELSE error stop ("die angesprochene Task existiert nicht")
FI.
fetch from dos disk:
IF NOT exists (name) COR overwrite permitted
THEN do fetch
FI.
overwrite permitted:
say ("eigene Datei """) ;
say (name) ;
yes (""" auf der Diskette ueberschreiben").
do fetch:
last param (name);
disable stop;
continue (dos channel);
fetch (dos name (name, read modus), space, fetch save modus);
continue (main channel);
IF NOT is error
THEN forget (name, quiet);
copy (space, name)
FI;
forget (space).
END PROC fetch;
PROC erase (TEXT CONST name, DOSTASK CONST task):
IF is dos task (task)
THEN do erase dos file
ELSE error stop ("die angesprochene Task existiert nicht")
FI.
do erase dos file:
IF NOT exists (name, /"DOS")
THEN error stop ("die Datei """ + name + """ gibt es nicht")
ELIF yes ("""" + dos name (name, read modus)+ """ auf Der Diskette loeschen")
THEN disable stop;
continue (dos channel);
erase dos file (dos name (name, read modus));
continue (main channel)
FI.
END PROC erase;
PROC save (TEXT CONST name, DOSTASK CONST task):
IF is dos task (task)
THEN save to dos disk
ELSE error stop ("die angesprochene Task existiert nicht")
FI.
save to dos disk:
TEXT CONST save file name :: dos name (name, write modus);
disable stop;
continue (dos channel);
IF NOT dos file exists (save file name) COR overwrite permitted
THEN IF dos file exists (save file name)
THEN erase dos file (save file name)
FI;
save (save file name, old (name), fetch save modus);
FI;
continue (main channel).
overwrite permitted:
continue (main channel);
BOOL CONST result :: yes ("""" + save file name + """ auf der Diskette ueberschreiben");
continue (dos channel);
result.
END PROC save;
PROC check (TEXT CONST name, DOSTASK CONST from):
IF is dostask (from)
THEN disable stop;
continue (dos channel);
check file (dos name (name, read modus));
continue (main channel)
ELSE error stop ("die angesprochene Task existiert nicht")
FI.
END PROC check;
BOOL PROC exists (TEXT CONST name, DOSTASK CONST task):
IF is dos task (task)
THEN disable stop;
continue (dos channel);
BOOL VAR dummy := dos file exists (dos name (name, read modus));
continue (main channel);
enable stop;
dummy
ELSE error stop ("die angesprochene Task existiert nicht"); FALSE
FI.
END PROC exists;
PROC list (DOSTASK CONST from):
forget (space);
space := nilspace;
FILE VAR list file := sequential file (output, space);
list (list file, from);
modify (list file);
show (list file);
forget (space).
ENDPROC list;
PROC list (FILE VAR list file, DOSTASK CONST from):
IF is dos task (from)
THEN list dos disk
ELSE error stop ("die angesprochene Task existiert nicht")
FI.
list dos disk:
disable stop;
continue (dos channel);
dos list (space);
continue (main channel);
enable stop;
output (list file);
FILE VAR list source := sequential file (output, space);
TEXT VAR line;
WHILE NOT eof (list source) REP
getline (list source, line);
putline (list file, line)
PER.
END PROC list;
THESAURUS OP ALL (DOSTASK CONST task):
IF is dos task (task)
THEN disable stop;
continue (dos channel);
THESAURUS VAR dummy := all dos files;
continue (main channel);
enable stop;
dummy
ELSE error stop ("die angesprochene Task existiert nicht"); empty thesaurus
FI.
END OP ALL;
THESAURUS OP SOME (DOSTASK CONST task):
IF is dos task (task)
THEN disable stop;
continue (dos channel);
THESAURUS VAR dummy := all dos files;
continue (main channel);
enable stop;
SOME dummy
ELSE error stop ("die angesprochene Task existiert nicht"); empty thesaurus
FI.
END OP SOME;
PROC clear (DOSTASK CONST task):
IF is dos task (task)
THEN clear disk
ELSE error stop ("die angesprochene Task existiert nicht")
FI.
clear disk:
disable stop;
IF yes ("Diskette loeschen")
THEN continue (dos channel);
clear dos disk;
continue (main channel)
FI.
END PROC clear;
PROC format (INT CONST format code, DOSTASK CONST task):
IF is dos task (task)
THEN format disk
ELSE error stop ("die angesprochene Task existiert nicht")
FI.
format disk:
disable stop;
IF yes ("Diskette formatieren")
THEN continue (dos channel);
format dos disk (format code);
continue (main channel)
FI.
END PROC format;
END PACKET dos single;
|
