Initial import

1 files changed, 233 insertions, 0 deletions

diff --git a/system/dos/1.8.7/src/save b/system/dos/1.8.7/src/save
new file mode 100644
index 0000000..7e67e91
--- /dev/null
+++ b/system/dos/1.8.7/src/save
@@ -0,0 +1,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;
+