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;