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
|
PACKET save DEFINES (* Copyright (C) 1985 *)
(* Frank Klapper *)
(* 07.05.86 *)
save filemode,
save rowtextmode,
save dsmode:
LET ascii = 1,
ascii german = 2,
transparent = 3,
ebcdic = 4,
atari st = 10;
LET ascii ctrl z = ""26"";
LET row text mode length = 4000;
CLUSTER VAR cluster;
DATASPACE VAR cluster space;
BOUND STRUCT (INT size,
ROW row text mode length TEXT cluster row) VAR cluster struct;
REAL VAR storage;
TEXT VAR cr lf, ff;
TEXT VAR buffer;
PROC save filemode (DATASPACE CONST file space,
TEXT CONST name,
INT CONST code type):
disable stop;
cluster space := nilspace;
cluster := cluster space;
enable save filemode (file space, name, code type);
buffer := "";
forget (cluster space).
END PROC save filemode;
PROC enable save filemode (DATASPACE CONST file space,
TEXT CONST name,
INT CONST code type):
enable stop;
open save (name);
init save filemode;
INT VAR line no;
FOR line no FROM 1 UPTO lines (file) REP
to line (file, line no);
buffer cat file line;
WHILE LENGTH buffer >= cluster size REP
copy buffer to cluster;
write disk cluster (cluster space, first non dummy ds page, next save cluster no);
remember rest
PER
PER;
cat ctrl z if necessary;
write rest;
close save (storage).
init save filemode:
storage := 0.0;
FILE VAR file := sequential file (modify, file space);
SELECT code type OF
CASE ascii, ascii german, atari st, transparent: cr lf := ""13""10""; ff := ""12""
CASE ebcdic: cr lf := ""13"%"; ff := ""12""
END SELECT;
buffer := "".
buffer cat file line:
exec (PROC (TEXT CONST, INT CONST) cat adapted line, file, code type).
copy buffer to cluster:
write text (cluster, buffer);
storage INCR real (min (cluster size, LENGTH buffer)).
remember rest:
buffer := subtext (buffer, cluster size + 1).
write rest:
WHILE buffer <> ""
REP copy buffer to cluster;
write disk cluster (cluster space, first non dummy ds page, next save cluster no);
remember rest
PER.
cat ctrl z if necessary:
IF code type <> ebcdic
THEN buffer CAT ascii ctrl z
FI.
END PROC enable save filemode;
PROC cat adapted line (TEXT VAR line, INT CONST code type):
IF subtext (line, 1, 6) = "#page#"
THEN buffer CAT ff;
LEAVE cat adapted line
FI;
SELECT code type OF
CASE transparent: (* no operation *)
CASE ascii: change eumel print chars; ascii change
CASE ascii german: change eumel print chars; ascii german change
CASE atari st: change eumel print chars; atari st change
CASE ebcdic: change eumel print chars; eumel to ebcdic with substitution (line)
END SELECT;
buffer CAT line;
buffer CAT cr lf.
change eumel print chars:
INT VAR char pos := pos (line, ""220"", ""223"", 1);
WHILE char pos > 0 REP
replace (line, char pos, std char);
char pos := pos (line, ""220"", ""223"", char pos + 1)
PER.
std char:
SELECT code (line SUB char pos) OF
CASE 220: "k"
CASE 221: "-"
CASE 222: "#"
CASE 223: " "
OTHERWISE ""
END SELECT.
ascii change:
change all (line, ""251"", "#251#");
char pos := pos (line, "Ä", "ü", 1);
WHILE char pos > 0 REP
line := subtext (line, 1, char pos - 1) + ersatzdarstellung + subtext (line, char pos + 1);
char pos := pos (line, "Ä", "ü", char pos + 1)
PER.
ascii german change:
char pos := pos (line, "[", "]", 1);
WHILE char pos > 0 REP
line := subtext (line, 1, char pos - 1) + ersatzdarstellung + subtext (line, char pos + 1);
char pos := pos (line, "[", "]", char pos + 1)
PER;
char pos := pos (line, "{", "}", 1);
WHILE char pos > 0 REP
line := subtext (line, 1, char pos - 1) + ersatzdarstellung + subtext (line, char pos + 1);
char pos := pos (line, "{", "}", char pos + 1)
PER;
change all (line, ""251"", "~");
char pos := pos (line, "Ä", "ü", 1);
WHILE char pos > 0 REP
replace (line, char pos, umlaut in ascii german);
char pos := pos (line, "Ä", "ü", char pos + 1)
PER.
atari st change:
change all (line, "ß", ""158"");
char pos := pos (line, "Ä", "ü", 1);
WHILE char pos > 0 REP
replace (line, char pos, umlaut in atari st);
char pos := pos (line, "Ä", "ü", char pos + 1)
PER.
ersatzdarstellung:
TEXT VAR char code := text (code (line SUB char pos));
"#" + (3 - LENGTH char code) * "0" + char code + "#".
umlaut in ascii german:
SELECT code (line SUB char pos) OF
CASE 214: "["
CASE 215: "\"
CASE 216: "]"
CASE 217: "{"
CASE 218: "|"
CASE 219: "}"
OTHERWISE ""
END SELECT.
umlaut in atari st:
SELECT code (line SUB char pos) OF
CASE 214: ""142""
CASE 215: ""153""
CASE 216: ""154""
CASE 217: ""132""
CASE 218: ""148""
CASE 219: ""129""
OTHERWISE ""
END SELECT.
END PROC cat adapted line;
PROC save rowtextmode (DATASPACE CONST space,
TEXT CONST name):
disable stop;
cluster space := nilspace;
cluster := cluster space;
enable save rowtext mode (space, name);
forget (cluster space).
END PROC save rowtextmode;
PROC enable save rowtextmode (DATASPACE CONST space,
TEXT CONST name):
enable stop;
open save (name);
init save row textmode;
WHILE line no < cluster struct.size REP
fill buffer;
copy buffer to cluster;
write disk cluster (cluster space, first non dummy ds page, next save cluster no);
remember rest
PER;
write rest;
close save (storage).
init save rowtextmode:
storage := 0.0;
cluster struct := space;
INT VAR line no := 0;
TEXT VAR buffer := "".
fill buffer:
WHILE line no < cluster struct.size AND NOT buffer full REP
line no INCR 1;
buffer CAT cluster struct.cluster row [line no]
PER.
buffer full:
LENGTH buffer >= cluster size.
copy buffer to cluster:
write text (cluster, buffer);
storage INCR real (min (cluster size, LENGTH buffer)).
remember rest:
buffer := subtext (buffer, cluster size + 1).
write rest:
WHILE buffer <> ""
REP copy buffer to cluster;
write disk cluster (cluster space, first non dummy ds page, next save cluster no);
remember rest
PER.
END PROC enable save rowtextmode;
PROC save ds mode (DATASPACE CONST ds,
TEXT CONST name):
disable stop;
enable save ds mode (ds, name).
END PROC save ds mode;
PROC enable save ds mode (DATASPACE CONST ds,
TEXT CONST name):
enable stop;
open save (name);
INT VAR page no := first non dummy ds page;
get last allocated ds page;
WHILE page no <= last allocated ds page REP
write disk cluster (ds, page no, next save cluster no);
page no INCR sectors per cluster
PER;
close save (size).
get last allocated ds page:
INT VAR last allocated ds page := -1,
i;
FOR i FROM 1 UPTO ds pages (ds) REP
last allocated ds page := next ds page (ds, last allocated ds page)
PER.
size:
real (last allocated ds page - first non dummy ds page + 1) * 512.0.
END PROC enable save ds mode;
END PACKET save;
|
