Initial import

1 files changed, 371 insertions, 0 deletions

diff --git a/system/dos/1.8.7/src/fetch b/system/dos/1.8.7/src/fetch
new file mode 100644
index 0000000..7cb7571
--- /dev/null
+++ b/system/dos/1.8.7/src/fetch
@@ -0,0 +1,371 @@
+PACKET fetch DEFINES                   (* Copyright (C) 1985, 86, 87 *)
+                                       (* Frank Klapper              *)
+                                       (* 27.04.87                   *) 
+  fetch,
+  check file:
+
+LET ascii             = 1,
+    ascii german      = 2,
+    transparent       = 3,
+    row text          = 5,
+    ds                = 6,
+    dump              = 7,
+    atari st          = 10,
+    ibm               = 11,
+
+  (*line end chars    = ""10""12""13"",*)
+    min line end char = ""10"",
+    max line end char = ""13"",
+    lf                = ""10"",
+    cr                = ""13"",
+    tab code          = 9,
+    lf  code          = 10,
+    ff  code          = 12,
+    cr  code          = 13,
+    ctrl z            = ""26"", 
+
+    page cmd          = "#page#",
+
+    row text length   = 4000,
+    row text type     = 1000;
+
+BOUND STRUCT (INT size,
+              ROW row text length TEXT cluster row) VAR cluster struct;
+
+FILE VAR file;
+
+TEXT VAR buffer;
+INT VAR buffer length;
+
+PROC fetch (TEXT CONST name, DATASPACE VAR file ds, INT CONST mode):
+
+  SELECT mode OF 
+    CASE ascii, ascii german, atari st, ibm, transparent:
+                      fetch filemode (file ds, name, mode)
+    CASE row text   : fetch row textmode (file ds, name)
+    CASE ds         : fetch dsmode       (file ds, name)
+    CASE dump       : fetch dumpmode     (file ds, name)
+    OTHERWISE error stop ("Unzulässige Betriebsart")
+  END SELECT.
+
+END PROC fetch;
+
+PROC fetch filemode (DATASPACE VAR file space, TEXT CONST name,
+                     INT CONST code type):
+  enable stop;
+  initialize fetch filemode;
+  open fetch dos file (name);
+  WHILE NOT was last fetch cluster REP
+    get text of cluster;
+    write lines;
+(***************************************)
+    IF lines (file) > 3900
+      THEN putline (file, ">>> FREMDDATEI FUER EUMEL ZU LANG. ES KÖNNEN DATEN FEHLEN <<<");
+           LEAVE fetch filemode
+    FI;
+(***************************************)
+  UNTIL file end via ctrl z
+  PER;
+  write last line if necessary; 
+  close fetch dos file.
+ 
+initialize fetch filemode:
+  buffer := "";
+  buffer length := 0;
+  forget (file space);
+  file space := nilspace;
+  file := sequential file (output, file space);
+  BOOL VAR file end via ctrl z := FALSE.
+ 
+get text of cluster:
+  cat next fetch dos cluster (buffer);
+  IF ascii code
+    THEN ctrl z is buffer end
+  FI;
+  adapt code (buffer, buffer length + 1, code type);
+  buffer length := length (buffer).
+
+ascii code:
+  (code type = ascii) OR (code type = ascii german).
+
+ctrl z is buffer end:
+  INT  CONST ctrl z pos :: pos (buffer, ctrl z, buffer length + 1);
+  file end via ctrl z := ctrl z pos > 0;
+  IF file end via ctrl z
+    THEN buffer := subtext (buffer, 1, ctrl z pos - 1);
+         buffer length := length (buffer)
+  FI.
+
+write lines:
+  INT VAR line begin pos := 1, line end pos;
+  compute line end pos;
+  WHILE line end pos > 0 REP
+    putline (file, subtext (buffer, line begin pos, line end pos));
+    exec (PROC (TEXT CONST, INT CONST) control char conversion, file, code type);
+    line begin pos := line end pos + 1;
+    compute line end pos
+  PER;
+  buffer := subtext (buffer, line begin pos);
+  buffer length := length (buffer);
+  IF buffer length > 5 000
+    THEN putline (file, buffer);
+         exec (PROC (TEXT CONST, INT CONST) control char conversion, file, code type);
+         buffer := "";
+         buffer length := 0
+  FI.
+
+compute line end pos:
+  line end pos := line begin pos;
+  REP
+    line end pos := pos (buffer, min line end char, max line end char, line end pos);
+    INT CONST line end code :: code (buffer SUB line end pos);
+    SELECT line end code OF
+      CASE lf code: look for cr
+      CASE 11     : line end pos INCR 1
+      CASE cr code: look for lf
+    END SELECT
+  UNTIL line end code <> 11
+  PER.
+
+look for cr:
+  IF line end pos = buffer length
+    THEN line end pos := 0
+  ELIF (buffer SUB line end pos + 1) = cr
+    THEN line end pos INCR 1
+  FI.
+
+look for lf:
+  IF line end pos = buffer length
+    THEN line end pos := 0
+  ELIF (buffer SUB line end pos + 1) = lf
+    THEN line end pos INCR 1
+  FI.
+
+write last line if necessary:
+  IF buffer length > 0
+    THEN putline (file, buffer);
+         exec (PROC (TEXT CONST, INT CONST) control char conversion, file, code type);
+  FI.
+
+END PROC fetch filemode;
+
+PROC adapt code (TEXT VAR text buffer, INT CONST start pos, code type):
+  SELECT code type OF
+    CASE ascii       : cancel bit 8
+    CASE ascii german: cancel bit 8; ascii german adaption
+    CASE atari st    : atari st adaption
+    CASE ibm         : ibm adaption
+  (*CASE transparent : do nothing *)
+  END SELECT.
+
+cancel bit 8:
+  INT VAR set pos := pos (text buffer, ""128"", ""255"", start pos);
+  WHILE set pos > 0 REP
+    replace (text buffer, set pos, seven bit char);
+    set pos := pos (text buffer, ""128"", ""255"", set pos + 1)
+  PER.
+
+seven bit char:
+  code (code (text buffer SUB set pos) AND 127).
+
+ascii german adaption:
+  change all by replace (text buffer, start pos, "[", "Ä");
+  change all by replace (text buffer, start pos, "\", "Ö");
+  change all by replace (text buffer, start pos, "]", "Ü");
+  change all by replace (text buffer, start pos, "{", "ä");
+  change all by replace (text buffer, start pos, "|", "ö");
+  change all by replace (text buffer, start pos, "}", "ü");
+  change all by replace (text buffer, start pos, "~", "ß").
+
+atari st adaption:
+  change all by replace (text buffer, start pos, ""142"", "Ä");
+  change all by replace (text buffer, start pos, ""153"", "Ö");
+  change all by replace (text buffer, start pos, ""154"", "Ü");
+  change all by replace (text buffer, start pos, ""132"", "ä");
+  change all by replace (text buffer, start pos, ""148"", "ö");
+  change all by replace (text buffer, start pos, ""129"", "ü");
+  change all by replace (text buffer, start pos, ""158"", "ß").
+
+ibm adaption:
+  change all by replace (text buffer, start pos, ""142"", "Ä");
+  change all by replace (text buffer, start pos, ""153"", "Ö");
+  change all by replace (text buffer, start pos, ""154"", "Ü");
+  change all by replace (text buffer, start pos, ""132"", "ä");
+  change all by replace (text buffer, start pos, ""148"", "ö");
+  change all by replace (text buffer, start pos, ""129"", "ü");
+  change all by replace (text buffer, start pos, ""225"", "ß").
+
+END PROC adapt code;
+
+PROC change all by replace (TEXT VAR string, INT CONST begin pos,
+                            TEXT CONST old, new):
+
+  INT VAR p := pos (string, old, begin pos);
+  WHILE p > 0 REP
+    replace (string, p, new);
+    p := pos (string, old, p + 1)
+  PER.
+
+END PROC change all by replace;
+
+PROC control char conversion (TEXT VAR string, INT CONST code type):
+
+  IF code type <> transparent
+    THEN code conversion
+  FI.
+
+code conversion:
+  INT VAR p := pos (string, ""0"", ""31"", 1);
+  WHILE p > 0 REP
+    convert char;
+    p := pos (string, ""0"", ""31"", p)
+  PER.
+
+convert char:
+  INT CONST char code := code (string SUB p);
+  SELECT char code OF
+    CASE tab code: expand tab
+    CASE lf  code: change (string, p, p, "")
+    CASE ff  code: change (string, p, p, page cmd)
+    CASE cr  code: change (string, p, p, "")
+    OTHERWISE ersatzdarstellung
+  END SELECT.
+
+expand tab:
+  change (string, p, p, (8 - (p - 1) MOD 8) * " ").
+
+ersatzdarstellung:
+  TEXT CONST t := text (char code);
+  change (string, p, p, "#" + (3 - length (t)) * "0" + t + "#").
+
+END PROC control char conversion;
+
+PROC fetch rowtextmode (DATASPACE VAR file space,
+                        TEXT CONST name):
+  enable stop; 
+  open fetch dos file (name);
+  initialize fetch rowtext mode;
+  WHILE NOT was last fetch cluster REP
+    cluster struct.size INCR 1;
+    cluster struct.cluster row [cluster struct.size] := "";
+    cat next fetch dos cluster (cluster struct.cluster row [cluster struct.size])
+  PER; 
+  close fetch dos file.
+ 
+initialize fetch row text mode:
+  forget (file space);
+  file space := nilspace;
+  cluster struct := file space;
+  type (file space, row text type);
+  cluster struct.size := 0.
+
+END PROC fetch rowtext mode;
+
+PROC fetch ds mode (DATASPACE VAR in ds, TEXT CONST name):
+  enable stop;
+  open fetch dos file (name);
+  init fetch dsmode;
+  WHILE NOT was last fetch cluster REP
+    read next fetch dos cluster (in ds, ds block no);
+  PER; 
+  close fetch dos file.
+ 
+init fetch dsmode:
+  forget (in ds);
+  in ds := nilspace;
+  INT VAR ds block no := 2.
+
+END PROC fetch ds mode;
+
+PROC fetch dumpmode (DATASPACE VAR file space, TEXT CONST name):
+  enable stop; 
+  open fetch dos file (name);
+  initialize fetch dumpmode;
+  WHILE NOT was last fetch cluster REP
+    TEXT VAR cluster buffer := "";
+    cat next fetch dos cluster (cluster buffer);
+    dump cluster
+    UNTIL offset > 50 000.0
+  PER; 
+  close fetch dos file.
+ 
+initialize fetch dump mode:
+  BOOL VAR fertig := FALSE;
+  REAL VAR offset := 0.0;
+  forget (file space);
+  file space := nilspace;
+  file := sequential file (output, file space).
+
+dump cluster:
+  TEXT VAR dump line;
+  INT VAR line, column;
+  FOR line FROM 0 UPTO (cluster size DIV 16) - 1 REP
+    build dump line;
+    putline (file, dump line);
+    offset INCR 16.0
+  UNTIL fertig
+  PER.
+
+build dump line:
+  TEXT VAR char line := "";
+  dump line := text (offset, 6, 0);
+  dump line := subtext (dump line, 1, 5);
+  dump line CAT "   ";
+  FOR column FROM 0 UPTO 7 REP
+    convert char;
+    dump line CAT " "
+  PER;
+  dump line CAT " ";
+  FOR column FROM 8 UPTO 15 REP
+    convert char;
+    dump line CAT " "
+  PER;
+  dump line CAT "  ";
+  dump line CAT char line.
+
+convert char:
+  TEXT CONST char :: cluster buffer SUB (line * 16 + column + 1);
+  IF char = ""
+    THEN fertig := TRUE;
+         dump line CAT "  ";
+         LEAVE convert char
+  FI;
+  INT CONST char code := code (char);
+  LET hex chars = "0123456789ABCDEF";
+  dump line CAT (hex chars SUB (char code DIV 16 + 1));
+  dump line CAT (hex chars SUB (char code MOD 16 + 1));
+  charline CAT show char.
+
+show char:
+  IF (char code > 31 AND char code < 127)
+    THEN char
+    ELSE "." 
+  FI.
+
+END PROC fetch dump mode;
+
+PROC check file (TEXT CONST name):
+  disable stop;
+  DATASPACE VAR test ds := nilspace;
+  enable check file (name, test ds);
+  forget (test ds);
+  IF is error
+    THEN clear error;
+         error stop ("Fehler beim Prüflesen der Datei """ + name + """")
+  FI.
+
+END PROC check file;
+
+PROC enable check file (TEXT CONST name, DATASPACE VAR test ds):
+  enable stop;
+  open fetch dos file (name);
+  WHILE NOT was last fetch cluster REP
+    INT VAR dummy := 2;
+    read next fetch dos cluster (test ds, dummy)
+  PER; 
+  close fetch dos file.
+ 
+END PROC enable check file;
+
+END PACKET fetch;
+