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
|
PACKET save DEFINES (* Copyright (C) 1985, 86, 87 *)
(* Frank Klapper *)
(* 27.04.87 *)
save:
LET ascii = 1,
ascii german = 2,
transparent = 3,
row text = 5,
ds = 6,
atari st = 10,
ibm = 11,
ff = ""12"",
ctrl z = ""26"",
cr lf = ""13""10"",
row text mode length = 4000;
TEXT VAR buffer;
BOUND STRUCT (INT size,
ROW row text mode length TEXT cluster row) VAR cluster struct;
PROC save (TEXT CONST file name, DATASPACE CONST file ds, INT CONST mode):
SELECT mode OF
CASE ascii, ascii german, atari st, ibm, 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 ("Unzulässige Betriebsart")
END SELECT.
END PROC save;
PROC save filemode (DATASPACE CONST file space, TEXT CONST name, INT CONST code type):
enable stop;
open save dos file (name);
FILE VAR file := sequential file (modify, file space);
buffer := "";
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
write next save dos cluster (subtext (buffer, 1, cluster size));
buffer := subtext (buffer, cluster size + 1)
PER
PER;
IF ascii code
THEN buffer CAT ctrl z
FI;
write rest;
close save dos file;
buffer := "".
buffer cat file line:
exec (PROC (TEXT CONST, INT CONST) cat adapted line, file, code type).
ascii code:
(code type = ascii) OR (code type = ascii german).
write rest:
WHILE buffer <> ""
REP write next save dos cluster (subtext (buffer, 1, cluster size));
buffer := subtext (buffer, cluster size + 1)
PER.
END PROC save filemode;
PROC cat adapted line (TEXT VAR line, INT CONST code type):
IF code type = transparent
THEN buffer CAT line
ELSE change esc sequences;
change eumel print chars;
SELECT code type OF
CASE ascii : ascii change
CASE ascii german: ascii german change
CASE atari st : atari st change
CASE ibm : ibm change
END SELECT;
buffer CAT line;
IF (line SUB length (line)) <> ff
THEN buffer CAT cr lf
FI
FI.
change esc sequences:
change all (line, "#page#", ff);
INT VAR p := pos (line, "#");
WHILE p > 0 REP
IF is esc sequence
THEN change (line, p, p+4, coded char)
FI;
p := pos (line, "#", p+1)
PER.
is esc sequence:
LET digits = "0123456789";
(line SUB (p+4)) = "#" CAND pos (digits, line SUB p+1) > 0 CAND
pos (digits, line SUB p+2) > 0 CAND pos (digits, line SUB p+3) > 0.
coded char:
code (int (subtext (line, p+1, p+3))).
change eumel print chars:
p := pos (line, ""220"", ""223"", 1);
WHILE p > 0 REP
replace (line, p, std char);
p := pos (line, ""220"", ""223"", p + 1)
PER.
std char:
"k-# " SUB (code (line SUB p) - 219).
ascii change:
change all (line, "ß", "#251#");
p := pos (line, "Ä", "ü", 1);
WHILE p > 0 REP
change (line, p, p, ersatzdarstellung (line SUB p));
p := pos (line, "Ä", "ü", p + 1)
PER.
ascii german change:
change all (line, "[", "#091#");
change all (line, "\", "#092#");
change all (line, "]", "#093#");
change all (line, "{", "#123#");
change all (line, "|", "#124#");
change all (line, "}", "#125#");
change all (line, "~", "#126#");
change all (line, "ß", ""126"");
p := pos (line, "Ä", "ü", 1);
WHILE p > 0 REP
replace (line, p, umlaut in ascii german);
p := pos (line, "Ä", "ü", p + 1)
PER.
umlaut in ascii german:
"[\]{|}" SUB (code (line SUB p) - 213).
ibm change:
change all (line, "ß", ""225"");
p := pos (line, "Ä", "ü", 1);
WHILE p > 0 REP
replace (line, p, umlaut in ibm);
p := pos (line, "Ä", "ü", p + 1)
PER.
atari st change:
change all (line, "ß", ""158"");
p := pos (line, "Ä", "ü", 1);
WHILE p > 0 REP
replace (line, p, umlaut in ibm);
p := pos (line, "Ä", "ü", p + 1)
PER.
umlaut in ibm:
""142""153""154""132""148""129"" SUB (code (line SUB p) - 213).
END PROC cat adapted line;
TEXT PROC ersatzdarstellung (TEXT CONST char):
TEXT CONST t :: text (code (char SUB 1));
"#" + (3 - length (t)) * "0" + t + "#"
END PROC ersatzdarstellung;
PROC save rowtextmode (DATASPACE CONST space, TEXT CONST name):
enable stop;
open save dos file (name);
init save row textmode;
WHILE line no < cluster struct.size REP
fill buffer;
write next save dos cluster (subtext (buffer, 1, cluster size));
remember rest
PER;
write rest;
close save dos file;
buffer := "".
init save rowtextmode:
cluster struct := space;
buffer := "";
INT VAR line no := 0.
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.
remember rest:
buffer := subtext (buffer, cluster size + 1).
write rest:
WHILE buffer <> ""
REP write next save dos cluster (subtext (buffer, 1, cluster size));
remember rest
PER.
END PROC save rowtextmode;
PROC save ds mode (DATASPACE CONST out ds, TEXT CONST name):
enable stop;
open save dos file (name);
INT VAR page no := first non dummy ds page;
get last allocated ds page;
WHILE page no <= last allocated ds page REP
write next save dos cluster (out ds, page no);
PER;
close save dos file.
get last allocated ds page:
INT VAR last allocated ds page := -1,
i;
FOR i FROM 1 UPTO ds pages (out ds) REP
last allocated ds page := next ds page (out ds, last allocated ds page)
PER.
END PROC save ds mode;
END PACKET save;
|
