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;