Initial import

20 files changed, 4807 insertions, 0 deletions

diff --git a/system/setup/3.1/source-disk b/system/setup/3.1/source-disk
new file mode 100644
index 0000000..1421205
--- /dev/null
+++ b/system/setup/3.1/source-disk
@@ -0,0 +1 @@
+setup/setup-src-3.1_shard-4.9_1989-04-18.img
diff --git a/system/setup/3.1/src/AT-4.x b/system/setup/3.1/src/AT-4.x
new file mode 100644
index 0000000..86962e3
--- /dev/null
+++ b/system/setup/3.1/src/AT-4.x
diff --git a/system/setup/3.1/src/SHARD b/system/setup/3.1/src/SHARD
new file mode 100644
index 0000000..c1619b3
--- /dev/null
+++ b/system/setup/3.1/src/SHARD
diff --git a/system/setup/3.1/src/SHard Basis b/system/setup/3.1/src/SHard Basis
new file mode 100644
index 0000000..60800a1
--- /dev/null
+++ b/system/setup/3.1/src/SHard Basis
diff --git a/system/setup/3.1/src/bootblock b/system/setup/3.1/src/bootblock
new file mode 100644
index 0000000..00b56a2
--- /dev/null
+++ b/system/setup/3.1/src/bootblock
diff --git a/system/setup/3.1/src/configuration b/system/setup/3.1/src/configuration
new file mode 100644
index 0000000..139597f
--- /dev/null
+++ b/system/setup/3.1/src/configuration
@@ -0,0 +1,2 @@
+
+
diff --git a/system/setup/3.1/src/neu b/system/setup/3.1/src/neu
new file mode 100644
index 0000000..a89779c
--- /dev/null
+++ b/system/setup/3.1/src/neu
@@ -0,0 +1,34 @@
+TEXT VAR t1 :: "SHardmodul Floppy", t2 :: "FLOPPY.EXE"; 
+reserve ("ds", /"DOS"); 
+IF yes("init",FALSE)
+  THEN init modules list; 
+FI;
+THESAURUS VAR th1 :: all modules, th2 :: empty thesaurus; 
+WHILE yes ("noch Module holen", TRUE) REP 
+t2 := ONE /"DOS"; 
+t1 := ONE (th1); 
+editget (t1); line; 
+forget (t1); 
+fetch (t2, /"DOS"); 
+copy (t2, t1);  last param (t1); 
+th2 := th2 + t1
+PER;
+WHILE yes ("jetzt noch andere holen", FALSE) REP 
+  t2 := ONE /"DOS";
+  t1 := ONE all;
+editget (t1); line; 
+forget (t1); 
+fetch (t2, /"DOS"); 
+copy (t2, t1);  last param (t1); 
+PER;
+release (/"DOS");
+
+linkshard module (th2);
+ 
+
+
+
+
+
+
+
diff --git a/system/setup/3.1/src/setup eumel -1: mini eumel dummies b/system/setup/3.1/src/setup eumel -1: mini eumel dummies
new file mode 100644
index 0000000..a1fa2b5
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel -1: mini eumel dummies
@@ -0,0 +1,28 @@
+ 
+PACKET setup eumel mini eumel dummies    (* Stand : 08.04.88 *)
+DEFINES FILE, 
+        sequentialfile, 
+        output, 
+        putline, 
+        :=,
+        run : 
+ 
+TYPE FILE = INT;
+ 
+INT CONST output :: 0; 
+
+OP := (FILE VAR a, FILE CONST b):
+
+END OP :=;
+FILE PROC sequentialfile (INT CONST a, TEXT CONST b) : 
+  FILE : (0).
+END PROC sequentialfile; 
+ 
+PROC putline (FILE CONST a, TEXT CONST b): 
+END PROC putline; 
+ 
+PROC run (TEXT CONST a): 
+END PROC run; 
+ 
+END PACKET setup eumel mini eumel dummies;
+
diff --git a/system/setup/3.1/src/setup eumel 0: -M b/system/setup/3.1/src/setup eumel 0: -M
new file mode 100644
index 0000000..bad5028
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 0: -M
@@ -0,0 +1,32 @@
+PACKET setup eumel multiuserspecials       (* Copyright (C) 1985, 1988 *)
+DEFINES terminal setup,                    (* Martin Schönbeck, Spenge *)
+        indirect list,                     (* Lutz Prechelt, Karlsruhe *)
+        setup testing :                    (* Stand: 07.05.88   2.1    *)
+
+LET sysout file = "sysout";
+
+BOOL VAR setup test version :: FALSE;
+
+PROC terminal setup: 
+  (* It took about 2 manmonths to debug this procedure ! *)
+END PROC terminal setup; 
+ 
+PROC indirect list (BOOL CONST make indirection) :
+  IF make indirection
+  THEN sysout (sysout file);
+  ELSE sysout ("");
+       print (sysout file);
+       forget (sysout file, quiet)
+  FI.
+END PROC indirect list;
+
+PROC setup testing (BOOL CONST new ):
+   setup test version := new;
+END PROC setup testing;
+
+BOOL PROC setup testing :
+  setup test version.
+END PROC setup testing;
+
+END PACKET setup eumel multiuserspecials;
+
diff --git a/system/setup/3.1/src/setup eumel 0: -S b/system/setup/3.1/src/setup eumel 0: -S
new file mode 100644
index 0000000..50a8330
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 0: -S
@@ -0,0 +1,35 @@
+PACKET setup eumel singleuserspecials      (* Copyright (C) 1985, 1988 *)
+DEFINES terminal setup,                    (* Martin Schönbeck, Spenge *)
+        break,                             (* Lutz Prechelt, Karlsruhe *)
+        indirect list,                     (* Stand: 07.05.88   2.1    *)
+        setup testing :
+
+LET printer channel  = 15,
+    screen  channel  =  1;
+
+ 
+PROC break (QUIET CONST quiet): 
+END PROC break; 
+ 
+PROC terminal setup:
+  setup
+END PROC terminal setup;
+
+PROC indirect list (BOOL CONST make indirection) :
+  (* Man beachte, daß es nicht besonders sinnvoll ist, auf einem Drucker
+     cout zu machen...
+  *)
+  IF make indirection
+  THEN continue (printer channel)
+  ELSE continue (screen channel)  FI.
+END PROC indirect list;
+
+PROC setup testing (BOOL CONST new):
+END PROC setup testing;
+
+BOOL PROC setup testing :
+  FALSE.
+END PROC setup testing;
+
+END PACKET setup eumel singleuserspecials;
+
diff --git a/system/setup/3.1/src/setup eumel 1: basisoperationen b/system/setup/3.1/src/setup eumel 1: basisoperationen
new file mode 100644
index 0000000..a705ff4
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 1: basisoperationen
@@ -0,0 +1,1071 @@
+
+(**************************************************************************)
+(***** Grundoperationen für den Setup-Eumel (Modul-SHard) *****************)
+(***** Copyright (c) 1985 - 1988 by                       *****************)
+(***** Martin Schönbeck, Spenge / Lutz Prechelt, Karlsruhe ****************)
+(**************************************************************************)
+
+(* Fünf Pakete :
+   1. setup eumel basisoperationen
+         Handhabung von 16-Bit unsigned Werten in INTs und Editierfunktionen
+   2. splitting
+         Worttrennung von REALs und Bytetrennung von INTs
+   3. basic block io
+         blockin und blockout auf Datenräume mit retrys und Fehlermeldungen
+   4. write file
+         Direktes Schreiben/Lesen eines Datenraums in/aus eine(r) Partition
+   5. thesaurus utilities
+         ONE,CERTAIN,certain  zum Aussuchen aus Thesauri ohne Editor
+*)
+
+
+PACKET setup eumel basisoperationen   (* (C) 1987 Lutz Prechelt, Karlsruhe *)
+DEFINES editget, editgetchar,         (* Stand: 08.04.88   Version 1.1     *)
+        yes, no,                      (* Eumel 1.8.0                       *)
+        direction, reset direction,
+        data error, write head,
+        LIST, list, CAT, emptylist,
+        (*UNSIGNED,*) unsigned, int, text,
+        RANGE, range, everywhere,
+        ANDXOR, andxor,
+        dec, hex, bin,
+        IN,
+        := ,
+        put :
+ 
+(* Dieses Paket stellt die Basisfunktionen für den Elanteil des Setup-SHard 
+   zur Verfügung. 
+   Es ist dies im Wesentlichen die Handhabung von INT-Werten auch in Binär- 
+   und Hexdarstellung, sowie die Plausibilitätsprüfung mit Fehleranzeigen. 
+*) 
+ 
+TYPE    LIST     = TEXT,    (* TEXT aus mehreren UNSIGNEDen (replace/ISUB) *)
+        RANGE    = STRUCT (UNSIGNED low, high), 
+        ANDXOR   = STRUCT (UNSIGNED and mask, xor mask);
+
+LET     UNSIGNED   = INT;     (* 16 bit *)
+
+TYPE    REPRESENTATION = INT;
+
+REPRESENTATION CONST dec :: REPRESENTATION : (10),
+                     hex :: REPRESENTATION : (16), 
+                     bin :: REPRESENTATION :  (2);
+
+(* Diese Typen dienen zur Wertprüfung bei der Eingabe. *) 
+ 
+LET    up      = ""3"",
+       down    = ""10"",
+       right   = ""2"",
+       error   = ""0"";  (* fuer current direction *)
+
+TEXT VAR current direction :: ""; (* enthaelt up oder down oder "" *)
+BOOL VAR direction valid :: FALSE;
+
+TEXT CONST hex digits :: "0123456789abcdef"; 
+ 
+(********************* Zuweisungen *************************************) 
+
+OP := (LIST VAR a, LIST CONST b) : 
+  CONCR (a) := CONCR (b) 
+END OP := ; 
+ 
+OP := (RANGE VAR a, RANGE CONST b) : 
+  a.low  := b.low; 
+  a.high := b.high
+END OP := ; 
+
+OP := (ANDXOR VAR a, ANDXOR CONST b) : 
+  a.and mask := b.and mask;
+  a.xor mask := b.xor mask
+END OP := ; 
+ 
+OP := (REPRESENTATION VAR a, REPRESENTATION CONST b) : 
+  CONCR (a) := CONCR (b) 
+END OP := ; 
+ 
+(************************** IN ******************************************) 
+ 
+BOOL OP IN (UNSIGNED CONST a, LIST CONST l) : 
+  INT CONST p :: pos (CONCR (l), textform (a)); 
+  p > 0 AND p MOD 2 = 1  (* enthalten und word-aligned *) 
+END OP IN; 
+ 
+BOOL OP IN (UNSIGNED CONST a, RANGE CONST b) : 
+  (* RANGES sind inklusiv ihrer Grenzen *)
+  reverse (textform (a)) <= reverse (textform (b.high)) AND 
+  reverse (textform (a)) >= reverse (textform (b.low)) 
+END OP IN;
+ 
+BOOL OP IN (UNSIGNED CONST a, ANDXOR CONST mask) : 
+  (* Es muss (Bitweise) (a AND andmask) XOR xormask = 0 sein *)
+  ((a AND mask.and mask) XOR mask.xor mask) = 0 
+END OP IN;
+
+(************************* Konstruktoren ********************************) 
+ 
+LIST CONST emptylist :: LIST : (""); 
+ 
+LIST PROC list (TEXT CONST list text) :
+  (* Konstruiert aus einer in Textform gegebenen Liste von Unsigneds eine
+     LIST. Die einzelnen Werte sind durch Komma getrennt und dürfen in
+     dezimaler, sedezimaler oder binärer Darstellung notiert sein. 
+  *)
+  TEXT VAR t :: compress (list text);
+  IF t = "" THEN emptylist
+  ELSE TEXT VAR result :: ""; 
+       REPEAT 
+         INT VAR first comma pos :: pos (t, ","); 
+         IF first comma pos = 0 THEN first comma pos := LENGTH t + 1  FI; 
+         result CAT textform (unsigned (subtext (t, 1, first comma pos - 1)));
+         t := subtext (t, first comma pos + 1) 
+       UNTIL t = ""  PER;
+       LIST : (result)
+  FI 
+END PROC list;
+
+(*UNSIGNED PROC unsigned (INT CONST sixteen bits) :
+  sixteen bits
+END PROC unsigned;*)
+
+UNSIGNED PROC unsigned (TEXT CONST number) : 
+  INT  VAR result :: 0, i;
+  TEXT VAR t :: compress (to lower (number)), type :: t SUB LENGTH t; 
+  IF pos ("hb" + hex digits, type) = 0 
+  THEN set conversion (FALSE); 
+       LEAVE unsigned WITH 0 
+  FI; 
+  IF type = "h" 
+  THEN convert hex 
+  ELIF type = "b" 
+  THEN convert binary
+  ELSE convert decimal  FI;
+  result. 
+ 
+convert hex : 
+  FOR i FROM 1 UPTO LENGTH t - 1 REP
+    TEXT CONST c :: t SUB i;
+    IF pos (hex digits, c) = 0
+    THEN set conversion (FALSE);
+         LEAVE unsigned WITH 0
+    FI;
+    rotate (result, 4);
+    result INCR pos (hex digits, c) - 1
+  PER.
+
+convert binary :
+  FOR i FROM 1 UPTO LENGTH t - 1 REP
+    TEXT CONST bit :: t SUB i;
+    IF bit <> "0" AND bit <> "1"
+    THEN set conversion (FALSE);
+         LEAVE unsigned WITH 0
+    FI;
+    rotate (result, 1);
+    result INCR int (bit)
+  PER.
+
+convert decimal :
+  REAL VAR x :: real (t);
+  IF NOT last conversion ok THEN LEAVE unsigned WITH 0  FI;
+  IF x < 32768.0
+  THEN result := int (x)
+  ELSE result := int (x - 65536.0)  FI.
+END PROC unsigned; 
+ 
+RANGE CONST everywhere :: RANGE : (0, -1); 
+ 
+RANGE PROC range (UNSIGNED CONST low, high) : 
+  RANGE : (low, high) 
+END PROC range; 
+ 
+ANDXOR PROC andxor (UNSIGNED CONST and mask, xor mask) : 
+  ANDXOR : (and mask, xor mask) 
+ENDPROC andxor; 
+ 
+
+(******* weitere Operationen für UNSIGNED, LIST, RANGE, ANDXOR **************)
+ 
+INT PROC int (UNSIGNED CONST a) : 
+  (* falls jemand noch exotische Dinge damit tun will *)
+  a 
+END PROC int;
+
+OP CAT (LIST VAR l, UNSIGNED CONST a) : 
+  (* Liste nachtraeglich erweitern *)
+  CONCR (l) CAT textform (a) 
+END OP CAT; 
+ 
+(********************* editget(char), yes, no *****************************) 
+
+PROC editget (INT CONST spalte, zeile, TEXT CONST prompt, INT VAR i) : 
+  cursor (spalte, zeile);
+  editget (prompt, i)
+END PROC editget; 
+ 
+PROC editget (INT CONST spalte, zeile, TEXT CONST prompt, UNSIGNED VAR a,
+              REPRESENTATION CONST r) :
+  cursor (spalte, zeile);
+  editget (prompt, a, r)
+END PROC editget; 
+ 
+PROC editget (TEXT CONST prompt, INT VAR i) : 
+  TEXT VAR t :: text (i);
+  test up or down (prompt, t);
+  IF current direction <> "" THEN LEAVE editget  FI;
+  editget (t,7,7);
+  i := int (t);
+  IF NOT last conversion ok
+  THEN data error ("Eingabe unerlaubt als Zahl")  FI
+END PROC editget; 
+ 
+PROC editget (TEXT CONST prompt, UNSIGNED VAR a, REPRESENTATION CONST r) : 
+  TEXT VAR t :: text (a, r);
+  test up or down (prompt, t);
+  IF current direction <> "" THEN LEAVE editget  FI;
+  editget (t,18,18);
+  a := unsigned (t);
+  IF NOT last conversion ok
+  THEN data error ("Eingabe unerlaubt")  FI
+END PROC editget; 
+ 
+BOOL PROC yes (TEXT CONST frage, BOOL CONST std antwort) : 
+  (* Achtung: hierdrin kann nicht die alte "yes" Prozedur benutzt werden, da
+              diese kein getchar benutzt.
+     Die alten yes/no werden unten durch Resultatlose ueberdeckt.
+  *)
+  LET allowed = "NnJj";
+  INT VAR x,y; get cursor (x,y);
+  IF NOT command dialogue THEN LEAVE yes WITH std antwort  FI;
+  REP UNTIL getcharety = "" PER;
+  REP
+    cursor (x,y);
+    test up or down (frage + " ? (j/n)", standard antwort text);
+    IF current direction <> "" THEN LEAVE yes WITH std antwort  FI;
+    TEXT VAR t;
+    getchar (t);
+    IF t = ""13""
+    THEN t := standard antwort text  FI;
+    IF pos (allowed, t) = 0
+    THEN out (""7"") ELSE out (t); out (""13""10"")  FI
+  UNTIL pos (allowed, t) <> 0  PER;
+  t = "j" OR t = "J".
+
+standard antwort text:
+  IF std antwort
+    THEN "j"
+    ELSE "n"
+  FI.
+END PROC yes; 
+
+BOOL PROC yes (INT CONST spalte, zeile, TEXT CONST frage,
+               BOOL CONST std antwort) :
+  cursor (spalte, zeile);
+  yes (frage, std antwort).
+END PROC yes;
+
+PROC yes (TEXT CONST dummy): END PROC yes;
+
+PROC no  (TEXT CONST dummy): END PROC no;
+
+PROC editgetchar (INT CONST spalte, zeile,  TEXT CONST prompt, allowed,
+                  UNSIGNED VAR a) :
+  cursor (spalte, zeile);
+  editgetchar (prompt, allowed, a)
+END PROC editgetchar;
+
+PROC editgetchar (TEXT CONST prompt, allowed, UNSIGNED VAR a) :
+  (* Bietet Zeichen an (nehmen mit RETURN), nimmt nur die in allowed.
+     obere 8 Bit der Vorbesetzung werden abgeschnitten.
+  *)
+  TEXT VAR t;
+  test up or down (prompt, perhaps a);
+  a := a MOD 256;
+  IF current direction <> "" THEN LEAVE editgetchar  FI;
+  getchar (t);
+  IF t = ""13""
+  THEN (* Vorbesetzung behalten *)
+       out (right)
+  ELIF pos (allowed, t) <> 0
+  THEN a := code (t);
+       out (t)
+  ELSE out (t);
+       data error ("unzulässiges Zeichen")
+  FI.
+
+perhaps a:
+  IF a > 31 THEN code (a) ELSE ""  FI.
+END PROC editgetchar;
+
+(********* data error, write head, (reset) direction *********************)
+
+PROC data error (TEXT CONST fehlermeldung) :
+  cursor (1, 24);
+  out (""7"Fehler : " + fehlermeldung + "    (Bitte Taste) ");
+  REP UNTIL incharety (2) = "" PER; pause;
+  cursor (1, 24); out (""4"");
+  current direction := error
+END PROC data error;
+
+PROC write head (TEXT CONST headtext) :
+  TEXT CONST text :: subtext (headtext, 1, 77);
+  INT CONST luecke :: (79 - LENGTH text) DIV 2 - 1;
+  out (""1""4""15"");
+  luecke TIMESOUT " ";
+  out (text);
+  luecke TIMESOUT " ";
+  out (""14""13""10""10"").
+END PROC write head;
+
+TEXT PROC direction :
+  current direction
+END PROC direction;
+
+PROC reset direction (BOOL CONST manouvres possible) :
+  (* Hiermit kann die letzte Manövrierbewegung nach der Auswertung gelöscht
+     werden. Mit NOT manouvres possible wird der ganze Manövriermechanismus
+     außer Betrieb gesetzt.
+  *)
+  direction valid := manouvres possible;
+  current direction := ""
+END PROC reset direction;
+
+(*********************** put *******************************************) 
+ 
+PROC put (INT CONST spalte, zeile, UNSIGNED CONST a, REPRESENTATION CONST r):
+  cursor (spalte, zeile);
+  put (a, r)
+END PROC put;
+
+PROC put (INT CONST spalte, zeile, LIST CONST l, REPRESENTATION CONST r):
+  cursor (spalte, zeile);
+  put (l, r)
+END PROC put;
+
+PROC put (INT CONST spalte, zeile, RANGE CONST a, REPRESENTATION CONST r):
+  cursor (spalte, zeile);
+  put (a, r)
+END PROC put;
+
+PROC put (UNSIGNED CONST a, REPRESENTATION CONST r) : 
+  put (text (a, r)) 
+END PROC put; 
+ 
+PROC put (LIST CONST a, REPRESENTATION CONST r) : 
+  INT VAR i, l :: LENGTH CONCR (a) DIV 2;
+  write ("(");
+  FOR i FROM 1 UPTO l REP 
+    put (text (CONCR (a) ISUB i, r)); 
+    IF i < l THEN put (",")  FI
+  PER; 
+  IF l > 0 THEN out (""8"")  FI;
+  put (")")
+END PROC put;
+
+PROC put (RANGE CONST a, REPRESENTATION CONST r) : 
+  write (text (a.low, r));
+  write ("...");
+  write (text (a.high, r))
+END PROC put;
+(*** ist put auf RANGE in dieser Weise sinnvoll ?
+     vielleicht lieber die Maske bitweise mit x, 1, 0 darstellen ?
+***)
+
+PROC put (BOOL CONST b):
+  IF b
+    THEN put ("Ja  ");
+    ELSE put ("Nein");
+  FI
+END PROC put;
+
+
+(********************* interne Hilfsprozeduren ****************************) 
+ 
+TEXT PROC text (UNSIGNED CONST a, REPRESENTATION CONST r) : 
+  TEXT VAR result :: "";
+  INT  VAR i;
+  set conversion (TRUE);
+  IF CONCR (r) = 10   THEN decimal form
+  ELIF CONCR (r) = 2  THEN binary form 
+  ELSE hex form  FI. 
+ 
+decimal form :
+  IF bit (a, 15)  (* dann kriegt man im Eumel negatives Vorzeichen *)
+  THEN result := text (real (text (a)) + 65536.0); (* Der Umweg ueber
+       Text ist noetig, wegen (1.8.0) real (-32767-1) --> stack overflow *)
+       subtext (result, 1, pos (result, ".") - 1) (* Dezimalpunkt weghauen *)
+  ELSE text (a)  FI. 
+
+binary form : 
+  FOR i FROM 15 DOWNTO 0 REP
+    IF bit (a, i) THEN result CAT "1" ELSE result CAT "0"  FI 
+  PER; 
+  result + "b". 
+ 
+hex form : 
+  INT VAR help :: a; 
+  FOR i FROM 1 UPTO 4 REP 
+    rotate (help, 4);    (* oberste 4 bit zu untersten 4 machen *)
+    result CAT (hex digits SUB nibble + 1);  (* oberste 4 bit darstellen *) 
+  PER; 
+  result + "h". 
+ 
+nibble : 
+  help MOD 16.   (* unterste 4 bit *) 
+END PROC text; 
+
+TEXT PROC textform (UNSIGNED CONST a) : 
+  (* speichert das INT in einen TEXT (mit ISUB lesbar) *) 
+  TEXT VAR ta :: "  ";
+  replace (ta, 1, a);
+  ta 
+END PROC textform; 
+ 
+TEXT PROC reverse (TEXT CONST a) : 
+  (* Text umdrehen. Das braucht man, um die ISUBS direkt vergleichen zu
+     koennen. 
+  *)
+  IF LENGTH a <= 1 THEN a 
+  ELSE reverse (subtext (a, 2)) + (a SUB 1)  FI 
+END PROC reverse;
+
+PROC test up or down (TEXT CONST prompt, data) :
+  IF current direction <> "" AND NOT direction valid
+  THEN current direction := "";
+       LEAVE test up or down
+  FI;
+  out (prompt);
+  out ("       "8""8""8""8""8""8"");  (* nächste 6 Zeichen Löschen *)
+  out (data); LENGTH data TIMESOUT ""8"";
+  IF NOT direction valid THEN LEAVE test up or down  FI;
+  getchar (current direction);
+  IF current direction = up OR current direction = down
+  THEN (* verschlucken, spaeter auswerten *)
+  ELSE push (current direction);
+       current direction := ""
+  FI
+END PROC test up or down;
+
+TEXT PROC to lower (TEXT CONST text) :
+  TEXT VAR t :: text;
+  INT  VAR i;
+  FOR i FROM 1 UPTO LENGTH t REP
+    IF (t SUB i) >= ""65"" AND (t SUB i) <= ""90""
+    THEN replace (t, i, code (code (t SUB i) + 32))  FI
+  PER;
+  t
+END PROC to lower;
+
+END PACKET setup eumel basisoperationen;
+
+
+
+PACKET splitting DEFINES  low byte,     (* Copyright (C) 1985       *)
+                          high byte,    (* Martin Schönbeck, Spenge *)
+                          low word,     (* Stand: 13.09.85          *)
+                          high word: 
+ 
+INT PROC high byte (INT CONST value):
+ 
+    TEXT VAR x := "  ";
+    replace (x, 1, value);
+    code (x SUB 2)
+
+END PROC high byte;
+
+INT PROC low byte (INT CONST value):
+ 
+    TEXT VAR x := "  ";
+    replace (x, 1, value);
+    code (x SUB 1)
+
+END PROC low byte; 
+ 
+INT PROC high word (REAL CONST double precission int):
+
+    int (double precission int / 65536.0)
+
+END PROC high word;
+
+INT PROC low word (REAL CONST double precission int): 
+ 
+    string of low bytes ISUB 1.
+
+string of low bytes:
+    code (int (double precission int MOD 256.0)) +
+    code (int ((double precission int MOD 65536.0) / 256.0)). 
+ 
+END PROC low word; 
+ 
+END PACKET splitting;
+
+
+
+PACKET basic block io DEFINES
+  verify track, 
+  read block,
+  write block:
+
+
+PROC read block (DATASPACE VAR ds,
+                 INT CONST ds page no, 
+                 INT CONST block no,
+                 INT VAR return code):
+  read block; 
+  retry if read error.
+ 
+read block: 
+  block in (ds, ds page no, 0, block no, return code).
+ 
+retry if read error: 
+  INT VAR retry;
+  FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP 
+    reset to block 0 if fifth try; 
+    read block 
+  PER. 
+ 
+reset to block 0 if fifth try: 
+  IF retry = 5 
+    THEN block in (ds, ds page no, 0, 0, return code) 
+  FI. 
+ 
+END PROC read block;
+ 
+PROC write block (DATASPACE CONST ds,
+                 INT CONST ds page no, 
+                 INT CONST block no,
+                 INT VAR return code):
+  write block; 
+  retry if write error. 
+ 
+write block: 
+  block out (ds, ds page no, 0, block no, return code).
+ 
+retry if write error: 
+  INT VAR retry;
+  FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP 
+    reset to block 0 if fifth try; 
+    write block 
+  PER. 
+ 
+reset to block 0 if fifth try: 
+  IF retry = 5 
+    THEN disable stop;
+         DATASPACE VAR dummy ds := nilspace;
+         block in (dummy ds, 2, 0, 0, return code);
+         forget (dummy ds);
+         enable stop
+  FI. 
+ 
+END PROC write block; 
+
+PROC read block (DATASPACE VAR ds, INT CONST ds page,
+                 REAL CONST archive block):
+
+   enable stop;
+   read block (ds, ds page, archive block, error);
+   INT VAR error;
+   SELECT error OF
+      CASE 0:
+      CASE 1: error stop ("Platte kann nicht gelesen werden");
+      CASE 2: error stop ("Lesefehler bei Block "+ text (archive block));
+      CASE 3: error stop ("Versorgungsfehler Archiv");
+      OTHERWISE error stop ("unbekannter Fehler auf Platte");
+   END SELECT;
+
+END PROC read block;
+
+PROC write block (DATASPACE CONST ds, INT CONST ds page,
+                  REAL CONST archive block):
+
+   enable stop;
+   write block (ds, ds page, archive block, error);
+   INT VAR error;
+   SELECT error OF
+      CASE 0:
+      CASE 1: error stop ("Platte kann nicht geschrieben werden");
+      CASE 2: error stop ("Schreibfehler bei Block "+ text (archive block));
+      CASE 3: error stop ("Versorgungsfehler Archiv");
+      OTHERWISE error stop ("unbekannter Fehler auf Platte");
+   END SELECT;
+
+END PROC write block;
+
+PROC read block (DATASPACE VAR ds,
+                 INT CONST ds page no, 
+                 REAL CONST block no,
+                 INT VAR return code):
+  read block; 
+  retry if read error.
+ 
+read block: 
+  block in (ds, ds page no, high word (block no) OR -512,
+                             low word (block no), return code).
+ 
+retry if read error: 
+  INT VAR retry;
+  FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP 
+    reset to block 0 if fifth try; 
+    read block 
+  PER. 
+ 
+reset to block 0 if fifth try: 
+  IF retry = 5 
+    THEN block in (ds, ds page no, 0, 0, return code) 
+  FI. 
+ 
+END PROC read block;
+ 
+PROC write block (DATASPACE CONST ds,
+                 INT CONST ds page no, 
+                 REAL CONST block no,
+                 INT VAR return code):
+  write block; 
+  retry if write error. 
+ 
+write block: 
+  block out (ds, ds page no, high word (block no) OR -512,
+                              low word (block no), return code).
+ 
+retry if write error: 
+  INT VAR retry;
+  FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP 
+    reset to block 0 if fifth try; 
+    write block 
+  PER. 
+ 
+reset to block 0 if fifth try: 
+  IF retry = 5 
+    THEN disable stop;
+         DATASPACE VAR dummy ds := nilspace;
+         block in (dummy ds, 2, 0, 0, return code);
+         forget (dummy ds);
+         enable stop
+  FI. 
+ 
+END PROC write block; 
+
+PROC verify track (DATASPACE VAR ds, INT CONST ds page no,
+                   REAL CONST startblock no, INT VAR return code):
+  block in (ds, ds page no, high word (startblock no) OR -256,
+                   low word (startblock no), return code);
+END PROC verify track;
+
+END PACKET basic block io;
+
+
+
+PACKET write file DEFINES write file,   (* Copyright (C) 1985, 1987 *)
+                          read file :   (* Martin Schönbeck, Spenge *)
+                                        (* Lutz Prechelt, Karlsruhe *)
+                                        (* Stand: 07.06.87          *)
+
+PROC write file (TEXT CONST file name, REAL CONST start block,
+                 INT CONST number of blocks): 
+ 
+    INT VAR count;
+    disable stop; 
+    DATASPACE VAR ds := old (file name);
+    FOR count FROM 0 UPTO (number of blocks - 1) REP 
+        write block (ds, count + 3, start block + real (count)) 
+    UNTIL is error PER; 
+    forget (ds). 
+ 
+END PROC write file; 
+ 
+PROC write file (TEXT CONST file name, REAL CONST start block,
+                 INT CONST number of blocks, write channel): 
+ 
+    enable stop; 
+    INT VAR old channel := channel;
+    IF old channel <> write channel THEN continue (write channel)  FI;
+    disable stop;
+    write file (file name, start block, number of blocks);
+    IF old channel <> write channel
+    THEN break (quiet);
+         continue (old channel)
+    FI.
+END PROC write file;
+
+PROC read file (DATASPACE VAR file, REAL CONST start block,
+                 INT CONST number of blocks): 
+    INT VAR count;
+    disable stop; 
+    forget (file); file := nilspace;
+    FOR count FROM 0 UPTO (number of blocks - 1) REP 
+        read block (file, count + 3, start block + real (count)) 
+    UNTIL is error PER.
+END PROC read file; 
+ 
+PROC read file (DATASPACE VAR file, REAL CONST start block,
+                INT CONST number of blocks, read channel): 
+    enable stop; 
+    INT VAR old channel := channel;
+    IF old channel <> read channel THEN continue (read channel)  FI;
+    disable stop;
+    read file (file, start block, number of blocks);
+    IF old channel <> channel
+    THEN break (quiet);
+         continue (old channel)
+    FI.
+END PROC read file;
+
+END PACKET write file;
+
+PACKET thesaurus utilities
+DEFINES ONE, certain :                     (* Stand: 21.03.88 *)
+                                           (* Korr : Lutz Prechelt *)
+LET  max entries = 200; 
+ 
+LET oben unten rubout return = ""3""10""12""13"";
+ 
+INT  VAR anzahl, 
+         firstline, size,  (* erste Bildschirmz./Anz. Zeilen für Vorgang *)
+         realc, virtc;     (* akt. Zeile in Fenster/Eintragsnummer *)
+ 
+TEXT VAR string; 
+ 
+THESAURUS PROC certain (THESAURUS CONST in, pre) :
+  einzelne (in, pre, TRUE).
+END PROC certain;
+
+TEXT OP ONE (THESAURUS CONST t): 
+  name (einzelne (t, empty thesaurus, FALSE),1) 
+END OP ONE; 
+ 
+THESAURUS PROC einzelne (THESAURUS CONST thes, preselections, 
+                         BOOL CONST viele): 
+  (* Benutzt nur den Rest des Bildschirms ab der aktuellen Zeile nach unten. 
+     Die in preselections enthaltenen Namen aus t sind bereits zu Beginn 
+     angekreuzt. 
+     Ein Aufruf mit NOT viele und preselections/t <> empty thesaurus ist
+     nicht sinnvoll.
+     Die Cursorposition nach Verlassen ist wieder in der "aktuellen" Zeile 
+     auf Position 1, so daß mit out (""4"") der Kram selektiv gelöscht
+     werden kann.
+  *)
+  ROW maxentries TEXT VAR eintrag;
+  THESAURUS VAR ausgabe :: empty thesaurus,
+                t :: empty thesaurus + thes;  (* Leereinträge entfernen! *)
+  INT VAR i; 
+  initialisiere ankreuzen;
+  IF anzahl = 0 THEN LEAVE einzelne WITH empty thesaurus FI;
+  bildschirm vorbereiten;
+  bild (1, eintrag); 
+  virtc := 1; 
+  realc := 1; 
+  realcursor setzen; 
+  kreuze an (viele, eintrag);
+  ausgabe erzeugen; 
+  cursor (1, firstline - 2); out (""4"");
+  ausgabe. 
+ 
+initialisiere ankreuzen:
+  anzahl := highest entry (t);
+  string := "";
+  (* t enthält keine Leereinträge mehr ! *)
+  FOR i FROM 1 UPTO anzahl REP 
+     eintrag [i] := name (t,i)
+  PER;
+  FOR i FROM 1 UPTO highest entry (preselections) REP 
+    INT CONST preselection link :: link (t, name (preselections, i));
+    IF preselection link > 0
+    THEN string CAT textstr (preselection link)  FI
+  PER.
+
+bildschirm vorbereiten: 
+  get cursor (i, firstline); 
+  out (""13""4"");  (* Restbildschirm löschen *)
+  IF viele
+  THEN putline ("Wählen <CR>  Löschen <RUBOUT>  " + 
+                "alle Löschen <HOP><RUBOUT>  Beenden <ESC>q") 
+  ELSE putline ("Auswählen <CR>")  FI;
+  putline ("Marke bewegen  <RUNTER>  <RAUF>  <HOP><RUNTER>  <HOP><RAUF>"); 
+  firstline INCR 2; 
+  size := 24 - firstline + 1.
+
+ausgabe erzeugen: 
+  WHILE string <> "" REP 
+    insert (ausgabe, eintrag [string ISUB 1]);
+    string := subtext (string, 3); 
+ PER 
+END PROC einzelne; 
+ 
+PROC realcursor setzen: 
+  TEXT CONST mark :: marke (virtc, TRUE);
+  cursor (1, firstline + realc - 1); 
+  out (mark + LENGTH mark * ""8"").
+END PROC real cursor setzen; 
+ 
+TEXT PROC marke (INT CONST zeiger, BOOL CONST mit cursor): 
+  INT VAR pl :: nr (zeiger); 
+  IF pl = 0 
+     THEN leer
+     ELSE mit zahl
+  FI. 
+ 
+mit zahl: 
+  IF mit cursor 
+     THEN (3 - length (text (pl))) * "-" + text (pl) + "-> " 
+     ELSE text (pl, 3) + " > " 
+  FI. 
+ 
+leer: 
+  IF mit cursor 
+     THEN ">>>>> " 
+     ELSE "      "
+  FI 
+END PROC marke; 
+ 
+PROC bild (INT CONST anfang, ROW maxentries TEXT CONST eintrag): 
+  cursor (1, firstline);
+  out (""4""3"");    (* Restschirm löschen, 1 Zeile rauf *)
+  INT VAR i; 
+  FOR i FROM anfang UPTO grenze REP 
+     out (""13""10"");
+     out (marke (i, FALSE)); 
+     out (eintrag [i]) 
+  PER. 
+ 
+grenze: 
+  min (anzahl, anfang + size - 1)
+END PROC bild; 
+ 
+PROC kreuze an (BOOL CONST viele, ROW maxentries TEXT CONST eintrag) :
+  REP zeichen lesen; 
+      zeichen interpretieren 
+  PER. 
+ 
+zeichen lesen: 
+  TEXT VAR zeichen; 
+  inchar (zeichen, ""1""27""3""10""13"1Xx+"11""12"Oo0-"). 
+ 
+zeichen interpretieren: 
+  SELECT code (zeichen) OF 
+    CASE   1 (* hop *)    : hoppen (eintrag)
+    CASE  27 (* ESC *)    : IF incharety (600) = "q" THEN LEAVE kreuze an  FI
+    CASE   3 (* rauf *)   : nach oben (eintrag)
+    CASE  10 (* runter *) : nach unten (eintrag)
+    CASE  13 (* Return *) : ankreuzen (eintrag, TRUE); evtl aufhoeren
+    CASE  49,(* 1 *)
+          88,(* X *)
+         120,(* x *)
+          43,(* + *)
+          11 (* Rubin *)  : ankreuzen (eintrag, FALSE); evtl aufhoeren 
+    CASE  12,(* Rubout *)
+          79,(* O *)
+         111,(* o *)
+          48,(* 0 *)
+          45 (* - *)      : auskreuzen (eintrag)
+  END SELECT. 
+ 
+evtl aufhoeren: 
+  IF NOT viele THEN LEAVE kreuze an FI. 
+ 
+END PROC kreuze an; 
+ 
+PROC hoppen (ROW maxentries TEXT CONST eintrag) :
+  zweites zeichen lesen; 
+  zeichen interpretieren. 
+ 
+zweites zeichen lesen: 
+  TEXT VAR zz; 
+  inchar (zz).
+ 
+zeichen interpretieren: 
+  SELECT pos (oben unten rubout return, zz) OF 
+    CASE 1 : hop nach oben 
+    CASE 2 : hop nach unten 
+    CASE 3 : alles loeschen 
+    CASE 4 : rest ankreuzen
+    OTHERWISE out (""7"")
+  END SELECT. 
+ 
+rest ankreuzen:
+  INT VAR i;
+  FOR i FROM 1 UPTO anzahl REP     (* alles *)
+    IF nr (i) = 0                  (* was noch nicht angekreuzt ist *)
+       THEN string CAT textstr (i) (* ankreuzen *)
+    FI
+  PER;
+  bild aktualisieren.
+
+alles loeschen: 
+  string := ""; 
+  bild aktualisieren.
+ 
+hop nach oben: 
+  IF   ganz oben 
+       THEN out (""7"") 
+  ELIF oben im fenster    
+       THEN raufblaettern 
+       ELSE top of page 
+  FI. 
+ 
+ganz oben: 
+  virtc = 1. 
+ 
+oben im fenster: 
+  realc = 1. 
+ 
+raufblaettern: 
+  virtc DECR size;
+  virtc := max (virtc, 1); 
+  bild (virtc, eintrag); 
+  realcursor setzen. 
+ 
+top of page: 
+  loesche marke; 
+  virtc DECR (realc - 1); 
+  realc := 1; 
+  realcursor setzen. 
+ 
+hop nach unten: 
+  IF   ganz unten 
+       THEN out (""7"") 
+  ELIF unten im fenster 
+       THEN runterblaettern 
+       ELSE bottom of page 
+  FI. 
+ 
+ganz unten: 
+  virtc = anzahl. 
+ 
+unten im fenster: 
+  firstline + realc > 24. 
+ 
+runterblaettern: 
+  INT VAR alter virtc :: virtc; 
+  virtc INCR size;
+  virtc := min (virtc, anzahl); 
+  realc := virtc - alter virtc; 
+  bild (alter virtc + 1, eintrag);
+  realcursor setzen. 
+ 
+bottom of page: 
+  loesche marke; 
+  alter virtc := virtc; 
+  virtc INCR (size - realc); 
+  virtc := min (anzahl, virtc); 
+  realc INCR (virtc - alter virtc); 
+  realcursor setzen 
+END PROC hoppen; 
+ 
+PROC ankreuzen (ROW maxentries TEXT CONST eintrag, BOOL CONST ggf auskreuzen):
+  (* bei ggf auskreuzen wird der Eintrag, falls er schon angekreuzt ist,
+     ausgekreuzt, andernfalls normal angekreuzt.
+  *)
+  INT VAR pl :: nr (virtc); 
+  IF pl <> 0 
+     THEN schon angekreuzt
+  FI; 
+  string CAT textstr (virtc); 
+  IF virtc < anzahl THEN nach unten (eintrag) ELSE realcursor setzen  FI.
+
+schon angekreuzt :
+  IF ggf auskreuzen THEN auskreuzen (eintrag) ELSE out (""7"")  FI;
+  LEAVE ankreuzen.
+END PROC ankreuzen; 
+ 
+PROC auskreuzen (ROW maxentries TEXT CONST eintrag) :
+  INT VAR posi :: nr (virtc); 
+  IF posi = 0 
+     THEN out (""7""); LEAVE auskreuzen 
+  FI; 
+  rausschmeissen; 
+  loesche marke; 
+  bild aktualisieren; 
+  IF virtc < anzahl THEN nach unten (eintrag) FI.
+ 
+rausschmeissen: 
+  string := subtext (string,1, 2*posi-2) + subtext (string,2*posi+1) 
+END PROC auskreuzen; 
+ 
+PROC bild aktualisieren: 
+  INT VAR ob, un, i; 
+  ob := virtc - realc + 1; 
+  un := min (ob + size - 1, anzahl); 
+  cursor (1, firstline - 1); 
+  FOR i FROM ob UPTO un REP 
+    out (""13""10""); out (marke (i, FALSE))
+  PER;
+  realcursor setzen.
+END PROC bild aktualisieren; 
+ 
+PROC nach oben (ROW maxentries TEXT CONST eintrag) :
+  IF noch nicht oben   (* virtuell *) 
+     THEN gehe nach oben 
+     ELSE out (""7"") 
+  FI;
+  realcursor setzen.
+ 
+noch nicht oben: 
+  virtc > 1. 
+ 
+gehe nach oben: 
+  IF realc = 1 
+     THEN scroll down 
+     ELSE cursor up 
+  FI. 
+ 
+scroll down: 
+  virtc DECR 1; 
+  bild (virtc, eintrag).
+ 
+cursor up: 
+  loesche marke; 
+  virtc DECR 1; 
+  realc DECR 1.
+END PROC nach oben; 
+ 
+PROC nach unten (ROW maxentries TEXT CONST eintrag) :
+  IF noch nicht unten  (* virtuell *) 
+     THEN gehe nach unten
+     ELSE out (""7"")
+  FI. 
+ 
+noch nicht unten: 
+  virtc < anzahl. 
+ 
+gehe nach unten:
+  IF realc > size - 1 
+     THEN scroll up 
+     ELSE cursor down 
+  FI. 
+ 
+scroll up: 
+  virtc INCR 1; 
+  bild (virtc - size + 1, eintrag); 
+  realcursor setzen. 
+ 
+cursor down: 
+  loesche marke; 
+  virtc INCR 1; 
+  realc INCR 1; 
+  realcursor setzen 
+END PROC nach unten; 
+ 
+PROC loesche marke: 
+  out (marke (virtc, FALSE)) 
+END PROC loesche marke; 
+ 
+TEXT PROC textstr (INT CONST nr): 
+  TEXT VAR help :: "  "; 
+  replace (help, 1, nr); 
+  help.
+END PROC textstr; 
+ 
+INT PROC nr (INT CONST zeiger): 
+  IF pos (string, textstr (zeiger)) = 0 (* haut hin, da zeiger < 255 *)
+     THEN 0 
+     ELSE (pos (string,textstr (zeiger)) DIV 2) + 1 
+  FI 
+END PROC nr;
+
+PROC inchar (TEXT VAR t, TEXT CONST allowed) : 
+  REP 
+    getchar (t); 
+    IF pos (allowed, t) = 0 THEN out (""7"")  FI 
+  UNTIL pos (allowed, t) > 0  PER. 
+END PROC inchar; 
+ 
+END PACKET thesaurus utilities;
+
diff --git a/system/setup/3.1/src/setup eumel 2: modulzugriffe b/system/setup/3.1/src/setup eumel 2: modulzugriffe
new file mode 100644
index 0000000..42163f4
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 2: modulzugriffe
@@ -0,0 +1,441 @@
+
+(* Pakete:
+ 1. setup eumel modulzugriffe
+       Abstrakter Datentyp MODUL : Typ, Datenraumtyp, Zugriffsoperationen
+ 2. setup eumel modul und shard zugriffe
+       Zugriffe in Module und SHards (Datentyp MODUL) mit Strukturwissen
+*)
+ 
+(**************************************************************************)
+(***** Datentyp MODUL und Zugriffsoperationen dafür        ****************)
+(***** Copyright (c) 1987, 1988 by                         ****************)
+(***** Lutz Prechelt, Karlsruhe                            ****************)
+(**************************************************************************)
+
+PACKET setup eumel modulzugriffe            (* Copyright (c) 1987 by    *)
+DEFINES int, byte, text, unsigned,          (* Lutz Prechelt, Karlsruhe *)
+        dtcb abfragen,    ccb abfragen,     (* Stand : 12.03.88   1.1   *)
+        dtcb refinements, ccb refinements,  (* Eumel 1.8.1              *)
+        info,
+        page,
+        copy,
+        datenraumtyp modul,
+        MODUL :
+
+
+(* Dies Paket realisiert gezielte Zugriffe in einen Struct vom Typ MODUL.
+   Dies ist das Format eines SHard Moduls. Der Typ wird auch verwendet, um
+   das SHard-Hauptmodul oder einzelne ccbs zu handhaben!
+   Für die Adressierung der Bytes werden REAL-Werte verwendet, damit die
+   Größe nicht auf maxint beschränkt ist. Dies ist normalerweise sicher
+   (wegen der BCD-Arithmetik des Eumel), jedoch sind sinnlose nichtganzzahlige
+   Adressen dadurch möglich. Das wird aus Effizienzgründen nicht abgefangen,
+   die korrekte Benutzung liegt in der Verantwortung des Aufrufers.
+   Es sollen alle Zugriffe auf Module nur mit den Prozeduren dieses Pakets
+   abgewickelt werden.
+*) 
+ 
+ 
+INT CONST high only ::-256,
+          low  only :: 255;
+
+LET  max page = 128;
+
+TYPE MODUL =   STRUCT (ALIGN dummy, ROW 256 INT header,
+                      ROW max page ROW 256 INT b, 
+                      INT dtcb abfragen, ccb abfragen, 
+                      TEXT dtcb ref, ccb ref, info);
+
+(* Der Typ kann wegen des ALIGN direkt auf einen Datenraum (für ein Modul)
+   gelegt werden. Der Teil b fasst 64kB Daten und kann direkt für blockout
+   verwendet werden. Die restlichen Teile sind nur für Module relevant. 
+*) 
+ 
+INT CONST datenraumtyp modul :: 5687;  (* Typ eines MODUL als Datenraum *)
+
+(*********************** INT ********************************************)
+
+INT PROC int (MODUL CONST m, REAL CONST byte nr) : 
+  (* liefert das INT aus dem Modul m, das bei Byte "byte nr" beginnt *)
+  INT VAR   page :: int (byte nr DIV 512.0) + 1,
+            nr   :: int (byte nr MOD 512.0) DIV 2 + 1;
+  INT VAR   whole int :: m.b[page][nr];
+  IF byte nr MOD 2.0 <> 0.0 
+  THEN rotate (whole int, 8); (* high und low byte vertauschen *)
+       (whole int AND low only) + next byte in high
+  ELSE whole int  FI.
+
+next byte in high :
+  IF nr = 256 THEN nr := 1; page INCR 1 ELSE nr INCR 1  FI;
+  INT VAR help :: m.b[page][nr] AND low only;
+  rotate (help, 8);
+  help.
+END PROC int;
+
+INT PROC int (MODUL CONST m, INT CONST byte nr) :
+  int (m, real (byte nr))
+END PROC int;
+
+PROC int (MODUL VAR m, REAL CONST byte nr, INT CONST new) :
+  (* schreibt den neuen 16-Bit Wert new ab dem Byte "byte nr" in den Teil b
+     des Moduls m. Hier kommt es nicht sehr aufs Tempo an, deshalb benutzen
+     wir hier einfach "byte".
+  *)
+  INT VAR value :: new;
+  rotate (value, 8); (* high byte zu low byte machen *)
+  byte (m, byte nr,       new   AND low only);
+  byte (m, byte nr + 1.0, value AND low only);
+END PROC int;
+
+PROC int (MODUL VAR m, INT CONST byte nr, INT CONST new) :
+  int (m, real (byte nr), new)
+END PROC int;
+
+(************************** BYTE *******************************************)
+
+INT PROC byte (MODUL CONST m, REAL CONST byte nr) : 
+  (* liefert das Byte mit der Nummer "byte nr" aus dem Teil b des Moduls m.
+     Das erste Byte hat die Nummer 0
+  *)
+  INT CONST page :: int (byte nr DIV 512.0) + 1,
+            nr   :: int (byte nr MOD 512.0) DIV 2 + 1;
+  INT VAR   whole int :: m.b[page][nr];
+  IF byte nr MOD 2.0 <> 0.0 
+  THEN rotate (whole int, 8); (* high und low byte vertauschen *)  FI; 
+  whole int AND low only. 
+END PROC byte; 
+ 
+INT PROC byte (MODUL CONST m, INT CONST byte nr) :
+  byte (m, real (byte nr))
+END PROC byte;
+
+PROC byte (MODUL VAR m, REAL CONST byte nr, INT CONST new) :
+  (* Schreibt die unteren 8 bit von new an das Byte der Stelle byte nr im
+     Modul m
+  *)
+  INT CONST page :: int (byte nr DIV 512.0) + 1,
+            nr   :: int (byte nr MOD 512.0) DIV 2 + 1;
+  INT VAR   new byte  :: new AND low only,
+            whole int :: m.b[page][nr];
+  m.b[page][nr] := new int.
+
+new int :
+  IF byte nr MOD 2.0 = 0.0  (* low byte ändern ? *)
+  THEN (whole int AND high only) + new byte
+  ELSE rotate (new byte, 8); (* new nach high rotieren *)
+       new byte + (whole int AND low only)
+  FI.
+END PROC byte;
+
+PROC byte (MODUL VAR m, INT CONST byte nr, INT CONST new) :
+  byte (m, real (byte nr), new)
+END PROC byte;
+
+(*********************** TEXT ********************************************)
+
+TEXT PROC text (MODUL CONST m, REAL CONST first byte nr, INT CONST length) : 
+  (* Extrahiert die naechsten length bytes aus m ab byte nr als TEXT *) 
+  REAL VAR i :: first byte nr;
+  TEXT VAR result :: ""; 
+  WHILE i < first byte nr + real (length) REP
+    result CAT code (byte (m, i)); 
+    i INCR 1.0
+  PER; 
+  result. 
+END PROC text; 
+ 
+TEXT PROC text (MODUL CONST m, INT CONST first byte nr, INT CONST length) : 
+  text (m, real (first byte nr), length)
+END PROC text;
+
+(* Ein schreibendes Analogon zu "text" gibt es nicht. *)
+
+(*********************** unsigned *****************************************)
+
+REAL PROC unsigned (INT CONST sixteen bits) :
+  (* hiermit kann man die Vorzeichenprobleme umschiffen, die der Eumel bei
+     INTs über maxint macht.
+     Liefert das INT als 16-Bit unsigned Wert interpretiert im REAL-Format.
+  *)
+  real (text (sixteen bits, dec))
+END PROC unsigned;
+
+INT PROC unsigned (REAL CONST sixteen bit value) :
+  (* Umkehrung des obigen : REAL 0..65536 rein, passenden 16 bit unsigned
+     Wert raus
+  *)
+  TEXT CONST t :: text (sixteen bit value);
+  int (unsigned (value text)).
+
+value text :
+  IF pos (t, ".") <> 0
+  THEN subtext (t, 1, pos (t, ".") - 1)
+  ELSE t
+  FI.
+END PROC unsigned;
+
+(******************** dtcb, ccb, info **************************************)
+
+INT PROC dtcb abfragen (MODUL CONST m) :
+  m.dtcb abfragen
+END PROC dtcb abfragen;
+
+PROC dtcb abfragen (MODUL VAR m, INT CONST neu) :
+  m.dtcb abfragen := neu
+END PROC dtcb abfragen;
+
+TEXT PROC dtcb refinements (MODUL CONST m) :
+  m.dtcb ref
+END PROC dtcb refinements;
+
+PROC dtcb refinements (MODUL VAR m, TEXT CONST neu) :
+  m.dtcb ref := neu
+END PROC dtcb refinements;
+
+INT PROC ccb abfragen (MODUL CONST m) :
+  m.ccb abfragen
+END PROC ccb abfragen;
+
+PROC ccb abfragen (MODUL VAR m, INT CONST neu) :
+  m.ccb abfragen := neu
+END PROC ccb abfragen;
+
+TEXT PROC ccb refinements (MODUL CONST m) :
+  m.ccb ref
+END PROC ccb refinements;
+
+PROC ccb refinements (MODUL VAR m, TEXT CONST neu) :
+  m.ccb ref := neu
+END PROC ccb refinements;
+
+TEXT PROC info (MODUL CONST m) :
+  m.info
+END PROC info;
+
+PROC info (MODUL VAR m, TEXT CONST neu) :
+  m.info := neu
+END PROC info;
+
+(********************* page **********************************************)
+
+(* Die Prozedur page dient dazu, aus dem Datenbereich b eines MODULs
+   einzelne Seiten (512 Byte Blöcke) in Form eines ROW 256 INT anzusprechen
+   um damit blockin/blockout zu machen.
+   Die Seitennummern gehen von 1 bis max page
+*)
+
+ROW 256 INT PROC page (MODUL CONST m, INT CONST page nr) :
+  m.b[page nr]
+END PROC page;
+
+PROC page (MODUL VAR m, INT CONST page nr, ROW 256 INT CONST new page) :
+  m.b[page nr] := new page
+END PROC page;
+
+(*********************** copy ********************************************)
+
+PROC copy (MODUL CONST from, REAL CONST origin,
+           MODUL VAR   to,   REAL CONST destination, INT CONST length) :
+  (* Kopiert schnell eine Anzahl von Bytes aus einem Modul in ein anderes
+     die Optimierung klappt nur, wenn von einer geraden Adresse an eine
+     gerade Adresse kopiert wird oder von ungerade nach ungerade.
+     Macht cout.
+  *)
+  INT  VAR i, interval :: cout interval;
+  REAL VAR offset :: 0.0;
+  IF length < 0 THEN errorstop ("copy : length = " + text (length))  FI;
+  IF origin MOD 2.0 <> destination MOD 2.0
+  THEN copy slow
+  ELSE copy fast  FI;
+  cout (length).
+
+cout interval :
+  IF   length > 1024   THEN 32
+  ELIF length >   64   THEN  8
+  ELSE                       1  FI.
+
+copy slow :
+  FOR i FROM 1 UPTO length REP
+    IF i MOD 2*interval = 0 THEN cout (i)  FI;
+    byte (to, destination + offset, byte (from, origin + offset));
+    offset INCR 1.0
+  PER.
+
+copy fast :
+  IF origin MOD 2.0 <> 0.0 AND length > 0
+  THEN byte (to, destination, byte (from, origin));
+       offset := 1.0
+  FI;
+  FOR i FROM 1 UPTO (length - int (origin MOD 2.0))  DIV 2 REP
+    INT CONST page1 :: int ((origin+offset) DIV 512.0) + 1,
+              nr1   :: int ((origin+offset) MOD 512.0) DIV 2 + 1,
+              page2 :: int ((destination+offset) DIV 512.0) + 1,
+              nr2   :: int ((destination+offset) MOD 512.0) DIV 2 + 1;
+    to.b[page2][nr2] := from.b[page1][nr1];
+    IF i MOD interval = 0 THEN cout (2*i)  FI;
+    offset INCR 2.0
+  PER;
+  IF length - int (offset) = 1
+  THEN byte (to, destination + offset, byte (from, origin + offset))  FI.
+END PROC copy;
+
+(************************ Hilfsprozeduren ********************************)
+
+REAL OP DIV (REAL CONST a, b) :
+  floor (a/b)
+END OP DIV;
+
+END PACKET setup eumel modulzugriffe;
+
+ 
+(**************************************************************************)
+(***** Zugriffe in Module mit Strukturwissen               ****************)
+(***** Copyright (c) 1988 by                               ****************)
+(***** Lutz Prechelt, Karlsruhe                            ****************)
+(**************************************************************************)
+
+PACKET setup eumel modul und shard zugriffe (* Copyright (c) 1988 by    *)
+DEFINES sh dtcb offset,                     (* Lutz Prechelt, Karlsruhe *)
+        sh ccb offset,                      (* Stand : 23.04.88   1.2   *)
+        get new channel table,              (* Eumel 1.8.1              *)
+        init modules list,
+        all modules,
+        module type,
+        module name:
+
+(* Dieses Paket definiert Operationen zum Zugriff auf bestimmte Daten in 
+   SHardmodulen und SHards. Es ist hierin Wissen über die Struktur dieser 
+   Teile enthalten. 
+   Beschreibung des SHardformats siehe setup eumel 4: modulkonfiguration
+*) 
+
+LET nr of channels total          = 40,
+    offset channel table pointer  = 10;
+
+THESAURUS VAR all the beautiful modules we know :: emptythesaurus;
+ 
+(******************* Kanaltabelle lesen/schreiben **************************)
+
+(* Hier geht schöne Struktur (und damit zugleich einfache Programmierung)
+   über gute Performance. (Wir lesen einiges mehrfach)
+*)
+
+REAL PROC sh dtcb offset (MODUL CONST shard, INT CONST kanal) :
+  unsigned (int (shard, ct + 4 * kanal)).
+
+ct :
+  int (shard, offset channel table pointer).
+END PROC sh dtcb offset;
+
+REAL PROC sh ccb offset (MODUL CONST shard, INT CONST kanal) :
+  unsigned (int (shard, ct + 4 * kanal + 2)).
+
+ct :
+  int (shard, offset channel table pointer).
+END PROC sh ccb offset;
+
+PROC sh dtcb offset (MODUL VAR shard, INT CONST kanal, REAL CONST value) :
+  int (shard, ct + 4 * kanal, unsigned (value)).
+
+ct :
+  int (shard, offset channel table pointer).
+END PROC sh dtcb offset;
+
+PROC sh ccb offset (MODUL VAR shard, INT CONST kanal, REAL CONST value) :
+  int (shard, ct + 4 * kanal + 2, unsigned (value)).
+
+ct :
+  int (shard, offset channel table pointer).
+END PROC sh ccb offset;
+
+PROC get new channel table (MODUL CONST new shard,
+                            ROW 256 INT VAR channel table of new shard) :
+  (* Kopiert die Kanaltabelle aus new shard nach
+     channel table of new shard
+  *)
+  INT VAR offset :: int (new shard, offset channel table pointer);
+  INT VAR  i;
+  FOR i FROM 1 UPTO 2 * nr of channels total REP
+    channel table of new shard [i] := int (new shard, offset);
+    offset INCR 2
+  PER.
+END PROC get new channel table;
+
+(********************* modules list handling *****************************)
+
+TEXT VAR m list;
+
+PROC init modules list :
+  (* Baut in der Variablen m list einen "Assoziativspeicher" für
+     Modulnamen <--> Modultyp auf und erstellt eine Liste aller
+     Shardmoduldateinamen für "all modules"
+     Der Text m list enthält für jede Datei, die ein SHardmodul enthält,
+     einen Eintrag folgender Form :
+     ""0"", modultyp, ""0"", Dateiname, ""0""
+     Dabei ist modultyp genau 4 Byte lang.
+     Diese Eintragsform ermöglicht ein (auf dem Eumel) sehr effizientes
+     Suchen, sowohl von Modultypen zu Modulnamen als auch umgekehrt.
+     Die Prozedur macht cout (dateinummer)
+  *)
+  INT VAR i;
+  TEXT VAR t;
+  m list := ""; all the beautiful modules we know := empty thesaurus;
+  FOR i FROM 1 UPTO highest entry (all) REP
+     cout (i);
+     t := name (all, i);
+     IF t <> "" CAND type (old (t)) = datenraumtyp modul
+     THEN add t  FI
+  PER.
+
+add t :
+  insert (all the beautiful modules we know, t);
+  TEXT CONST typ :: read module type (t);
+  m list cat typmarker;
+  m list CAT t;
+  m list CAT ""0"".
+
+m list cat typmarker :
+  m list CAT ""0"";
+  m list CAT typ;
+  m list CAT ""0"".
+END PROC init modules list;
+
+THESAURUS PROC all modules :
+  all the beautiful modules we know.
+END PROC all modules;
+
+TEXT PROC read module type (TEXT CONST datei) : 
+  (* Liefert den 4-Byte Modultyp des in der Datei datei enthaltenen 
+     SHardmoduls, falls möglich, andernfalls "" 
+  *) 
+  IF NOT exists (datei) COR type (old (datei)) <> datenraumtyp modul 
+  THEN ""
+  ELSE BOUND MODUL CONST m :: old (datei); 
+       text (m, int (m, 8), 4)
+  FI.
+END PROC read module type; 
+ 
+TEXT PROC module type (TEXT CONST module name) :
+  (* Liefert den 4-Byte Modultyp zu module name aus m list, sofern vorhanden
+     andernfalls ""
+  *)
+  INT CONST p :: pos (m list, ""0"" + module name + ""0"");
+  IF p = 0
+  THEN ""
+  ELSE subtext (m list, p - 4, p - 1)  FI.
+END PROC module type;
+
+TEXT PROC module name (TEXT CONST module type) :
+  (* Liefert den Moduldateinamen zum 4-Byte Modultyp module type, oder
+     "" falls kein solches Modul vorhanden.
+  *)
+  INT VAR p :: pos (m list, ""0"" + module type + ""0"");
+  IF p = 0
+  THEN ""
+  ELSE p INCR 6;
+       subtext (m list, p, pos (m list, ""0"", p) - 1)
+  FI.
+END PROC module name;
+
+END PACKET setup eumel modul und shard zugriffe;
+
diff --git a/system/setup/3.1/src/setup eumel 3: modulkonfiguration b/system/setup/3.1/src/setup eumel 3: modulkonfiguration
new file mode 100644
index 0000000..529d0de
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 3: modulkonfiguration
@@ -0,0 +1,854 @@
+
+(**************************************************************************)
+(***** Ergänzung des SHards um ein Modul (mit Dialog)     *****************)
+(***** Copyright (c) 1987, 1988 by                        *****************)
+(***** Lutz Prechelt, Karlsruhe                           *****************)
+(**************************************************************************)
+
+PACKET setup eumel modulkonfiguration     (* Copyright (c) by         *)
+DEFINES configurate module,               (* Lutz Prechelt, Karlsruhe *)
+        print configuration,              (* Eumel 1.8.1              *)
+        give me, take you,                (* Stand : 12.07.88   3.2   *)
+        new index,                        
+        perform dtcb dialogue,
+        perform ccb  dialogue,
+        (* für Modulprogrammierer : *)
+        write info,
+        channel free,
+        reserve channel,
+        channels of this module,
+        buffer address :
+
+(* Dieses Modul führt den kompletten Dialog mit dem Benutzer durch, der
+   nötig ist, um alle Kanäle, die mit demselben Modul laufen sollen, zu 
+   konfigurieren. 
+   Verfahren : 
+      im alten SHard den dtcb suchen 
+      dtcb und Modul im neuen SHard eintragen
+      dtcb mit oder ohne Vorbild konfigurieren 
+      alle ccbs zu dem Modul im alten SHard suchen und Kanalnummern merken
+      Auswahl einer Kanalmenge durch Benutzer mit alten als Vorschlag
+      ccbs in neuen SHard kopieren
+      ccbs mit oder ohne Vorbild konfigurieren
+      Kanaltabelle auf den neuen Stand bringen
+      neuen Shard und seine geänderte Länge zurückgeben 
+
+   Dabei kann der "Dialog" bei geeigneten Rahmenbedingungen durch bloßes
+   Übertragen der Werte aus einem Vorlage-SHard ersetzt werden, wenn der
+   Benutzer dies wünscht (want automatic mode). Dann geht alles von selbst.
+   (....kaufen Sie Setup-Eumel und es geht alles wie von selbst !)
+
+Format des SHard-Hauptmoduls : 
+   1. (Byte 0-2)     jmp boot (3 Byte)
+   2. (Byte 3)       reserviert
+   3. (Byte 4)       SHard-Version
+   4. (Byte 5)       SHard-Release
+   5. (Byte 6/7)     SHardlänge (2 Byte)
+   6. (Byte 8/9)     Verweis auf Bad-Block Tabelle (2 Byte)
+   7. (Byte 10/11)   Verweis auf Kanaltabelle
+   8. (Byte 16-175)  Eumelleiste
+   9. (Byte 176-299) SHardleiste
+  10. (ab Byte 300)  Shardhauptmodulroutinen und -daten
+  11. (danach)       Rumpf des Hauptmoduls mit Bad-Block-Tabelle,
+                     Kanaltabelle, Routinen und Daten
+  12. (danach)       Folge der Module (bis Byte SHardlänge - 1)
+
+Kanaltabelle:
+        feste Länge 40 Einträge "nr of channels total" (Kanal 0 bis Kanal 39)
+        jeder Eintrag besteht aus : (alles 2 Byte) 
+        offset dtcb, offset ccb 
+ 
+Achtung : Dieses Programm schmiert bei SHards über 32767 Byte Länge
+          eventuell ab (es hat noch niemand probiert) !
+
+Abkürzungen: cb steht für control block und meint entweder ccb oder dtcb 
+ 
+Implementationsanmerkung :
+Bei der Verwendung von THESAURUS wird von dem Wissen über die Art der
+Implementation derselben Gebrauch gemacht, indem folgende Annahmen in den
+Code eingehen:
+1. Bei einem THESAURUS, in dem nicht gelöscht wurde, ist highest entry gleich
+   der Kardinalität
+2. außerdem entspricht dann die Nummer (link) eines Eintrags seinem
+   Eintragszeitpunkt, d.h. der Position in der Eintragsfolge
+3. + und - liefert THESAURi, in denen nicht gelöscht wurde und die Eintrags-
+   reihenfolge ist wie von den Parametern vorgegeben (bei + links zuerst)
+4. certain und ONE liefern THESAURi, in denen nicht gelöscht wurde.
+*)
+
+(************************* Daten ********************************)
+
+LET    nr of channels total          = 40,  (* SHard Tabellenlänge *)
+       mdts                          = 40,  (* max dialogtable size in INTs *)
+       mchm                          = 20,  (* max channels for module *)
+       offset sh version             = 4,
+       offset sh structureversion    = 5,
+       offset shardlength            = 6,
+
+       do name = "PrOgRaM tO Do";
+
+LET  UNSIGNED  = INT,
+     VARIABLES = ROW mdts ROW mchm INT;
+TEXT CONST variables var xxv :: "ROW " + text (mdts) + " ROW "+
+                                text (mchm) + " INT VARxxv;";
+
+VARIABLES VAR v;             (* siehe give me / take you *)
+
+INT  VAR max index;          (* Information für new index *)
+
+INT  VAR channels of module; (* Information für channels of this module *)
+
+TEXT VAR actual info;        (* fuer write info *)
+
+ROW 256 INT VAR channel table of new shard;  (* für channel free *)
+
+DATASPACE VAR dummy ds;      (* für print configuration *)
+
+REAL VAR new shard length;
+
+(***************************************************************************)
+(************* Hier geht's los...... ***************************************)
+(***************************************************************************)
+
+(******************** configurate module **********************************)
+
+PROC configurate module (MODUL VAR  new shard, MODUL CONST old shard,
+                         BOOL CONST old shard valid, want automatic mode,
+                         TEXT CONST modulname) :
+  do configurate module (new shard, old shard, old shard valid,
+                      want automatic mode, modulname, FALSE)
+END PROC configurate module;
+
+(********************** print configuration *******************************)
+
+PROC print configuration (MODUL CONST old shard, TEXT CONST modulname) :
+  (* Es ist hier schon sichergestellt, daß old shard valid ist und das Modul
+     auch im SHard enthalten
+  *)
+  forget (dummy ds); dummy ds := nilspace;
+  BOUND MODUL VAR dummy :: dummy ds;
+  do configurate module (dummy, old shard, TRUE, FALSE, modulname, TRUE);
+  forget (dummy ds).
+END PROC print configuration;
+
+
+(******************* do configurate module *********************************)
+
+PROC do configurate module (MODUL VAR  new shard, MODUL CONST old shard,
+                            BOOL CONST old shard valid, want automatic mode,
+                            TEXT CONST modulname,
+                            BOOL CONST print configuration only):
+  (* In dieser Prozedur ist die Beschränkung auf Module mit unter 32kB
+     Länge ausgenutzt.
+     Ist kein alter SHard vorhanden, so muss ein leerer SHard übergeben
+     werden (d.h. alle Einträge in der Kanaltabelle sind 0).
+     Ein alter SHard darf keinesfalls unterschiedliche releases desselben
+     Modultyps enthalten.
+     Resultierende SHardgesamtlängen von über 32k sind noch nicht getestet.
+  *)
+  BOUND MODUL VAR m;
+  INT VAR  (***** Daten über das neue Modul *****)
+           sh version, sh structure version, release,
+           max ccb, nr of ccbs,
+           dtcb table entries, offset dtcb table, (* Variablentabellen *)
+           ccb  table entries, offset ccb  table,
+           muster ccb length, offset muster ccb, (* Muster-ccb im Modul *)
+           module body length,  (* Länge des zu kopierenden Modulrumpfs *)
+           offset module body, offset dtcb;
+  TEXT VAR modultyp; (* 4 Byte *)
+  INT VAR  (***** Daten über den alten SHard *****)
+           old release :: -2;  (* garantiert inkompatibel *)
+  REAL VAR offset old dtcb :: 0.0;
+  ROW nr of channels total REAL VAR offset old ccb;
+  BOOL VAR old cbs valid :: FALSE;
+  THESAURUS VAR old channels :: empty thesaurus;
+  (***** Daten über den neuen SHard *****)
+  REAL VAR dtcb location;
+  ROW nr of channels total REAL VAR ccb location;
+  (***** Sonstige Daten *****)
+  INT  VAR i, k, kanal, ccb count;
+  BOOL VAR automatic mode, configurate :: NOT print configuration only;
+  reset direction (FALSE); (* zur Sicherheit *)
+  IF configurate
+  THEN new shard length := unsigned (int (new shard, offset shard length)) FI;
+  connect module;
+  get module data;
+  test sh version compatibility;      (* ggf. LEAVE *)
+  (* Bisher wurde nur gelesen, ab jetzt darf nicht mehr abgebrochen werden *)
+  search old shard for module and find all old ccbs;
+  test release compatibility;         (* ggf. LEAVE *)
+  IF configurate
+  THEN write module with dtcb to shard;
+       perhaps set automatic mode;
+  FI;
+  configurate dtcb;
+  IF configurate
+  THEN kopf;
+       select channels;
+       write ccbs to shard;
+  ELSE nr of ccbs := highest entry (old channels)
+  FI;
+  configurate ccbs;
+  IF configurate
+  THEN make entries in channeltable of new shard;
+       int (new shard, offset shardlength, unsigned (new shard length))
+  FI.
+
+connect module :
+  m := old (modulname);
+  actual info := info (m);
+  IF configurate
+  THEN kopf
+  ELSE put ("-----"); put (modulname); putline ("-----")
+  FI.
+
+get module data :
+  (* Format des Moduls in den ersten Bytes:
+     Byte    Entry
+     0/1     offset dtcb variablen tabelle
+     2/3     offset ccb  variablen tabelle
+     4/5     offset muster-ccb
+     6/7     offset modulrumpf
+     8/9     offset dtcb
+     10/11   max anzahl ccbs
+     die tabellen enthalten im ersten Wort die Anzahl ihrer Einträge
+     der modulrumpf und der ccb ihre Länge in Byte
+     die Länge der Tabellen ergibt sich aus den offset-Differenzen.
+     dtcb-Format : Modultyp (4 Byte)
+                   SHardversion (1 Byte)
+                   SHardstrukturversion (1 Byte)
+                   Modulrelease (2 Byte)     ....
+  *)
+  max ccb := int (m, 10);
+  offset dtcb table  := int (m, 0);
+  dtcb table entries := int (m, offset dtcb table);
+  offset ccb table   := int (m, 2);
+  ccb  table entries := int (m, offset ccb table);
+  offset muster ccb  := int (m, 4);
+  muster ccb length  := int (m, offset muster ccb);
+  offset module body := int (m, 6);
+  module body length := int (m, offset module body);
+  offset dtcb        := int (m, 8);
+(*****
+put ("  offset dtcb table:"); put(       offset dtcb table); line;
+put ("  dtcb table entrie:"); put(      dtcb table entries); line;
+put ("  offset ccb table :"); put(       offset ccb table);  line;
+put ("  ccb  table entrie:"); put(      ccb  table entries); line;
+put ("  offset muster ccb:"); put(       offset muster ccb); line;
+put ("  muster ccb length:"); put(       muster ccb length); line;
+put ("  offset module bod:"); put(      offset module body); line;
+put ("  module body lengt:"); put(      module body length); line;
+put ("  offset dtcb      :"); put(       offset dtcb);       line;*****)
+  modultyp            := text (m, offset dtcb, 4);
+  sh version          := byte (m, offset dtcb + 4);
+  sh structureversion := byte (m, offset dtcb + 5);
+  release             := int  (m, offset dtcb + 6).
+
+test sh version compatibility :
+  IF configurate AND NOT version is compatible
+  THEN putline ("Das Modul ist mit dieser SHard-Version nicht mehr verträglich.");
+       putline (""10""10""15"  Installation des Moduls wird abgebrochen.  "14""7""13""10"");
+       go on;
+       LEAVE do configurate module
+  FI.
+
+version is compatible:
+  (* Kompatibel, wenn das Modul eine ältere oder gleiche sh version verlangt
+     und die gleiche sh structureversion
+  *)
+  sh version <= byte (new shard, offset sh version) CAND
+  sh structure version = byte (new shard, offset sh structureversion).
+
+search old shard for module and find all old ccbs :
+  (* Es werden alle Kanäle des alten SHard untersucht, ob der dortige Treiber
+     den gleichen Modultyp hat und in diesem Fall die Kanalnummer in
+     "old channels" gesammelt, sowie offset old ccb gemerkt, im Nichterfolgs-
+     falle wird offset old ccb auf diesem Kanal 0 gesetzt.
+     Es werden auch alle verketteten Treiber untersucht.
+     Auch old cbs valid und offset old dtcb werden ggf. gesetzt.
+  *)
+  IF NOT old shard valid
+  THEN LEAVE search old shard for module and find all old ccbs  FI;
+  IF configurate THEN put ("Ich untersuche den alten SHard :")  FI;
+  FOR kanal FROM 0 UPTO nr of channels total - 1 REP
+    IF configurate THEN cout (kanal)  FI;
+    collect ccbs on this channel
+  PER;
+  IF configurate THEN put (""13""5"")  FI.  (* Zeile löschen *)
+
+collect ccbs on this channel :
+  REAL VAR p dtcb :: sh dtcb offset (old shard, kanal),
+           p ccb  :: sh ccb offset (old shard, kanal);
+  WHILE p dtcb <> 0.0 AND p ccb <> 0.0 REP
+    BOOL CONST success :: text (old shard, p dtcb, 4) = modultyp;
+    IF success
+    THEN offset old dtcb := p dtcb;
+         old release     := int (old shard, p dtcb + 6.0);
+         insert (old channels, text (kanal));
+         offset old ccb [kanal+1] := p ccb
+    ELSE p dtcb := unsigned (int (old shard, p ccb + 2.0));  (* verkettet *)
+         p ccb  := unsigned (int (old shard, p ccb + 4.0))
+    FI
+  UNTIL success  PER;
+  old cbs valid := old shard valid AND offset old dtcb <> 0.0 AND
+                   (release = old release + 1 OR release = old release).
+
+test release compatibility:
+  IF print configuration only AND NOT old cbs valid
+  THEN putline ("Kein Zugriff auf die Konfigurationsdaten möglich");
+       LEAVE do configurate module
+  FI.
+
+write module with dtcb to shard :
+  put ("Modul """ + modulname + """ wird in den SHard eingetragen :");
+  IF int (new shard length MOD 2.0) <> offset module body MOD 2
+  THEN new shard length INCR 1.0  FI;   (* kopiert so schneller *)
+  dtcb location := new shard length +
+                      real (offset dtcb - offset module body);
+  copy (m, real (offset module body), new shard, new shard length,
+        module body length);
+  new shard length INCR real (module body length).
+
+perhaps set automatic mode :
+  IF old cbs valid AND old release = release
+  THEN automatic mode := want automatic mode
+  ELSE automatic mode := FALSE  FI.
+
+configurate dtcb :
+  IF configurate
+  THEN kopf;
+       putline ("Konfiguration des Treibers :");
+       get new channel table (new shard, channel table of new shard);
+  FI;
+  perform dtcb dialogue (m, real (offset dtcb table+2), dtcb table entries,
+                         new shard, dtcb location,
+                         old shard, offset old dtcb,
+                         old cbs valid, release = old release,
+                         dtcb refinements (m), dtcb abfragen (m),
+                         automatic mode, print configuration only).
+
+select channels :
+  ccb count := highest entry (old channels);
+  k := min (ccb count, max ccb); (* .... Mutter der Porzellankiste *)
+  nr of ccbs := max (k, 1);
+  IF automatic mode THEN LEAVE select channels  FI;
+  IF max ccb > 1
+  THEN REP
+         editget ("Wieviele Kanäle mit diesem Treiber (1 bis " +
+                  text (max ccb) + ") : ", nr of ccbs);
+         out (""13"")
+       UNTIL nr of ccbs IN range (1, max ccb)  PER;
+       out (""10""10"")
+  ELSE nr of ccbs := 1  FI;
+  IF nr of ccbs < ccb count  (* weniger als früher *)
+  THEN put ("Wählen Sie mindestens"); putline (x kanäle aus deren);
+       putline ("Werte nicht als Vorbesetzung angeboten werden sollen"10"");
+       REP
+         THESAURUS CONST help :: certain (old channels, empty thesaurus);
+         IF NOT enough refused THEN out (""7"")  FI
+       UNTIL enough refused  PER;
+       old channels := old channels - help;
+       out (""3""3""3""4"")  (* clear screen from incl. "Wählen..." on *)
+  FI.
+
+x kanäle aus deren :
+  IF ccb count - nr of ccbs > 1
+  THEN text (ccb count - nr of ccbs) + " Kanäle aus, deren"
+  ELSE "einen Kanal aus, dessen"  FI.
+
+enough refused :
+  highest entry (help) >= ccb count - nr of ccbs.
+
+write ccbs to shard :
+  (* Ausserdem wird hier ccb location vorbereitet *)
+  out ("Die Kanäle werden in den neuen SHard eingetragen : ");
+  FOR i FROM 1 UPTO nr of ccbs REP
+    ccb location [i] := new shard length;
+    copy (m, real (offset muster ccb + 2), new shard, new shard length,
+         muster ccb length);
+    new shard length INCR real (muster ccb length)
+  PER.
+
+configurate ccbs :
+  (*put (old shard valid); put ("Release:"); put (release); put ("  old release:"); put (old release);
+    put (old cbs valid); pause;*)
+  IF configurate
+  THEN out (""13""10"Konfiguration der Kanäle:"13""10"");
+       get new channel table (new shard, channel table of new shard)  
+  FI;
+  ccb count := 0;
+  FOR kanal FROM 0 UPTO nr of channels total REP
+    IF old channels CONTAINS text (kanal)
+    THEN ccb count INCR 1;
+         offset old ccb [ccb count] := offset old ccb [kanal+1]
+    FI
+  PER;
+  FOR i FROM ccb count + 1 UPTO nr of ccbs REP
+    offset old ccb [i] := 0.0
+  PER;
+  perform ccb dialogue (m, real (offset ccb table+2), ccb table entries,
+                        new shard, ccb location,
+                        old shard, offset old ccb,
+                        nr of ccbs,
+                        offset old dtcb <> 0.0, release = old release,
+                        ccb refinements (m), ccb abfragen (m),
+                        automatic mode, print configuration only).
+
+make entries in channeltable of new shard :
+  kopf;
+  out ("Konfigurationsdaten werden in den neuen SHard eingetragen : ");
+  FOR i FROM 1 UPTO nr of ccbs REP
+    cout (i);
+    kanal := (*v[1][i]falsch???!!!*) byte (new shard, ccb location [i]);
+    make entry in channeltable of new shard
+  PER.
+
+make entry in channeltable of new shard :
+  IF NOT channel free (kanal)
+  THEN (* dtcb/ccb Adresse aus channel table nach neuem ccb umtragen. *)
+       int (new shard, ccb location [i] + 2.0,
+            unsigned (sh dtcb offset (new shard, kanal)));
+       int (new shard, ccb location [i] + 4.0,
+            unsigned (sh ccb offset (new shard, kanal)));
+  ELSE (* Folge-dtcb/ccb Adresse auf 0 setzen *)
+       int (new shard, ccb location [i] + 2.0, 0);
+       int (new shard, ccb location [i] + 4.0, 0);
+  FI;
+  (* Jetzt neue Adresse in channel table eintragen *)
+  sh dtcb offset (new shard, kanal, dtcb location);
+  sh ccb  offset (new shard, kanal, ccb location [i]);
+  k := byte (new shard, ccb location [i] + 1.0);  (* Zusatzkanalnummer *)
+  IF k <> 255  (* 255 = kein Zusatzkanal vorhanden *)
+  THEN (* IF NOT channel free (k) THEN alter eintrag futsch !!! *)
+       sh dtcb offset (new shard, k, dtcb location);
+       sh ccb  offset (new shard, k, ccb location [i])
+  FI.
+
+kopf :
+  write head ("""" + modulname + """ in den SHard aufnehmen");
+  out (actual info);
+  out (""13""10"").
+END PROC do configurate module;
+
+
+(********************* perform dialogue ************************************)
+
+PROC perform dtcb dialogue
+   (MODUL VAR m,          REAL CONST offset dialogue table, 
+    INT CONST dialogue table entries,
+    MODUL VAR   dtcb,     REAL CONST offset dtcb,
+    MODUL CONST old dtcb, REAL CONST offset old dtcb,
+    BOOL CONST old dtcb valid, same release,
+    TEXT CONST refinements, INT CONST count,
+    BOOL CONST automatic mode, print configuration only):
+  ROW nr of channels total REAL VAR offset cb, offset old cb;
+  offset cb [1]     := offset dtcb;
+  offset old cb [1] := offset old dtcb;
+  perform dialogue (TRUE, m, offset dialogue table, dialogue table entries,
+                    dtcb, offset cb, old dtcb, offset old cb, 1,
+                    old dtcb valid, same release, refinements, count,
+                    automatic mode, print configuration only).
+END PROC perform dtcb dialogue;
+
+PROC perform ccb dialogue
+   (MODUL VAR m,         REAL CONST offset dialogue table, 
+    INT CONST dialogue table entries,
+    MODUL VAR   ccb,     ROW nr of channels total REAL CONST offset ccb,
+    MODUL CONST old ccb, ROW nr of channels total REAL CONST offset old ccb,
+    INT CONST nr of ccbs, BOOL CONST old ccbs valid, same release,
+    TEXT CONST refinements, INT CONST count,
+    BOOL CONST automatic mode, print configuration only) : 
+  perform dialogue (FALSE, m, offset dialogue table, dialogue table entries,
+                    ccb, offset ccb, old ccb, offset old ccb, nr of ccbs,
+                    old ccbs valid, same release, refinements, count,
+                    automatic mode, print configuration only).
+END PROC perform ccb dialogue;
+
+
+PROC perform dialogue
+  (BOOL CONST is dtcb,
+  MODUL VAR m,       REAL CONST offset dialogue table, 
+  INT CONST dialogue table entries,
+  MODUL VAR   cb,     ROW nr of channels total REAL CONST offset cb,
+  MODUL CONST old cb, ROW nr of channels total REAL CONST offset old cb,
+  INT CONST nr of cbs, BOOL CONST old cb valid, same release,
+  TEXT CONST refinements, INT CONST refinement count,
+  BOOL CONST automatic mode, print configuration only) : 
+  (* Konfigurationsdialog für einen (Satz von) Kontrollblock(s) oder bloßes
+     Anzeigen der Konfigurationsdaten derselben.
+
+  1. bei NOT print configuration only:
+     Führt den Dialog für eine Tabelle (also ccb oder dtcb Variablentabelle) 
+     durch und bestückt den controlblock entsprechend. 
+     Es wird gleich eine ganze Tabelle von controlblocks (max. mchm Stück)
+     abgearbeitet und zwar nr of cbs Stück; im Falle is dtcb wird natürlich
+     nur der Eintrag 1 der Tabellen benutzt (vom Aufrufer).
+     Das Eingabemodul ist m mit der zu bearbeitenden Tabelle an der Stelle
+     offset dialogue table. Die Tabelle enthält dialogue table entries
+     Einträge (max. mdts Stück !)
+     Die Ausgabe des Prozesses landet im Modul cb ab den Stellen offset cb.
+     cb ist dabei jeweils der neue SHard, damit man nicht das Modul ändert.
+     Die Vorlagen zum Abgucken liefert, falls old cb valid ist, das
+     Modul old cb (der alte SHard) ab offset old cb, dabei ist die Struktur
+     gleich der neuen, wenn same release gilt, andernfalls sind die
+     Vorversionsoffsets zu benutzen (Versionsnummer um genau 1 erhöht).
+     Bei automatic mode werden nur still diese Vorgabewerte übernommen.
+     Die Elan-Teile für den Dialog liefert schliesslich der Text refinements,
+     er enthält refinement count Abfragen der Namen r1, r2, .....
+     Wenn refinent count = 0 ist, passiert hier eigentlich nichts,
+     deshalb sollte dann
+     für eine korrekte Initialisierung auch die Variablentabelle leer sein;
+     ist sie es allerdings doch nicht, werden hier noch die Standardwerte in
+     die ccbs eingetragen und nur der leere Dialog unterdrückt.
+     Vor Beginn/Nach Ende des gesamten Dialogs wird das refinement
+     dialoguestart/dialogueend aufgerufen; bei NOT is dtcb vor/nach dem Dialog
+     jedes Kanals auch noch channelstart/channelend.
+
+  2. bei print configuration only:
+     Die Daten zum new shard werden überhaupt nicht benutzt, von den
+     refinements wird nur für jeden Kanal einmal "print configuration"
+     aufgerufen.
+  *)
+  REAL VAR table byte :: offset dialogue table;
+  ROW mdts INT VAR offset, old offset, length;
+  INT  VAR i, k;
+  BOOL VAR configurate :: NOT print configuration only;
+  TEXT VAR program, t;
+  IF print configuration only       (* Hier wird evtl. schon verlassen *)
+  THEN startup for print
+  ELSE startup for dialogue  FI;
+  IF refinement count > 0 THEN build program  FI;
+  build data in v;
+  IF refinement count > 0 THEN do program  FI;
+  IF configurate THEN put values in cb  FI.
+
+startup for print :
+  IF refinement count = 0 OR dialogue table entries = 0
+  THEN LEAVE perform dialogue  FI.
+
+startup for dialogue:
+  IF refinement count = 0
+  THEN putline ("Keine Konfiguration notwendig.");
+       IF dialogue table entries = 0
+       THEN pause (20); LEAVE perform dialogue  FI
+  ELSE putline ("Die Konfiguration wird vorbereitet.")  FI.
+
+build program:
+  max index := refinement count;  (* damit new index bescheid weiss *)
+  program := variables var xxv;
+  program cat main part;
+  perhaps program cat data refinements;
+  program CAT refinements.
+
+program cat main part :
+  program CAT "LET UNSIGNED=INT;giveme(xxv);INT VARxxi::1,actchannel;";
+  IF print configuration only OR automatic mode
+  THEN program cat main part for print or automatic mode
+  ELSE program cat main part for dialogue  FI.
+
+program cat main part for print or automatic mode:
+  (* Leider muss man, wenn man den Modulprogrammierer bei den .ccb und .dtcb
+     Teilen nicht zu stark reglementieren will, einiges mitübersetzen, was
+     dann gar nicht benutzt wird (z.B. alle Refinements).
+           Und der Gedanke macht ihn blaß,
+           wenn er fragt: was kostet das ?
+                                     Wilhelm Busch
+  *)
+  program CAT "FORactchannelFROM 1 UPTOchannelsofthismoduleREP";
+  IF print configuration only
+  THEN program CAT "printconfigurationPER."
+  ELSE (* automatic mode: *) program CAT "automaticPER;takeyou(xxv)."
+  FI;
+  program CAT " xxa:actchannel. thischannel:";
+  IF NOT is dtcb THEN program CAT "channelstart;"  FI;
+  FOR i FROM 1 UPTO refinement count REP
+    program CAT "r";         (* Alle in this channel aufrufen, damit  *)
+    program CAT text (i);    (* "LEAVE this channel" kein Fehler ist. *)
+    program CAT ";"
+  PER;
+  IF NOT is dtcb
+  THEN program CAT "channelend"  FI;
+  program CAT ". ".
+
+program cat main part for dialogue:
+  program CAT "dialoguestart;FORactchannelFROM 1 UPTOchannelsofthismoduleREP";
+  program CAT "thischannelPER;dialogueend;takeyou(xxv). ";
+  program CAT "xxa:actchannel. thischannel:";
+  IF NOT is dtcb THEN program CAT "channelstart;"  FI;
+  program CAT "REP SELECTxxiOF ";
+  FOR i FROM 1 UPTO refinement count REP
+    program CAT "CASE ";
+    program CAT text (i);
+    program CAT ":r";
+    program CAT text (i);
+    program CAT " "
+  PER;
+  program CAT "ENDSELECT UNTIL NOTnewindex(xxi)PER";
+  IF NOT is dtcb
+  THEN program CAT ";channelend;reservechannel(xxv[1][xxa])"  FI;
+  program CAT ". ".
+
+perhaps program cat data refinements :
+  FOR i FROM 1 UPTO dialogue table entries REP
+    IF configurate THEN cout (i)  FI;
+    read start of next table entry; (* must be done in autom. mode, too,  *)
+    t := next variable name;        (* to get offset/oldoffset/length [i] *)
+    program CAT t;
+    program CAT ":xxv[";
+    program CAT text (i);
+    program CAT "][xxa]. ";  (* Das war der normale Eintrag "varname" *)
+    program CAT t;           (* Jetzt der für alle Kanäle "varname k" *)
+    program CAT "k:xxv[";
+    program CAT text (i);
+    program CAT "]. "
+  PER.
+
+read start of next table entry :
+  (* Format der Einträge in den Variablentabellen:
+     dw offset in cb
+     dw offset in old cb (oder ffffh falls neu)
+     db Typ (d.h. Länge und ist 1 oder 2)
+     db Namenslänge
+     db ...(Name)...
+  *)
+  INT CONST length of variable :: byte (m, table byte + 4.0),
+            length of name     :: byte (m, table byte + 5.0);
+  old offset [i] := int (m, table byte + 2.0);  (* Diese Sammlung *)
+  offset [i]     := int (m, table byte);  (* bereitet das Datenholen vor *)
+  length [i]     := length of variable;
+  IF length of variable < 1 OR length of variable > 2
+  THEN errorstop ("invalid variablelength : " + text (length of variable))
+  FI;
+  table byte INCR 6.0.
+
+next variable name:
+  table byte INCR real (length of name);
+  text (m, table byte - real (length of name), length of name).
+
+build data in v :
+  FOR k FROM 1 UPTO nr of cbs REP  (* Kanäle *)
+    IF configurate THEN cout (k)  FI;
+    FOR i FROM 1 UPTO dialogue table entries REP  (* Variablen *)
+      v[i][k] := next init value
+    PER
+  PER.
+
+next init value :
+  IF old cb valid CAND old cb present CAND value accessible
+  THEN value from old cb
+  ELSE value from new cb  FI.
+
+old cb present :
+  offset old cb [k] > 0.0.
+
+value accessible :
+  same release OR
+  (* Ein release zuvor und Variable gibts schon: *) old offset [i] <> -1.
+
+value from old cb :
+  IF length [i] = 1
+  THEN byte (old cb, offset old cb [k] + real (offset of old value))
+  ELSE int  (old cb, offset old cb [k] + real (offset of old value))
+  FI.
+
+value from new cb :
+  IF length [i] = 1
+  THEN byte (cb, offset cb [k] + real (offset [i]))
+  ELSE int  (cb, offset cb [k] + real (offset [i]))  FI.
+
+offset of old value :
+  IF same release
+  THEN offset [i]
+  ELSE old offset [i]  FI.
+
+do program :
+  reset direction (TRUE);
+  channels of module := nr of cbs;
+  IF setup testing
+    THEN (* für diesen THEN-Teil beim abgespeckten Eumel
+            setup eummel mini eumel dummies insertieren *)
+         forget (do name, quiet);
+         FILE VAR f := sequentialfile (output, do name);
+         putline (f, program);
+         (*edit (do name);*)
+         run (do name);
+         forget(do name, quiet);
+    ELSE do (program);
+  FI;
+  program := "";  (* Platz sparen *)
+  reset direction (FALSE).
+
+put values in cb :
+  FOR k FROM 1 UPTO nr of cbs REP
+    cout (k);
+    FOR i FROM 1 UPTO dialogue table entries REP
+      IF length [i] = 1 THEN put byte ELSE put int  FI
+    PER;
+  PER.
+
+put byte :
+  byte (cb, offset cb [k] + real (offset [i]), v[i][k]).
+
+put int :
+  int  (cb, offset cb [k] + real (offset [i]), v[i][k]).
+END PROC perform dialogue;
+
+(****************** give me, take you, new index ***************************)
+
+(* Diese Prozeduren werden aus dem do beim perform dialogue heraus aufgerufen
+   Sie dienen zur Kommunikation mit den Paketdaten dieses Pakets (give me,
+   take you) oder zur Verkleinerung des do-Programms (new index)
+*)
+
+PROC give me (VARIABLES VAR variables) :
+  (* Der Sinn dieser Prozedur besteht in Folgendem :
+     bei perform dialogue wird in dem do, das die refinements des
+     SHard-Moduls ausführt, eine Datenstruktur vom Typ VARIABLES aufgebaut,
+     die alle in den Variablentabellen des Moduls aufgeführten Variablen
+     enthält und einzeln über passend benannte refinements zugänglich macht.
+     Diese Datenstruktur wird zuvor in diesem Paket hier initialisiert mit
+     Initwerten aus der Variablentabelle oder wenn möglich mit den
+     entsprechenden Werten aus dem alten SHard. Mit give me fordert das
+     do-Programm die initialisierte Datenstruktur aus diesem Paket hier an.
+     Im do wird am Schluss mit take you diese Datenstruktur an dieses Paket
+     (und damit an perform dialogue) zurückgegeben, damit die durch den
+     Dialog gesetzten Werte in den neuen SHard eingetragen werden können.
+     Eine alternative Methode, diese Kommunikation zu realisieren, wäre die
+     Benutzung von BOUND VARIABLES VARs mit demselben Datenraum.
+   *)
+  variables := v
+END PROC give me;
+
+PROC take you (VARIABLES CONST variables) :
+  (* Gegenstück zu give me, siehe dort *)
+  v := variables
+END PROC take you;
+
+BOOL PROC new index (INT VAR index) :
+  (* Verändert den Index je nach der direction und fragt bei down am Ende,
+     ob fertig. Liefert, ob es noch weitergehen soll (falls nein: index = 1)
+  *)
+  LET up     = ""3"",
+      down   = ""10"",
+      error  = ""0"";
+  TEXT CONST old direction :: direction;
+  reset direction (TRUE);
+  IF old direction = error   (* Bei Fehlern immer stehenbleiben *)
+  THEN TRUE
+  ELIF index = max index     (* am Schluss aufhören oder nach 1 springen *)
+  THEN perhaps end
+  ELIF index = 1 AND old direction = up  (* bei 1 und up an den Schluss *)
+  THEN index := max index; TRUE
+  ELSE normal new index     (* sonst je nach direction up oder down *)
+  FI.
+
+perhaps end :  (* index = max index *)
+  IF old direction = up AND max index > 1    (* hoch vom Ende *)
+  THEN index DECR 1;
+       TRUE
+  ELIF old direction = up
+  THEN TRUE
+  ELIF old direction = down                  (* runter am Ende *)
+  THEN index := 1;
+       TRUE
+  ELSE reset direction (FALSE);          (* normal oder runter ans Ende *)
+       index := 1;
+       BOOL CONST ready :: yes (1, 23, "Fertig", FALSE);
+       reset direction (TRUE);
+       NOT ready
+  FI.
+
+normal new index :
+  IF old direction = up
+  THEN index DECR 1; TRUE
+  ELSE index INCR 1; TRUE  FI.
+END PROC new index;
+
+(******************** channel (table) handling *****************************)
+
+BOOL PROC channel free (INT CONST nr,
+                        ROW 256 INT CONST channel table of shard) :
+  IF nr < 0 OR nr > nr of channels total
+  THEN FALSE
+  ELSE channel table of shard [index ccb offset] = 0  FI.
+
+index ccb offset :
+  2 * nr + 1 + 1.
+END PROC channel free;
+
+BOOL PROC channel free (INT CONST nr) :
+  channel free (nr, channel table of new shard).
+END PROC channel free;
+
+PROC reserve channel (INT CONST nr,
+                      ROW 256 INT VAR channel table of shard) :
+  IF nr >= 0 AND nr < nr of channels total
+  THEN channel table of shard [index ccb offset] := 1  (* nichtnull *)  FI.
+
+index ccb offset :
+  2 * nr + 1 + 1.  (* Start nicht bei 0 und ccb hinter dtcb *)
+END PROC reserve channel;
+
+PROC reserve channel (INT CONST nr) :
+  reserve channel (nr, channel table of new shard).
+END PROC reserve channel;
+
+(*THESAURUS PROC free channels (ROW 256 INT VAR channel table of shard):
+  (* Liefert einen THESAURUS, der die Klartextform genau aller in
+     channel table of shard als frei angegebenen Kanäle enthält.
+  *)
+  INT VAR i;
+  THESAURUS VAR result :: empty thesaurus;
+  FOR i FROM 1 UPTO nr of channels total REP
+    IF channel free (i, channel table of shard)
+    THEN insert (result, text (i))  FI
+  PER;
+  result.
+END PROC free channels;*)
+
+INT PROC channels of this module :
+  channels of module.
+END PROC channels of this module;
+
+(********************* write info, buffer adress **************************)
+
+PROC write info :
+  putline (actual info)
+END PROC write info;
+
+INT PROC buffer address (INT CONST buffer size):
+  IF new shard length MOD 2.0 <> 0.0 THEN new shard length INCR 1.0 FI;
+  INT CONST buf adr := unsigned (new shard length);
+  new shard length INCR real (buffer size);
+  IF new shard length >= 65536.0 OR buffer size > 1024
+    THEN errorstop ("zu großer Puffer verlangt")
+  FI;
+  buf adr
+END PROC buffer address;
+
+(************************* Hilfsprozeduren *******************************)
+
+PROC elan (INT CONST mode, DATASPACE CONST source, TEXT CONST line,
+           INT VAR start module nr, BOOL CONST new init, ins, dump, lst,
+           sys, coder, rt check, sermon) :
+  EXTERNAL 256
+END PROC elan;
+
+PROC do (TEXT CONST long line) :
+  DATASPACE VAR ds;
+  INT VAR module nr :: 0;
+  elan (2, ds, long line, module nr, FALSE, FALSE, FALSE, FALSE,
+        FALSE, FALSE, FALSE, FALSE);
+  forget (ds);
+  no do again
+END PROC do;
+
+PROC go on :
+  put ("   >>>>> Taste drücken zum Weitermachen  ");
+  REPEAT UNTIL incharety (2) = ""  PER;
+  pause;
+  line.
+END PROC go on;
+
+END PACKET setup eumel modulkonfiguration;
+
diff --git a/system/setup/3.1/src/setup eumel 4: dienstprogramme b/system/setup/3.1/src/setup eumel 4: dienstprogramme
new file mode 100644
index 0000000..9ce9ca3
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 4: dienstprogramme
@@ -0,0 +1,218 @@
+ 
+(**************************************************************************)
+(***** Dienstprogramme für Modulprogrammierer             *****************)
+(***** Copyright (c) 1987, 1988                           *****************)
+(***** Lutz Prechelt, Karlsruhe                           *****************)
+(**************************************************************************)
+
+PACKET setup eumel dienstprogramme            (* Copyright (c) 1987 by    *)
+DEFINES                                       (* Lutz Prechelt, Karlsruhe *)
+   file as one text,                          (* Stand : 07.05.88   1.4   *)
+   ich schreibe jetzt ein neues shard modul,  (* Eumel 1.8.1              *)
+   link shard module,
+   all modules:
+
+(* Dies sind Dienstprogramme, die der Modul-Programmierer braucht *) 
+
+(* Das Format der Refinementdateien für den dtcb- und ccb-Setupdialog ist wie
+   folgt:
+   1. Zeile: INT-Denoter für die Anzahl von Abfragerefinements, die drin sind
+             Rest der Zeile muß leer sein.
+   Danach  : lauter ELAN-Refinements mit den Namen r1, r2 usw.
+             evtl. weitere Refinements zur Hilfe mit beliebigen Namen (es
+             gibt ein paar Ausnahmen, über die man beim ersten Test dann aber
+             stolpert.)
+   In den Refinements dürfen Variablen vereinbart werden. Vor dem ersten
+   refinement der Datei darf KEIN Punkt sein (es ist sowieso schlechter
+   Stil, die Punkte nicht hinter die vorherige Zeile zu setzen, sondern
+   vor den refinementnamen.), hingegen MUSS nach dem letzten Refinement der
+   Datei ein Punkt stehen.
+   Wer das für nötig hält, kann auch Prozeduren definieren und verwenden,
+   was allerdings nicht geht, sind Pakete.
+   Wenn man mit Kommentaren und sonstigen Bytefressern sparsam
+   umgeht, läuft der Dialog beim Setup später etwas schneller an.
+*)
+
+LET modul namentyp         = "SHardmodul *";
+
+DATASPACE VAR ds;
+
+(***************************************************************************)
+
+THESAURUS PROC all modules (THESAURUS CONST th):
+  (* Hier wird schlabberig nach Namen ausgewählt, während der Setup Eumel
+     im Betrieb die Datenraumtypen als Auswahlkriterium verwendet.
+     Die Schwierigkeiten, die bei Nichteinhalten der Namenskonventionen
+     entstehen, veranlassen hoffentlich jeden zur nötigen Disziplin...
+  *)
+  (th LIKE "SHardmodul *") - (th LIKE "SHardmodul *.ccb")
+  - (th LIKE "SHardmodul *.dtcb") - (th LIKE "SHardmodul *.info")
+END PROC all modules;
+
+(*****THESAURUS PROC all modules:        wird sauber in Teil 2 realisiert
+  all modules (all)
+END PROC all modules;
+*****)
+
+(********************* link shard module *********************************) 
+
+PROC link shard module:
+  TEXT VAR module :: std;
+  REPEAT 
+    page; 
+    putline ("          L I N K   S H A R D - M O D U L E"); line (2);
+    put ("Modulname:"); editget (module); line (2); 
+    link shard module (module); line;
+  UNTIL NOT yes ("noch ein Modul linken", FALSE)  PER 
+END PROC link shard module;
+
+PROC link shard module (THESAURUS CONST th):
+   do (PROC (TEXT CONST) link shard module, th);
+END PROC link shard module;
+
+PROC link shard module (TEXT CONST module): 
+  (* Ruft link shard module (modul, dtcb, ccb, info) unter Anwendung von
+     Namenskonventionen (nämlich entsprechende Suffixe ".dtcb" etc.) auf.
+  *)
+  TEXT VAR dtcb, ccb, info;
+  BOOL VAR elan neu;
+  dtcb := module + ".dtcb"; 
+  ccb  := module + ".ccb"; 
+  info := module + ".info"; 
+  perhaps change filenames;
+  elan neu := yes (module + ": neue Elan Teile machen", FALSE);
+  IF elan neu THEN neue elan teile machen  FI;
+  link shard module (module, dtcb, ccb, info);
+  IF elan neu THEN check syntax FI.
+
+neue elan teile machen:
+  edit (dtcb); line (2);
+  edit (ccb);  line (2);
+  edit (info); page.
+
+perhaps change filenames:
+(*put ("Datei mit dtcb-refinements :"); editget (dtcb); line;
+  put ("Datei mit  ccb-refinements :"); editget (ccb);  line;
+  put ("Datei mit Infotext         :"); editget (info); line (2)*) .
+
+check syntax :
+  line (2); put (module); putline (": Syntax-Check");
+  forget (ds);
+  ds := nilspace;
+  BOUND MODUL VAR m :: old (module), old shard :: ds, new shard :: ds;
+  INT VAR  offset dtcb table  :: int (m, 0),
+           dtcb table entries :: int (m, offset dtcb table),
+           offset ccb table   :: int (m, 2),
+           ccb  table entries :: int (m, offset ccb table);
+  (* Jetzt einen total verkrüppelten automatischen "perform dialogue" für
+     die Probeübersetzung der .dtcb und .ccb refinements aufrufen.
+  *)
+  perform dtcb dialogue (m, real (offset dtcb table+2), dtcb table entries,
+                         new shard, 0.0,
+                         old shard, 0.0,
+                         FALSE, FALSE,
+                         dtcb refinements (m), dtcb abfragen (m),
+                         TRUE, FALSE);
+  putline ("dtcb refinements O.K.");
+  ROW 40 REAL VAR x :: ROW 40 REAL : (0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,
+   0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,
+   0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,
+   0.0, 0.0);
+  perform ccb dialogue (m, real (offset ccb table+2), ccb table entries,
+                        new shard, x,
+                        old shard, x,
+                        1,
+                        FALSE, FALSE,
+                        ccb refinements (m), ccb abfragen (m),
+                        TRUE, FALSE);
+  putline ("ccb refinements O.K.");
+  forget (ds).
+END PROC link shard module;
+
+PROC link shard module (TEXT CONST module, dtcb, ccb, infofile) : 
+  IF type (old (module)) <> datenraumtyp modul CAND NOT typ aendern 
+  THEN LEAVE link shard module
+  ELSE type (old (module), datenraumtyp modul)  FI;
+  IF NOT (module LIKE modul namentyp)
+  THEN errorstop ("Module MÜSSEN Namen der Art """ + modul namentyp +
+                   """ haben")
+  FI;
+  line;
+  BOUND MODUL VAR m :: old (module); 
+  TEXT VAR dtcb ref :: file as one text (dtcb, FALSE), 
+           ccb  ref :: file as one text (ccb,  FALSE),
+           info text:: file as one text (infofile, TRUE); 
+  INT CONST pos dtcb :: pos (dtcb ref, " "), (* Ende der ersten Zeile, die *)
+            pos ccb  :: pos (ccb ref,  " "); (* die Abfragezahl enthält *)
+  INT VAR   dtcb count, ccb count;
+  dtcb count := int (subtext (dtcb ref, 1, pos dtcb)); 
+  IF NOT last conversion ok OR dtcb count < 0 OR dtcb count > 1000 
+  THEN errorstop ("keine vernünftige Zahl von dtcb Abfragen gefunden")  FI;
+  ccb count := int (subtext (ccb ref, 1, pos ccb)); 
+  IF NOT last conversion ok OR ccb count < 0 OR ccb count > 1000 
+  THEN errorstop ("keine vernünftige Zahl von ccb Abfragen gefunden")  FI;
+  (* JETZT PASSIERTS : *) 
+  dtcb abfragen (m, dtcb count); 
+  dtcb refinements (m, subtext (dtcb ref, pos dtcb + 1)); 
+  ccb abfragen (m, ccb count); 
+  ccb refinements (m, subtext (ccb ref, pos ccb + 1)); 
+  info (m, infotext);
+  line;
+  putline (""""+module+""" gelinkt. " + text (storage (old (module))) +
+           " K Datenraumgröße.").
+
+typ aendern :
+  IF type (old (module)) = 1003 (* file type *)
+  THEN putline ("(""" + module + """ hat den Typ FILE)")  FI;
+  putline ("Achtung: """ + module + """ ist nicht vom Typ eines SHard-Moduls");
+  yes ("Soll es dazu gemacht werden (Typ aufprägen)", FALSE).
+END PROC link shard module;
+
+(******************** file as one text ************************************) 
+ 
+TEXT PROC file as one text (TEXT CONST filename, BOOL CONST verbatim) : 
+  FILE VAR f :: sequential file (input, filename); 
+  TEXT VAR result :: "", t; 
+  put ("Lese """ + filename + """ :");
+  WHILE NOT eof (f) REP 
+    cout (line no (f));
+    getline (f, t);
+    work on t;
+    result CAT t
+  PER;
+  line;
+  result.
+
+work on t :
+  IF verbatim
+  THEN t CAT ""13""10""
+  ELSE t := compress (t); t CAT " "  FI.
+END PROC file as one text;
+
+(****** ich schreibe jetzt ein neues shard modul ***************************)
+
+PROC ich schreibe jetzt ein neues shard modul :
+  line (2);
+  putline ("So so, Sie wollen also ein neues SHard-Modul schreiben."); line;
+  pause (20);
+  putline ("Mir kommt es so vor, als sei heute der " + date +
+           " und im Moment gerade " + time of day + " Uhr"); line;
+  IF NOT yes ("Stimmt das ungefähr (auf 5 Minuten kommt's nicht an)", TRUE)
+  THEN do ("set date"); line (2) FI;
+  putline ("Also gut. Schreiben Sie Ihr verdammtes Modul.");
+  putline ("Aber merken Sie sich die folgenden 4 Bytes als ihren Modultyp");
+  put (""15"   ");
+  REAL VAR x :: floor (clock (1) - date ("05.05.79") - time ("10:00:00"));
+  INT VAR i;
+  FOR i FROM 1 UPTO 4 REP
+    put (int (x MOD 256.0));
+    x := floor (x / 256.0)
+  PER;
+  put ("  "14""); line (2);
+  putline ("Also : die Dinger merken (schreiben Sie sie auf, sonst vergessen Sie");
+  putline ("       sie ja doch) und NICHT MEHR ÄNDERN !");
+  line (3)
+END PROC ich schreibe jetzt ein neues shard modul;
+
+END PACKET setup eumel dienstprogramme;
+
diff --git a/system/setup/3.1/src/setup eumel 5: partitionierung b/system/setup/3.1/src/setup eumel 5: partitionierung
new file mode 100644
index 0000000..705f26d
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 5: partitionierung
@@ -0,0 +1,435 @@
+PACKET setup eumel partitionierung         (* Copyright (C) 1985       *)
+                                           (* Martin Schönbeck, Spenge *)
+DEFINES             tracks,                (* Lutz Prechelt, Karlsruhe *)
+                    sectors,               (* Änderungen: Ley    ms    *)
+                    heads,                 (* Stand: 07.04.89          *)
+                    first track,
+                    last track,
+                    partition start,
+                    partition type,
+                    partition active,
+                    partition size,
+                    partition word 0,
+
+                    get boot block,
+                    put boot block,
+                    clear partition,
+
+                  (*get bad track table,*)
+                    get bad sector table,
+                    clear partition table,
+                    setup channel,
+                    start of partition:
+
+    LET bst size             = 1024;  (* nr of bad sector table entrys *)
+
+ROW 256 INT VAR boot block;
+INT VAR boot block session := session - 1;
+INT VAR fd channel         := 28;    (* Festplatten-Setupkanal *)
+
+INT PROC setup channel:
+   fd channel
+END PROC setup channel;
+
+PROC setup channel (INT CONST new channel):
+    enable stop;
+    teste kanal typ;
+    boot block session DECR 1;
+    wirf altes pac raus;
+    fd channel := new channel;
+    sorge dafuer dass kanal uptodate ist.
+
+teste kanal typ:
+    IF (get value (1, new channel) AND 12) <> 12
+       THEN errorstop ("Hier gibt es leider keine Platte")
+    FI.
+
+wirf altes pac raus:
+    IF new channel <> fd channel
+        THEN INT VAR raus := get value (-13, fd channel);
+    FI.
+
+sorge dafuer dass kanal uptodate ist:
+   INT VAR old channel := channel; 
+   ROW 256 INT VAR dummy; INT VAR i;
+   continue (new channel);
+   disable stop;
+   blockin (dummy, -1, -1, i);
+   break (quiet);
+   continue (old channel).
+
+END PROC setup channel;
+
+PROC get bad sector table (ROW bst size REAL VAR bb tab,
+                           INT VAR bad sect, INT CONST eumel type):
+    initialisiere tabelle;
+    suche schlechte sectoren.
+
+initialisiere tabelle:
+    INT VAR i;
+    FOR i FROM 1 UPTO bst size REP
+      bb tab [i] := -1.0;
+    PER.
+
+suche schlechte sectoren:
+    INT VAR  my channel := channel;
+    REAL VAR sector := start of partition (eumel type),
+             end := sector + partition size (partition number (eumel type)),
+             track mode restart :: 0.0;
+    INT VAR  akt track := 0,
+             fehler code;
+    bad sect := 1;  (* Eintragsnr. des NÄCHSTEN schlechten Sektors *)
+    continue (fd channel);
+    disable stop;
+    DATASPACE VAR ds := nilspace;
+    REAL CONST cylinder size :: real (sectors * heads),
+               track size    :: real (sectors);
+    track mode restart := sector + track size -
+                              (sector MOD track size);
+     (* wenn sector nicht erster der spur, dann die erste einzeln *)
+    WHILE sector < end REP
+         IF sector MOD cylinder size = 0.0
+         THEN melde naechste spur  FI;
+         IF sector >= track mode restart
+         THEN check track
+         ELSE check sector  FI
+    UNTIL bad sect > bst size OR is error PER;
+    continue (my channel);
+    forget (ds);
+    enable stop;
+    IF bad sect > bst size 
+        THEN errorstop ("Zu viele schlechte Sektoren"); 
+    FI;
+    lass nicht zu dass ein ersatzsektor ein schlechter ist;
+    bad sect DECR 1.  (* ANZAHL schlechter Sektoren *)
+
+melde naechste spur:
+   break (quiet);
+   continue (my channel);
+   akt track INCR 1;
+   cout (akt track);
+   continue (fd channel).
+
+check track :
+  verify track (ds, 2, sector, fehler code);
+  IF schlechten sektor gefunden
+  THEN track mode restart := sector + tracksize
+  ELSE sector INCR track size  FI.
+
+check sector :
+  read block (ds, 2, sector, fehler code);
+  IF schlechten sektor gefunden 
+  THEN eintragen  FI;
+  sector INCR 1.0.
+
+schlechten sektor gefunden:
+    SELECT fehler code OF
+       CASE 0: FALSE
+       CASE 1: error stop ("Platte kann nicht gelesen werden"); FALSE
+       CASE 2: TRUE
+       CASE 3: error stop ("Versorgungsfehler beim Plattentest"); FALSE
+       OTHERWISE error stop ("unbekannter Fehler auf Platte"); FALSE
+    END SELECT.
+
+eintragen:
+    bb tab [bad sect] := sector;
+    bad sect INCR 1.
+
+lass nicht zu dass ein ersatzsektor ein schlechter ist:
+    REAL VAR aktueller ersatz := end - real (bad sect - 1);
+    INT VAR akt b sect;
+    FOR akt b sect FROM 1 UPTO bad sect - 1 REP
+        IF aktueller ersatz ist in tabelle
+            THEN vertausche aktuell zu ersetzenden mit ihm
+        FI;
+    PER.
+
+aktueller ersatz ist in tabelle:
+    INT VAR such index;
+    FOR such index FROM 1 UPTO bad sect REP
+       IF aktueller ersatz = bb tab (such index)
+           THEN LEAVE aktueller ersatz ist in tabelle WITH TRUE
+       FI;
+    PER;
+    FALSE.
+
+vertausche aktuell zu ersetzenden mit ihm:
+    bb tab ( such index ) := bb tab ( akt b sect );
+    bb tab (akt b sect)   := aktueller ersatz.
+END PROC get bad sector table;
+
+INT PROC cyl and head (REAL CONST sector):
+     cylinder code (int (sector / real (sectors)) DIV heads) OR head.
+
+head :
+  (int (sector / real (sectors)) MOD heads).
+END PROC cyl and head;
+
+PROC get boot block:
+    IF boot block session <> session
+       THEN hole aktuellen boot block
+    FI.
+
+hole aktuellen bootblock :
+    disable stop;
+    DATASPACE VAR dummy ds := nilspace;
+    BOUND STRUCT (ALIGN dummy, 
+                  ROW 256 INT block) VAR partition table := dummy ds; 
+    get external block (dummy ds, 2, 0, fd channel); 
+    IF NOT is error
+        THEN transfer data to boot block
+    FI; 
+    forget (dummy ds). 
+ 
+transfer data to boot block:
+    IF not valid boot block
+        THEN try to get valid boot block from file
+    FI;
+    boot block := partition table. block;
+    boot block session := session.
+
+not valid boot block:
+    partition table. block [256] <> boot indicator OR
+    it is an old boot block of eumel.
+
+boot indicator: -21931.
+
+it is an old boot block of eumel:
+    partition table. block [1] = 1514.
+
+try to get valid boot block from file:
+    forget (dummy ds);
+    partition table := old ("bootblock");
+    IF is error THEN LEAVE transfer data to boot block FI.
+END PROC get boot block;
+
+PROC clear partition table (INT CONST sicherung):
+    IF sicherung = -3475 
+       THEN neuen boot block;
+            put boot block
+    FI.
+
+neuen boot block:
+    enable stop;
+    BOUND STRUCT (ALIGN dummy, 
+                  ROW 256 INT block) VAR partition table;
+    partition table := old ("bootblock");
+    boot block := partition table. block;
+    boot block session := session.
+END PROC clear partition table;
+
+PROC put boot block:
+    IF boot block ist uptodate
+        THEN schreibe block auf platte
+        ELSE errorstop ("boot block nicht uptodate")
+    FI.
+
+boot block ist uptodate:
+    boot block session = session.
+
+schreibe block auf platte:
+    disable stop;
+    DATASPACE VAR dummy ds := nilspace;
+    BOUND STRUCT (ALIGN dummy, 
+                  ROW 256 INT block) VAR partition table := dummy ds; 
+    transfer data to dataspace;
+    put external block (dummy ds, 2, 0, fd channel); 
+    forget (dummy ds). 
+ 
+transfer data to dataspace:
+    partition table. block := boot block.
+END PROC put boot block;
+
+INT PROC partition number (INT CONST part type):
+    INT VAR partition;
+    FOR partition FROM 1 UPTO 4 REP
+         IF partition type (partition) = part type
+              THEN LEAVE partition number WITH partition
+         FI
+    PER;
+    errorstop ("Partitiontyp gibt es nicht");
+    7.
+END PROC partition number;
+
+INT PROC partition word 0 (INT CONST partition):
+   boot block (entry (partition))
+END PROC partition word 0;
+
+PROC partition word 0 (INT CONST partition, word):
+   boot block (entry (partition)) := word
+END PROC partition word 0;
+
+REAL PROC start of partition (INT CONST partition type):
+    partition start (partition number (partition type))
+END PROC start of partition;
+ 
+
+INT PROC first track (INT CONST partition):
+    high byte (boot block [entry (partition) + 1]) 
+       + 4 * (low byte (boot block [entry (partition) + 1]) AND (128 + 64)) 
+END PROC first track;
+
+INT PROC last track (INT CONST partition):
+    high byte (boot block [entry (partition) + 3]) 
+       + 4 * (low byte (boot block [entry (partition) + 3]) AND (128 + 64)) 
+END PROC last track;
+
+INT PROC partition type (INT CONST partition):
+    low byte (boot block [entry (partition) + 2])
+END PROC partition type;
+
+BOOL PROC partition active (INT CONST partition):
+    low byte (boot block [entry (partition)]) = 128
+END PROC partition active;
+
+(****************** neu eingefügt ******************************)
+PROC partition active (INT CONST partition, BOOL CONST active):
+   IF active THEN activate this partition
+             ELSE deactivate this partition
+   FI.
+
+deactivate this partition:
+    set bit (boot block [entry (partition)], 7);
+    (* first setting needed, because reset bit does xor *)
+    reset bit (boot block [entry (partition)], 7).
+
+activate this partition:
+    set bit (boot block [entry (partition)], 7).
+END PROC partition active;
+
+(****************** neu eingefügt ******************************)
+ 
+PROC first track (INT CONST partition, cylinder):
+    boot block [entry (partition) + 1]
+            := cylinder code (cylinder) OR start sector.
+
+start sector:
+    IF cylinder = 0
+        THEN 2
+        ELSE 1
+    FI.
+END PROC first track;
+
+PROC last track (INT CONST partition, cylinder):
+    boot block [entry (partition) + 3] := cylinder code (cylinder).
+END PROC last track;
+
+PROC partition type (INT CONST partition, type):
+    boot block [entry (partition) + 2] := type.
+END PROC partition type;
+
+REAL PROC partition start (INT CONST partition):
+    unsigned low word + high word.
+
+unsigned low word:
+    real (low byte (boot block [entry (partition) + 4])) +
+    real (high byte (boot block [entry (partition) + 4])) * 256.0.
+
+high word:
+    real (boot block [entry (partition) + 5]) * 65536.0.
+END PROC partition start;
+
+PROC partition start (INT CONST partition, REAL CONST sector offset):
+    boot block [entry (partition) + 4] := low word (sector offset);
+    boot block [entry (partition) + 5] := high word (sector offset)
+END PROC partition start;
+
+REAL PROC partition size (INT CONST partition):
+    unsigned low word + high word.
+
+unsigned low word:
+    real (low byte (boot block [entry (partition) + 6])) +
+    real (high byte (boot block [entry (partition) + 6])) * 256.0.
+
+high word:
+    real (boot block [entry (partition) + 7]) * 65536.0.
+END PROC partition size;
+
+PROC partition size (INT CONST partition, REAL CONST number of blocks):
+    boot block [entry (partition) + 6] := low word (number of blocks);
+    boot block [entry (partition) + 7] := high word (number of blocks)
+END PROC partition size;
+ 
+PROC clear partition (INT CONST partition):
+    INT VAR i;
+    FOR i FROM 0 UPTO 7 REP
+        boot block [entry (partition) + i] := 0
+    PER
+END PROC clear partition;
+
+INT PROC entry (INT CONST partition):
+    get boot block;
+    256 - 5 * 8 + (partition * 8)
+END PROC entry;
+
+INT PROC cylinder code (INT CONST cylinder):
+    cylinder text ISUB 1.
+
+cylinder text:
+    high cylinder bits + low cylinder bits.
+
+high cylinder bits:
+    code ((cylinder AND (256 + 512)) DIV 4).
+
+low cylinder bits:
+    code (cylinder AND (128 + 64 + 32 + 16 + 8 + 4 + 2 + 1)).
+END PROC cylinder code;
+
+INT PROC tracks: 
+   get value (-10, fd channel) 
+END PROC tracks; 
+ 
+INT PROC sectors: 
+   get value (-11, fd channel) 
+END PROC sectors; 
+ 
+INT PROC heads: 
+   get value (-12, fd channel) 
+END PROC heads;
+ 
+INT PROC get value (INT CONST control code, channel for value): 
+    enable stop; 
+    INT VAR old channel := channel;
+    IF channel for value <> old channel THEN continue (channel for value)  FI;
+    INT VAR value; 
+    control (control code, 0, 0, value); 
+    IF channel for value <> old channel THEN continue (old channel)  FI;
+    value 
+END PROC get value; 
+ 
+PROC get external block (DATASPACE VAR ds, INT CONST ds page,
+                                             archive block, get channel):
+   INT VAR old channel := channel; 
+   continue (get channel);
+   disable stop;
+   read block (ds, ds page, archive block, error);
+   INT VAR error;
+   SELECT error OF
+      CASE 0:
+      CASE 1: error stop ("Platte kann nicht gelesen werden");
+      CASE 2: error stop ("Lesefehler bei Block "+ text (archive block));
+      CASE 3: error stop ("Versorgungsfehler Archiv");
+      OTHERWISE error stop ("unbekannter Fehler auf Platte");
+   END SELECT;
+   continue (old channel).
+END PROC get external block;
+
+PROC put external block (DATASPACE CONST ds, INT CONST ds page,
+                                             archive block, get channel):
+   INT VAR old channel := channel; 
+   continue (get channel);
+   disable stop;
+   write block (ds, ds page, archive block, error);
+   INT VAR error;
+   SELECT error OF
+      CASE 0:
+      CASE 1: error stop ("Platte kann nicht geschrieben werden");
+      CASE 2: error stop ("Schreibfehler bei Block "+ text (archive block));
+      CASE 3: error stop ("Versorgungsfehler Archiv");
+      OTHERWISE error stop ("unbekannter Fehler auf Platte");
+   END SELECT;
+   continue (old channel).
+END PROC put external block;
+
+END PACKET setup eumel partitionierung;
+
diff --git a/system/setup/3.1/src/setup eumel 6: shardmontage b/system/setup/3.1/src/setup eumel 6: shardmontage
new file mode 100644
index 0000000..cc0d475
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 6: shardmontage
@@ -0,0 +1,389 @@
+
+(**************************************************************************)
+(***** Zusammenbau eines SHards aus Modulen mit Dialog    *****************)
+(***** Copyright (c) 1987, 1988 by                        *****************)
+(***** Lutz Prechelt, Karlsruhe                           *****************)
+(**************************************************************************)
+
+PACKET setup eumel shardmontage        (* Copyright (c) 1987 by    *)
+DEFINES build shard,                   (* Lutz Prechelt, Karlsruhe *)
+        add bad sector table to shard, (* Stand : 08.04.88   3.2   *)
+        installation nr,               (* Eumel 1.8.1              *)
+        print configuration :
+
+(* Beschreibung des SHard-Hauptmodulformats siehe "modulkonfiguration" *)
+
+(* In diesem Paket sind viele Namenskonventionen verankert. 
+   Das leere SHard-Hauptmodul hat den Namen "SHard leer", teilaufgebaute
+   SHards heissen normalerweise in der Form "SHard 07.07.87 14:34" (andere
+   Namen sind möglich, wenn sie mit "SHard " beginnen.)
+   Die Prozedur build shard bastelt in Dialogsteuerung durch den Benutzer
+   aus Modulen und einem leeren oder teilaufgebauten SHard-Hauptmodul einen 
+   neuen SHard zusammen und schreibt ihn in die Datei SHARD 
+   Die Prozedur add bad block table to shard fügt einem so zusammengebauten
+   SHard eine bad block tabelle gemäß dem Zustand der Partition hinzu oder
+   ändert die vorhandene.
+   Dann ist der SHard komplett fertig zum auf-die-Partition-schleudern.
+   (einschliesslich Installationsnummer)
+*) 
+ 
+LET hauptmodul namentyp    = "SHard *", 
+  (*modul namentyp         = "SHardmodul *",*)
+    shard name             = "SHARD";
+
+LET bad sector table size            = 1024,   (* Entries *)
+    max sh length                    =   60,   (* Blocks, vorläufig !!! *)
+    nr of channels total             =   40,
+    offset shard length              =    6,
+    offset bad sector table pointer  =    8,
+    offset verbal identification     =  176,   (* Start Shardleiste *)
+    offset id 4                      =  196;   (* 176 + 14h *)
+
+INT VAR actual installation nr :: id (5);
+DATASPACE VAR ds :: nilspace;
+ 
+PROC build shard (DATASPACE CONST old shard ds) :
+  (* Der Aufrufer muß hinterher nachsehen, ob es die Datei SHARD auch
+     wirklich gibt. Falls nicht, ist "Aufbau des SHards war nicht möglich"
+     zu melden.
+  *)
+  BOUND MODUL VAR old shard :: old shard ds, new shard;
+  TEXT VAR t;
+  INT  VAR i;
+  THESAURUS VAR th, modules, automatic mode modules,
+                modules in old shard, modules in new shard;
+  BOOL CONST old shard valid :: int (old shard, offset id 4) = id (4) AND
+                                  verbal identification ok;
+  perhaps take old shard;  (* ggf. LEAVE *) 
+  get main module name in t;
+  copy (t, shard name);
+  new shard := old (shard name);
+  enable stop;
+  eliminate bad sector table from shard (new shard);
+  get module names; 
+  configurate modules and build shard;
+  add ids.
+ 
+verbal identification ok :
+  text (old shard, offset verbal identification, 16) =
+  "SHard Schoenbeck".
+
+perhaps take old shard : 
+  kopf; 
+  forget (shard name, quiet); 
+  IF old shard valid CAND 
+     yes ("Wollen Sie den SHard genauso wie beim letzten Setup", FALSE) 
+  THEN copy (old shard ds, shard name); LEAVE build shard
+  ELSE out (""10"")  FI.
+ 
+get main module name in t : 
+  putline ("   A u s w a h l   d e s   S H a r d - H a u p t m o d u l s "10"");
+  th := all LIKE hauptmodul namentyp;
+  IF highestentry (th) > 1
+  THEN let the user select one
+  ELSE take the only one  FI.
+
+let the user select one :
+  putline ("Wählen Sie jetzt bitte, welches SHard-Hauptmodul Sie als"); 
+  putline ("Ausgangspunkt der Konfiguration benutzen möchten."); 
+  putline ("(Namen durch Zeiger auswählen dann RETURN-Taste drücken)"); 
+  t := ONE th;
+  out (""4""13""10""10""10""). 
+
+take the only one :
+  t := name (th, 1);
+  putline ("Das einzige verfügbare SHard Hauptmodul ist");
+  putline (t);
+  pause (30).
+
+get module names :
+  (* Besorgt die Listen 1. vorhandene Module   2. Module im alten SHard
+     und 3. Module im SHard Hauptmodul
+     Liefert in modules eine Auswahl von 1. ohne 3. mit 2. als Vorschläge
+     und in automatic mode modules eine Auswahl von 2. (alles vorgeschlagen)
+     Die Liste 2. ist dabei so sortiert, daß stets eingekettete Module in der
+     richtigen Reihenfolge auftauchen.
+  *)
+  kopf;
+  put ("Ich untersuche den SHard: ");
+  get modules in shard (new shard, modules in new shard);
+  IF old shard valid
+  THEN get modules in shard (old shard, modules in old shard)
+  ELSE modules in old shard := empty thesaurus  FI;
+  kopf;
+  putline ("Wählen Sie jetzt bitte mit RETURN/rauf/runter, welche Module Sie");
+  putline ("mit in den SHard aufnehmen möchten.");
+  putline ("(Zum Verlassen ESC q)");
+  modules := certain (all modules - modules in new shard,
+                      modules in old shard);
+  IF old shard valid
+  THEN kopf;
+       putline ("Wählen Sie jetzt, welche der Module vollautomatisch wie im");
+       putline ("Vorlage-SHard konfiguriert werden sollen (Reihenfolge egal)");
+       automatic mode modules := certain (modules / modules in old shard,
+                                          modules in old shard)
+  ELSE automatic mode modules := empty thesaurus  FI.
+
+configurate modules and build shard :
+  FOR i FROM 1 UPTO highest entry (modules) REP
+    page; cout (i); collect heap garbage;
+    t := name (modules, i);
+    configurate module (new shard, old shard,
+                        modules in old shard CONTAINS t,
+                        automatic mode modules CONTAINS t, t)
+  PER;
+  IF highest entry (automatic mode modules) < highest entry (modules)
+  THEN perhaps keep copy of partly build shard  FI;
+  collect heap garbage.
+
+perhaps keep copy of partly build shard :
+  kopf;
+  storage info;
+  out (""10"Möchten Sie eine zusätzliche Kopie des SHard in dieser Version"13""10"");
+  IF yes ("aufheben", FALSE)
+  THEN TEXT CONST start :: subtext (hauptmodul namentyp, 1,
+                                    LENGTH hauptmodul namentyp - 1);
+       t := date;
+       put ("Gewünschter Name :"); out (start); editget (t); out (""13""10"");
+       t := start + t;
+       IF NOT exists (t) COR overwrite THEN copy (shard name, t)  FI
+  FI.
+
+add ids :
+  int (new shard, offset id 4 + 2  (* ID5 *), actual installation nr);
+  int (new shard, offset id 4 + 4  (* ID6 *), id (6));
+  int (new shard, offset id 4 + 6  (* ID7 *), id (7)).
+
+overwrite :
+  IF yes ("Existierende Datei """ + t + """ überschreiben", FALSE)
+  THEN forget (t, quiet);
+       TRUE
+  ELSE FALSE  FI.
+END PROC build shard;
+
+(******************** print configuration **********************************)
+
+PROC print configuration (DATASPACE CONST old shard ds, BOOL CONST on screen):
+  (* Ruft für alle Module, die in old shard ds und als Datei vorhanden sind
+     print configuration aus dem Paket modulkonfiguration auf.
+     Macht bei on screen nach jedem Modul eine Pause, andernfalls wird die
+     Ausgabe in einem Rutsch gemacht und mit indirect list auf den Drucker
+     umgeleitet.
+  *)
+  BOUND MODUL VAR old shard :: old shard ds;
+  THESAURUS VAR modules in old shard;
+  BOOL CONST old shard valid :: int (old shard, offset id 4) = id (4) AND
+                                  verbal identification ok;
+  enable stop;
+  IF NOT old shard valid
+  THEN errorstop ("Der SHard ist ungültig");
+       LEAVE print configuration
+  FI;
+  write head ("Anzeigen der Konfiguration des SHard");
+  put ("Bitte fassen Sie sich in Geduld");
+  get modules in shard (old shard, modules in old shard);
+  out (""4""13""10"");  (* clear cout, line *)
+  IF on screen
+  THEN putline ("Nach jedem Modul eine Taste drücken.")
+  ELSE putline ("Die Ausgabe geht zum Drucker");
+       indirect list (TRUE);
+       putline ("***** SHardkonfiguration *****"); line;
+  FI;
+  disable stop;
+  do print configuration (old shard, modules in old shard, on screen);
+  IF is error THEN put error; pause; clear error  FI;
+  enable stop;
+  IF NOT on screen THEN indirect list (FALSE)  FI.
+
+verbal identification ok :
+  text (old shard, offset verbal identification, 16) =
+  "SHard Schoenbeck".
+END PROC print configuration;
+
+PROC do print configuration (MODUL CONST old shard,
+                            THESAURUS CONST modules in old shard,
+                            BOOL CONST on screen) :
+  INT  VAR i;
+  TEXT VAR t;
+  enable stop;
+  FOR i FROM 1 UPTO highest entry (modules in old shard) REP
+    t := name (modules in old shard, i);
+    print configuration (old shard, t);
+    collect heap garbage;
+    IF on screen THEN pause  FI
+  PER.
+END PROC do print configuration;
+
+(********************** modules in shard **********************************)
+
+PROC get modules in shard (MODUL CONST old shard,
+                           THESAURUS VAR modules in old shard) :
+  (* Stellt einem THESAURUS zusammen, der aus den Namen aller in old shard
+     enthaltenen Module besteht (ohne Duplikate).
+     Dabei sind diejenigen Modulnamen, deren Treiber in old SHard nicht als
+     eingekettete Treiber vorkommen, im Resultat VOR den eingeketteten
+     (d.h. mit kleineren link-Nummern) zu finden, um die richtige
+     Konfigurationsreihenfolge vorschlagen zu können.
+     Es muß zuvor bereits einmal init modules list aufgerufen worden sein !
+  *)
+  INT  VAR kanal;
+  REAL VAR p dtcb, p ccb;
+  TEXT VAR type, m name;
+  THESAURUS VAR simple :: empty thesaurus, chained :: empty thesaurus;
+  FOR kanal FROM 0 UPTO nr of channels total - 1 REP
+    cout (kanal);
+    p dtcb := sh dtcb offset (old shard, kanal);
+    p ccb  := sh ccb  offset (old shard, kanal);
+    look at this chain
+  PER;
+  invert chained thesaurus;
+  modules in old shard := what comes out when i let nameset do all the hard
+           work for me with a little trick and knowledge of implementation.
+
+look at this chain :
+  (* Das Verfahren ist auf den ersten Blick etwas kompliziert, spart aber
+     einiges an Kodeduplikation
+  *)
+  m name :=  "";
+  WHILE p dtcb <> 0.0 AND p ccb <> 0.0 REP
+    IF m name <> "" AND NOT (chained CONTAINS m name)
+    THEN insert (chained, m name)  FI;
+    type   := text (old shard, p dtcb, 4);
+    m name := module name (type);
+    p dtcb := unsigned (int (old shard, p ccb + 2.0));  (* verkettet *)
+    p ccb  := unsigned (int (old shard, p ccb + 4.0));
+  PER;
+  IF m name <> "" THEN insert (simple, m name)  FI.
+
+invert chained thesaurus :
+  (* bis jetzt sind bei mehrfachen Verkettungen die zuletzt eingeketteten
+     Treiber als erstes eingetragen, das darf jedoch nicht so bleiben
+  *)
+  INT VAR i;
+  THESAURUS VAR help :: empty thesaurus;
+  FOR i FROM highest entry (chained) DOWNTO 1 REP
+    insert (help, name (chained, i))
+  PER;
+  chained := help.
+
+what comes out when i let nameset do all the hard
+work for me with a little trick and knowledge of implementation :
+  (* Beware of false algebraic identities !   These are neither numbers nor
+     sets but lists (ordered and not duplicate-free)
+  *)
+  empty thesaurus + (simple - chained) + chained.
+END PROC get modules in shard;
+
+(*************** add bad sector table to shard ****************************)
+
+PROC add bad sector table to shard (INT CONST eumel type,
+                                    DATASPACE CONST shard ds,
+                                    BOOL CONST take from partition,
+                                    INT VAR bad sector count) :
+  (* Fügt einem SHard eine bad sector table hinzu oder ändert sie.
+     Ist noch keine vorhanden, so sollte der Zeiger 0 sein.
+  *)
+  ROW bad sector table size REAL VAR bst;
+  BOUND MODUL VAR new shard :: shard ds;
+  REAL VAR new shard length, offset bst;
+  INT  VAR i;
+  enable stop;
+  IF take from partition
+  THEN put ("kopiere Tabelle :");
+       find bst in shard on partition
+  ELSE put ("Spur :");
+       get bad sector table (bst, bad sector count, eumel type);
+  FI;
+  eliminate bad sector table from shard (new shard);
+  new shard length := unsigned (int (new shard, offset shard length));
+  int (new shard, new shard length, bad sector count);
+  int (new shard, offset bad sector table pointer, unsigned (new shard length));
+  new shard length INCR 2.0;
+  IF take from partition
+  THEN copy bst from old to new shard
+  ELSE write bst to new shard  FI;
+  int (new shard, offset shard length, unsigned (new shard length)).
+
+copy bst from old to new shard :
+  copy (old shard, offset bst + 2.0, new shard, new shard length,
+        bad sector count * 4);
+  cout (bad sector count * 4);
+  new shard length INCR real (bad sector count * 4).
+
+write bst to new shard :
+  FOR i FROM 1 UPTO bad sector count REP
+    cout (i);
+    enter bad sector low word
+  PER;
+  FOR i FROM 1 UPTO bad sector count REP
+    cout (i);
+    enter bad sector high word;
+  PER.
+
+find bst in shard on partition :
+  cout (0);
+  read file (ds, start of partition (eumel type) + 1.0, max sh length,
+             setup channel);
+  BOUND MODUL CONST old shard :: ds;
+  IF int (old shard, offset id 4) <> id (4)
+  THEN errorstop ("SHard auf Partition unbrauchbar")  FI;
+  offset bst := unsigned (int (old shard, offset bad sector table pointer));
+  bad sector count := int (old shard, unsigned (offset bst)).
+
+enter bad sector low word :
+  int (new shard, new shard length, low word (bst [i]));
+  new shard length INCR 2.0.
+
+enter bad sector high word :
+  int (new shard, new shard length, high word (bst [i]));
+  new shard length INCR 2.0.
+END PROC add bad sector table to shard;
+
+(************ eliminate bad sector table from shard ****************)
+
+PROC eliminate bad sector table from shard (MODUL VAR shard) :
+  (* Entfernt die bad sector table (bst) aus dem shard falls sie sich am Ende
+     desselben befindet. Trägt korrekte neue Werte für den bst pointer und
+     shard laenge ein.
+  *)
+  REAL VAR shard length :: unsigned (int (shard, offset shard length)),
+           bst offset   :: unsigned (int (shard, offset bad sector table pointer));
+  LET bst entry length  =  4.0;  (* bst entries sind Wort-Paare *)
+  IF bst offset = 0.0
+  THEN (* ist gar keine bst vorhanden, also schon prima eliminiert *)
+  ELIF bst ist am ende
+  THEN bst entfernen  FI;
+  bst austragen.
+
+bst ist am ende :
+  bst offset + bst entry length * nr of bst entries + 2.0 =
+  shard length.
+
+nr of bst entries :
+  unsigned (int (shard, bst offset)).
+
+bst entfernen :
+  int (shard, offset shard length, unsigned (bst offset)).
+
+bst austragen :
+  int (shard, offset bad sector table pointer, 0).
+END PROC eliminate bad sector table from shard;
+
+(******************* installation nr *************************************)
+
+INT PROC installation nr :
+  actual installation nr
+END PROC installation nr;
+
+PROC installation nr (INT CONST new) :
+  actual installation nr := new
+END PROC installation nr;
+
+(*********************** Hilfsprozeduren **********************************)
+
+PROC kopf :
+  write head ("M o d u l - S H a r d     Zusammenbau eines SHard").
+END PROC kopf;
+
+END PACKET setup eumel shardmontage;
+
diff --git a/system/setup/3.1/src/setup eumel 7: setupeumel b/system/setup/3.1/src/setup eumel 7: setupeumel
new file mode 100644
index 0000000..0504e97
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 7: setupeumel
@@ -0,0 +1,1238 @@
+(*************************************************************************)
+(*** Hauptprogramm des setup-Eumel:Einstellen der EUMEL - Partitionen  ***)
+(*** und SHard-Installation auf einer Festplatte.                      ***)
+(***                                                                   ***)
+(*** Autor : W. Sauerwein                          Stand   : 07.04.89  ***)
+(***         I. Ley                                Version : 2.3       ***)
+(*** Anpassung an Modul-SHard : Lutz Prechelt, Karlsruhe               ***)
+(***           -"-            : Werner Metterhausen                    ***)
+(***           -"-            : Martin Schönbeck                       ***)
+(*************************************************************************)
+(*** V 3.1   14.04.89  shard wird immer mit 'max sh size' geschriegen  ***)
+(***                   da mit 'ds pages' ggf teile fehlten, wenn innen ***)
+(***                   unbenutzte pages (buffer) waren                 ***)
+(*** V 3.0   10.04.89  support fuer mehrere Laufwerke eingebaut        ***)
+(***                   ausgabe der module vor loeschen etc. entfernt   ***)
+
+PACKET setup eumel DEFINES setup eumel, setup eumel endlos, version,
+show partition table:
+
+LET setup version = "Version 3.1";
+
+TEXT VAR stand :: "Stand : 18.04.89    (mit Modul-SHard Version 4.9)";
+
+PROC version (TEXT CONST vers): stand := vers END PROC version;
+
+PROC version: editget (stand) END PROC version;
+
+LET    max partitions           =   4,
+       max sh size              =  128, (* Anzahl Bloecke *)
+       return                   = ""13"",
+       escape                   = ""27"";
+
+LET hauptmodul namentyp    = "SHard *", 
+    modul namentyp         = "SHardmodul *",
+    sh name                = "SHARD",
+    sh backup              = "SHARD Sicherungskopie";
+
+ROW max partitions INT  VAR   part list;
+ROW max partitions INT  VAR   part type, part active,
+                              part first track, part last track;
+ROW max partitions REAL VAR   part start,
+                              part size;
+
+ INT  VAR   zylinder,
+            startzeile tabelle      ::   1,
+            startzeile menu         ::  12,
+            active partition,
+            partitions,
+            partition, i, j, cx, cy, help;
+ TEXT VAR   retchar,
+            meldung := "";
+ BOOL VAR   testausgabe,
+            mit schreibzugriff := TRUE,
+            meldung eingetroffen := FALSE,
+            endlos :: FALSE,
+            at version;
+THESAURUS VAR minimum modulkollektion := empty thesaurus;
+DATASPACE VAR ds := nilspace;
+
+(************************* setup eumel endlos *****************************)
+                                 
+PROC setup eumel endlos (BOOL CONST b) :
+  endlos := b;
+  IF endlos
+  THEN line;
+       putline ("Bitte geben Sie nun alle die Dateien an, die der Benutzer auf");
+       putline ("keinen Fall löschen darf.  (Taste drücken)");
+       minimum modulkollektion := certain (all, emptythesaurus);
+       line (3);
+       putline ("Der setup eumel kann nun nach dem nächsten Aufruf nicht mehr ");
+       putline ("verlassen werden. ")
+  FI.
+END PROC setup eumel endlos;
+
+(******************** get/put actual partition data ************************)
+
+PROC get actual partition data :
+   get boot block;
+   zylinder := tracks;
+   FOR i FROM 1 UPTO max partitions REP
+      part type        (i) := partition type (i);
+      part first track (i) := first track (i);
+      part last track  (i) := last track (i);
+      part start       (i) := partition start (i);
+      part size        (i) := partition size (i);
+      part active      (i) := partition word 0 (i);
+      IF partition active (i) THEN active partition := i FI
+   PER;
+   get number of installed partitions;
+   generate part list.
+
+get number of installed partitions :
+   partitions := 0;
+   FOR i FROM 1 UPTO max partitions REP
+     IF part type (i) <> 0 THEN partitions INCR 1 FI
+   PER.
+
+generate part list :
+   FOR i FROM 1 UPTO max partitions REP
+      IF part type (i) <> 0 THEN part list (i) := i
+                            ELSE part list (i) := 0
+      FI;
+   PER;
+   schiebe nullen nach hinten;
+   sort part list.
+
+schiebe nullen nach hinten :
+   i := 1; INT VAR k := 0;
+   REP k INCR 1;
+       IF part list (i) = 0 THEN circle
+                            ELSE i INCR 1
+       FI
+   UNTIL k = max partitions - 1 PER.
+
+circle :
+   FOR j FROM i UPTO max partitions - 1 REP
+      part list (j) := part list (j + 1)
+   PER;
+   part list (max partitions) := 0.
+
+sort part list :
+   FOR i FROM 2 UPTO partitions REP
+      FOR j FROM 1 UPTO i - 1 REP
+          IF part first track (part list (i)) < part first track (part list (j))
+             THEN tausche FI
+      PER
+   PER.
+
+tausche :
+   help := part list (i);
+   part list (i) := part list (j);
+   part list (j) := help.
+
+END PROC get actual partition data;
+
+PROC put actual partition data :
+   FOR i FROM 1 UPTO max partitions REP
+      IF partition exists (i) THEN put partition
+                              ELSE clear partition (i)
+      FI;
+   PER;
+   IF mit schreibzugriff THEN put boot block FI.
+  
+put partition :
+   IF is eumel (i) THEN partition type   (i, part type        (i));
+                        first track      (i, part first track (i));
+                        last track       (i, part last track  (i));
+                        partition start  (i, part start       (i));
+                        partition size   (i, part size        (i))
+   FI;
+   partition word 0    (i, part active      (i));
+   IF active partition = i
+      THEN partition active (i, TRUE)
+      ELSE partition active (i, FALSE)
+   FI.
+
+END PROC put actual partition data;
+
+(*************************** setup eumel ********************************)
+
+PROC setup eumel :
+   line; command dialogue (TRUE);
+   at version := yes ("System für AT", TRUE);
+   testausgabe := FALSE; (*yes ("Testversion", FALSE); *)
+   pruefe ob notwendige dateien vorhanden;
+   init modules list;
+   IF  yes ("Leere Floppy für Systemsicherung eingelegt", FALSE)
+   THEN command dialogue (FALSE); save system; command dialogue (TRUE)  FI;
+   IF NOT endlos THEN putline ("Verlassen mit ESC."); pause (40)  FI;
+   terminal setup;
+   logo;
+   generate eumel.
+
+pruefe ob notwendige dateien vorhanden:
+   BOUND INT VAR y;
+   IF mit schreibzugriff THEN y := old (sh name);
+                              y := old ("shget.exe");
+                              y := old ("bootblock");
+                              y := old ("configuration");
+                              y := old ("AT-4.x")
+   FI.
+
+END PROC setup eumel;
+
+PROC generate eumel :
+   disable stop;
+   show partition table;
+   REP update table;
+       main menu;
+       action;
+       IF is error THEN fehler;
+                        put line (error message);
+                        put line ("Bitte betätigen Sie eine Taste !");
+                        clear error;
+                        pause;
+                        IF mit schreibzugriff THEN terminal setup FI
+       FI
+   PER.
+
+action :
+   INT VAR choice;
+   clear error;
+   REP
+      cursor (cx, cy);
+      IF partitions < max partitions
+      THEN choice := get choice (0, max, retchar)
+      ELSE choice := get choice (2, max, 0, retchar)
+      FI;
+      IF escaped CAND NOT endlos THEN LEAVE generate eumel FI;
+   UNTIL retchar = return PER;
+   cl eop (1, startzeile menu - 1);
+   INT VAR unser kanal := channel;
+   SELECT choice OF
+      CASE 0 : programm ende
+      CASE 1 : create partition (TRUE)
+      CASE 2 : create partition (FALSE)
+      CASE 3 : activate partition
+      CASE 4 : delete partition
+      CASE 5 : delete partition table
+      CASE 6 : konfiguration anzeigen
+      CASE 7 : shard zusammenbauen
+      CASE 8 : modulkollektion aendern
+      CASE 9 : change drive
+
+  END SELECT;
+  continue (unser kanal).
+
+max :
+  9.
+
+change drive:
+   cursor (1, startzeile menu);
+   put ("Bitte Laufwerksnummer angeben:");
+   get cursor (cx, cy);
+   put ("   0 - 3");
+   REP cursor (cx, cy);
+     INT VAR drive := get choice (0, 3, retchar);
+     IF sure escaped THEN LEAVE change drive FI;
+   UNTIL NOT escaped PER;
+   setup channel (28-drive);
+   show partition table.
+
+
+programm ende :
+   cursor (1, startzeile menu);
+   IF keine partition aktiv
+      THEN IF trotz warnung beenden THEN eumel beenden FI
+      ELSE IF yes ("Wollen Sie die Partitionierung Ihrer Festplatte beenden", FALSE)
+              THEN eumel beenden
+   FI FI.
+
+keine partition aktiv : active partition = 0.
+
+trotz warnung beenden :
+   put line ("ACHTUNG : Es ist keine Partition aktiv gesetzt !");
+   put line ("          Sie können daher nicht von der Festplatte booten !");
+   line;
+   yes ("Wollen Sie trotzdem die Partitionierung der Festplatte beenden", FALSE).
+
+eumel beenden :
+   cl eop (1, startzeile menu - 1);
+   cursor (1, startzeile menu + 3);
+   shutup; terminal setup;
+   logo;
+   show partition table.
+   
+shard zusammenbauen :
+  cl eop (1, startzeile menu);
+  IF yes ("Wollen Sie Ihren SHard neu konfigurieren", FALSE)
+    THEN shard sichern und vorlage beschaffen;
+
+       IF NOT is error THEN build shard (ds)  FI;
+       IF is error OR NOT exists (sh name)
+
+       THEN forget (sh name, quiet); rename (sh backup, sh name);
+            putline ("Zusammenbau fehlgeschlagen. Alter SHard erhalten.");
+            pause (300);
+       FI;
+       forget (sh backup, quiet); forget (ds);
+       show partition table
+  FI.
+
+shard sichern und vorlage beschaffen :
+  forget (sh backup, quiet);
+  IF exists (shname)
+     THEN copy (sh name, sh backup);
+  FI;
+  forget (ds);
+  line;
+  IF yes (""3"Ist in einer existierenden Eumel-Partition ein SHard installiert,
+"13""10"der als Vorlage dienen soll", FALSE)
+  THEN INT VAR vorlage :: 69;
+       editget (1, startzeile menu + 4, "Partitiontyp: ", vorlage);
+       (* Das sollte man mal noch schöner machen !!! *)
+       read file (ds, start of partition (vorlage) + 1.0, max sh size,
+                  setup channel)
+  ELSE ds := old (sh name)  FI.
+
+
+konfiguration anzeigen :
+  hole anzuzeigenden ds;
+  line;
+  print configuration (ds, NOT yes ("Auf dem Drucker ausgeben", FALSE));
+  show partition table.
+
+hole anzuzeigenden ds:
+  forget (ds);
+  line;
+  IF yes ("Soll ein SHard aus einer Partition angezeigt werden", TRUE)
+  THEN INT VAR anzeige :: 69;
+       editget (1, startzeile menu + 4, "Partitiontyp: ", anzeige);
+       (* Das sollte man mal noch schöner machen !!! *)
+       read file (ds, start of partition (anzeige) + 1.0, max sh size,
+                  setup channel)
+  ELSE ds := old (ONE ((all LIKE hauptmodul namentyp) + "SHARD")) FI.
+
+
+modulkollektion aendern :
+  THESAURUS VAR th;
+  TEXT VAR x :: "SHard";
+  INT VAR i ;
+  page;
+  th := (all LIKE hauptmodul namentyp) + (all LIKE modul namentyp) +
+             (all LIKE sh name) ;
+  (* Diese Ausgabe macht leider den Bildschirmaufbau kaputt *)
+  (* mit dem Erfolg, daß man dann nicht mehr sieht, was man *)
+  (* ankreuzt, deshalb auskommentiert *)
+  (*******
+  putline(" Alle SHards :");
+  line;
+  FOR i FROM 1 UPTO highest entry(th)
+  REP
+     putline(name(th,i))
+  PER;
+  *******)
+  putline("      Modulkollektion ändern");
+  line;
+  IF yes ("Wollen Sie irgendwelche Module löschen", FALSE)
+  THEN th := (all LIKE hauptmodul namentyp) + (all LIKE modul namentyp) +
+             (all LIKE sh name) - minimum modulkollektion;
+       forget (certain (th, emptythesaurus));
+  ELIF yes ("Wollen Sie Module vom Archiv holen", FALSE)
+  THEN put ("Archivname:"); editget (x); line;
+       archive (x);
+       th := ALL archive LIKE modul namentyp;
+       fetch (certain (th, emptythesaurus), archive);
+       release (archive)
+  FI;
+  init modules list;
+  show partition table.
+
+
+END PROC generate eumel;
+
+
+PROC show partition table :
+   IF NOT mit schreibzugriff THEN get actual partition data FI;
+   headline;
+   devide table;
+   columns;
+   underlines;
+   rows;
+   downline.
+
+head line :
+   cl eop (1, startzeile tabelle);
+   put center (startzeile tabelle, "Aktuelle Partitions - Tabelle", TRUE).
+
+devide table :
+   FOR i FROM 1 UPTO 8
+   REP
+      cursor (45, startzeile tabelle + i); out (inverse (""))
+   PER.
+
+columns :
+   cursor ( 1, startzeile tabelle + 2);
+   out ("Nr. System   Typ Zustand Grösse Anfang Ende");
+   cursor (48, startzeile tabelle + 2);
+   out ("Platte    :   Zyl. / KB").
+
+underlines :
+   cursor ( 1, startzeile tabelle + 3);
+   out ("--------------------------------------------");
+   cursor (47, startzeile tabelle + 3);
+   out ("------------------------------").
+
+rows :
+   FOR i FROM 1 UPTO max partitions
+   REP cursor (2, startzeile tabelle + 3 + i);
+       put (text (i) + " :")
+   PER.
+
+downline :
+   put center (startzeile menu - 3, " EUMEL Installationssystem " + setup version
+                     + " (IBM PC/" + rechner typ
+                     + " und kompatible Rechner) ", TRUE);
+   put center (startzeile menu - 2, stand, TRUE).
+
+rechner typ :
+   IF at version THEN "AT"
+                 ELSE "XT"
+   FI.
+
+END PROC show partition table;
+
+PROC main menu :
+   biete auswahl an;
+   IF meldung eingetroffen THEN melde FI;
+   IF testausgabe THEN ausgabe fuer test FI.
+
+ausgabe fuer test :
+   testrahmen;
+   test out.
+
+testrahmen :
+   FOR i FROM startzeile menu - 1 UPTO startzeile menu + 9
+   REP
+      cl eol (45, i);
+      put (inverse (""))
+   PER;
+   cursor (52, startzeile menu);
+   put ("Ecke für Test-Output");
+   cursor (52, startzeile menu).
+
+test out :
+   FOR i FROM 1 UPTO max partitions
+   REP
+      cursor (52, startzeile menu + 1 + i);
+      put (text (i) + ":");
+      put (part type (i)); 
+      put (part first track (i));
+      put (part last track (i));
+      IF active partition = i THEN put ("aktiv")
+                             ELSE put ("inaktiv")
+      FI;
+   PER.
+
+melde :
+   cursor (1, 24);
+   put (inverse ("Meldung :"));
+   put (meldung);
+   meldung eingetroffen := FALSE.
+
+biete auswahl an :
+    cl eop (1, startzeile menu - 1); line;
+    IF partitions < max partitions
+    THEN putline (" EUMEL - Partition einrichten .............. 1")
+    ELSE line;
+         putline (" EUMEL - Partition")
+    FI;
+    cursor (20, startzeile menu + 1);
+    putline                    ("erneuern (Neuer SHard) .. 2");
+    putline ("                   aktivieren .............. 3");
+    putline ("                   löschen ................. 4");
+    putline (" Partitionstabelle löschen ................. 5");
+    putline (" SHard-Konfiguration anzeigen .............. 6");
+    putline (" SHard konfigurieren ....................... 7");
+    putline (" SHardmodule laden oder löschen ............ 8");
+    putline (" Bearbeitetes Laufwerk wechseln ............ 9");
+    putline (" SETUP-EUMEL beenden ....................... 0");
+    putline ("-----------------------------------------------");
+    put     (" Ihre Wahl                                >>");
+    get cursor (cx, cy).
+
+END PROC main menu;
+
+PROC update table :
+   IF mit schreibzugriff THEN get actual partition data FI;
+   FOR i FROM 1 UPTO partitions REP update partition PER;
+   FOR i FROM partitions + 1 UPTO max partitions REP rubout partition PER;
+   zeige plattengroesse;
+   IF active partition = 0 THEN meldung := "ACHTUNG : Es ist keine Partition aktiv gesetzt !";
+                                meldung eingetroffen := TRUE
+   FI.
+
+update partition :
+   partition := part list (i);
+   show partition.
+
+rubout partition :
+   cursor (5, startzeile tabelle + 3 + i);
+   out ("                                       ").
+
+show partition :
+   cursor (5, startzeile tabelle + 3 + i);
+   put (name + type + zustand  + groesse + startspur + endspur).
+
+name : subtext (subtext (part name, 1, 7)
+              + "     ", 1, 8).
+
+type : text (part type (partition), 5) + "  ".
+
+zustand   : IF active partition = partition THEN (" aktiv ")
+                                            ELSE ("       ")
+            FI.
+
+startspur : " " + text (part first track (partition), 5).
+endspur   :       text (part last track   (partition), 6).
+groesse   :       text (part groesse, 5).
+
+zeige plattengroesse :
+   put gesamt;
+   put noch freie;
+   put maximaler zwischenraum.
+
+put maximaler zwischenraum :
+   cursor (48, startzeile tabelle + 6);
+   put ("gr. Lücke : " + text (maximaler zwischenraum, 5) + "  / "
+   + kilobyte(maximaler zwischenraum)).
+
+put gesamt :
+   cursor (48, startzeile tabelle + 4);
+   put ("Gesamt    : " + text (zylinder, 5) + "  / "
+   + kilobyte(zylinder)).
+
+put noch freie :
+   cursor (48, startzeile tabelle + 5);
+   put ("Frei      : " + text (freie zylinder, 5) + "  / "
+   + kilobyte( freie zylinder)).
+
+END PROC update table;
+
+
+TEXT PROC kilobyte (INT CONST zylinderzahl):
+     TEXT VAR kb;
+     kb := text(round(real(zylinderzahl) * real(heads) * real(sectors) * 0.512,0));
+     subtext(kb,1,length(kb)-2)
+
+END PROC kilobyte;
+
+
+PROC create partition (BOOL CONST partition is new) :
+   IF NOT partition is new
+   THEN renew partition
+   ELIF freie part number gefunden CAND noch platz uebrig
+   THEN new partition
+   ELSE kein platz mehr  FI.
+
+kein platz mehr :
+   fehler;
+   put ("Es kann keine neue Partition mehr eingerichtet werden.");
+   pause (300).
+
+noch platz uebrig : freie zylinder > 0.
+
+freie part number gefunden :
+   IF partitions < max partitions THEN suche nummer;
+                                       TRUE
+                                  ELSE FALSE
+   FI.
+
+suche nummer :
+   partition := 0;
+   REP partition INCR 1 UNTIL part type (partition) = 0 PER.
+
+new partition :
+   cl eop (1, startzeile menu);
+   IF yes ("Neue EUMEL - Partition einrichten", FALSE)
+      THEN INT VAR alte aktive partition := active partition;
+           IF NOT partition exists (partition)
+              THEN IF enter partition spezifikations
+                      THEN IF mit schreibzugriff THEN check part and install FI
+                   FI;
+              ELSE keine freie partition
+   FI FI.
+
+renew partition :
+   cl eop (1, startzeile menu);
+   IF yes ("Neuen SHard auf bestehende EUMEL - Partition schreiben", FALSE)
+      THEN enter part number;
+           IF mit schreibzugriff THEN check part and install FI
+   FI.
+
+enter part number :
+   put ("Welche Partition wollen Sie erneuern :");
+   get cursor (cx, cy);
+   put ("   Abbruch mit <ESC>");
+   REP
+      REP cursor (cx, cy);
+          partition := get choice (1, 4, retchar);
+          IF sure escaped THEN LEAVE create partition FI;
+          partition := part list (partition)
+      UNTIL NOT escaped PER;
+      IF NOT (partition exists (partition) AND is eumel (partition))
+      THEN fehler; put ("Keine EUMEL - Partition");
+           pause (300); cl eop (1, 20);
+      FI
+   UNTIL partition exists (partition) AND is eumel (partition) PER.
+
+check part and install:
+   IF partition is new THEN put actual partition data  FI;
+   IF testausgabe THEN put ("Keine Überprüfung schlechter Sektoren, da Testversion !")
+                  ELSE trage schlechte sektoren ein;
+   FI;
+   IF is error AND partition is new
+               THEN active partition := alte aktive partition;
+                    rubout partition;
+                    LEAVE check part and install
+               ELIF NOT is error
+               THEN line;
+                    put ("Shard wird auf die Partition geschrieben..."); line (2);
+                    bringe shard auf platte (part type (partition));
+               ELSE line;
+                    putline ("Fehler aufgetreten. Partition unverändert")
+               FI;
+   put ("Bitte betätigen Sie eine Taste !");
+   loesche eingabepuffer;
+   pause.
+
+trage schlechte sektoren ein:
+   INT VAR anzahl schlechter sektoren;
+   line (2);
+   putline ("Überprüfen der Partition nach schlechten Sektoren.");
+   add bad sector table to shard (part type (partition), old (sh name),
+             NOT partition is new, anzahl schlechter sektoren);
+   line;
+   IF NOT is error THEN put ("Ich habe " + bs zahl + " gefunden.") FI.
+
+bs zahl:
+   IF anzahl schlechter sektoren = 0 
+      THEN "keine schlechten Sektoren"
+   ELIF anzahl schlechter sektoren > 1
+      THEN text (anzahl schlechter sektoren) + " schlechte Sektoren" 
+      ELSE "einen schlechten Sektor"
+   FI.
+
+keine freie partition :
+   fehler;
+   put line ("Sie können nur auf freien Partitionen 'EUMEL' einrichten.");
+   put      ("Die Partition " + text (partition) + " ist bereits mit einem System belegt !");
+   pause (300).
+
+END PROC create partition;
+
+BOOL PROC enter partition spezifikations :
+   cl eol (60, startzeile menu); put ("Abbruch mit <ESC>");
+   cl eol (1, startzeile menu + 2);
+   put ("Typ : EUMEL,");
+   INT VAR old end             := part last track (partition);
+   enter part size;
+   enter part first track;
+   put end track;
+   cl eol (60, startzeile menu);
+   IF NOT eingaben ok THEN LEAVE enter partition spezifikations WITH FALSE FI;
+   cl eol (1, startzeile menu + 4);
+   part first track (partition) := int (start);
+   part last track  (partition) := int (start) + int (size) - 1;
+   part start       (partition) := first usable sector;
+   part size        (partition) := first sector behind partition -
+                                               part start (partition);
+   active partition             := partition;
+   part type        (partition) := kleinste freie eumel nummer;
+   add to part list;
+   TRUE.
+
+eingaben ok :
+   cl eop (1, startzeile menu + 4);
+   yes ("Sind die Partitionsangaben korrekt", FALSE).
+
+enter part size :
+   get cursor (cx, cy);
+   REP
+      REP cursor (cx, cy);
+          put ("Welche Grösse :");
+          TEXT VAR size := groessenvorschlag;
+          loesche eingabepuffer;
+          editget (size, escape, "", retchar);
+          IF sure escaped
+             THEN LEAVE enter partition spezifikations WITH FALSE
+          FI
+      UNTIL NOT escaped PER;
+      IF NOT size ok THEN falsche groesse FI
+   UNTIL size ok  AND not too big PER;
+   cl eol (1, y + 1);
+   cl eol (1, y + 2);
+   cl eol (cx, cy);
+   put ("Grösse : " + size + ";").
+
+size ok :
+        NOT size greater maxint
+   CAND size positiv
+    AND desired size <= maximaler zwischenraum.
+
+not too big:
+  INT VAR x,y;
+  get cursor(x,y);
+  IF real(kilobyte(int(size))) >= 16196.0
+   THEN line;
+        putline("Eine Partition grösser 16 MB ist nur bei einer + Version sinnvoll !");
+        yes("Eingabe korrekt",FALSE)
+   ELSE TRUE
+  FI.
+
+size greater maxint :
+   length (size) >= 5.
+
+size positiv :
+   desired size > 0.
+   
+falsche groesse :
+   fehler;
+   put line ("Es kann keine Partition mit " + size + " Zylindern eingerichtet werden !");
+   IF NOT size greater maxint CAND size positiv
+      THEN put ("Die grösste zusammenhängende Anzahl Zylinder ist "
+              + text (maximaler zwischenraum) + ".")
+      ELSE put ("Bitte eine positive Grösse angeben !")
+   FI.
+
+groessenvorschlag :
+   text (maximaler zwischenraum).
+
+enter part first track :
+   get cursor (cx, cy);
+   REP
+      REP cursor (cx, cy);
+          put ("Start - Zylinder der Partition :");
+          TEXT VAR start := startvorschlag;
+          loesche eingabepuffer;
+          editget (start, escape, "", retchar);
+          IF sure escaped THEN part last track (partition) := old end;
+                               LEAVE enter partition spezifikations WITH FALSE
+          FI
+      UNTIL NOT escaped PER;
+      IF NOT start ok THEN falscher start FI
+   UNTIL start ok PER;
+   cl eol (cx, cy);
+   put ("Start : " + start + ";").
+
+put end track :
+   put ("Ende : " + text (int (start) + int (size) - 1)).
+
+start ok :
+        length (start) < 5
+   CAND enough room
+    AND NOT in existing partition
+    AND NOT out of volume.
+
+out of volume : desired start > zylinder OR desired start < 0.
+
+in existing partition :
+   IF partitions = 0 THEN FALSE
+                     ELSE i := 0;
+                          REP
+                             i INCR 1
+                          UNTIL start of part i > desired start
+                             OR last partition
+                             OR error found PER;
+                          IF error found THEN TRUE ELSE FALSE FI
+   FI.
+
+error found :
+   part index <> i AND
+   (start of part i <= desired start AND end spur i >= desired start).
+
+part index :
+   0.
+
+desired start : int (start).
+
+start of part i : part first track (part list (i)).
+
+last partition : i = partitions.
+
+enough room :
+   desired start + desired size <= begin of next partition.
+
+desired size : int (size).
+
+begin of next partition :
+   IF partitions = 0 THEN zylinder
+                     ELSE i := 0;
+                          REP
+                             i INCR 1;
+                          UNTIL start of part i > desired start
+                             OR last partition PER;
+                          IF start of part i > desired start THEN start of part i
+                                                             ELSE zylinder
+                          FI
+   FI.
+
+falscher start :
+   fehler;
+   put ("Auf Zylinder " + start);
+   put ("kann keine Partition der Grösse " + size);
+   put ("beginnen !").
+
+startvorschlag :
+   text (best start position).
+
+best start position :
+   IF partitions = 0 THEN 0
+                     ELSE best start spur vor und zwischen den partitionen
+   FI.
+
+best start spur vor und zwischen den partitionen :
+   INT VAR best start := 0, min size := zylinder;
+   FOR i FROM 0 UPTO partitions
+   REP
+      IF platz genug zwischen i und i plus 1 AND kleiner min size
+         THEN min size   := platz zwischen i und i plus 1;
+              best start := start des zwischenraums
+      FI
+   PER;
+   best start.
+
+start des zwischenraums :
+   end spur i + 1.
+
+end spur i :
+   IF i = 0 THEN -1
+            ELSE part last track (part list (i))
+   FI.
+
+platz zwischen i und i plus 1 :
+   part first track i plus 1 - (end spur i + 1).
+
+part first track i plus 1 :
+   IF i = partitions THEN zylinder
+                     ELSE part first track (part list (i + 1))
+   FI.
+
+platz genug zwischen i und i plus 1 :
+   platz zwischen i und i plus 1 >= int (size).
+
+kleiner min size : platz zwischen  i und i plus 1 < min size.
+
+first usable sector:
+   IF int (start) = 0
+      THEN 1.0
+      ELSE real (heads * sectors) * real (start)
+   FI.
+
+first sector behind partition:
+   real (heads * sectors) * (real(start) + real (size)).
+
+kleinste freie eumel nummer :
+   IF partitions = 0 THEN 69
+                     ELSE search for part type (69)
+   FI.
+   
+END PROC enter partition spezifikations;
+
+INT PROC search for part type (INT CONST minimum) :
+   IF minimum exists THEN search for part type (minimum + 1)
+                     ELSE minimum
+   FI.
+
+minimum exists :
+   BOOL VAR exists := FALSE;
+   INT VAR i;
+   FOR i FROM 1 UPTO partitions REP
+      IF part type (part list (i)) = minimum THEN exists := TRUE FI
+   PER;
+   exists.
+
+END PROC search for part type;
+
+PROC bringe shard auf platte (INT CONST eumel type):
+   IF mit schreibzugriff THEN
+      enable stop;
+      INT CONST old session :: session;
+      fixpoint;
+      IF session <> old session
+      THEN errorstop ("SHard auf Platte schreiben im RERUN !")  FI;
+      write file ("shget.exe", start der eumel partition, 1, setup channel);
+      write file (sh name, start der eumel partition + 1.0,
+                  max sh size, setup channel)
+   FI.
+
+start der eumel partition:
+   start of partition (eumel type).
+END PROC bringe shard auf platte;
+
+
+PROC add to part list :
+   IF part list leer THEN part list (1) := partition
+   ELIF neuer start vor letzter partition THEN fuege ein
+                                          ELSE haenge an
+   FI;
+   partitions INCR 1.
+
+part list leer : partitions = 0.
+
+neuer start vor letzter partition :
+   part first track (partition) < part first track (part list (partitions)).
+
+haenge an : part list (partitions + 1) := partition.
+
+fuege ein :
+   suche erste partition die spaeter startet;
+   schiebe restliste auf;
+   setze partition ein.
+
+suche erste partition die spaeter startet :
+   i := 0;
+   REP i INCR 1
+   UNTIL part first track (part list (i)) > part first track (partition) PER.
+
+schiebe restliste auf :
+   FOR j FROM partitions DOWNTO i
+   REP
+      part list (j + 1) := part list (j)
+   PER.
+
+setze partition ein :
+   part list (i) := partition.
+
+END PROC add to part list ;
+
+INT PROC maximaler zwischenraum :
+   IF partitions = 0 THEN zylinder
+                     ELSE max (maximaler platz vor und zwischen den partitionen,
+                               platz hinter letzter partition)
+   FI.
+
+maximaler platz vor und zwischen den partitionen :
+   help := platz vor erster partition;
+   FOR i FROM 1 UPTO partitions - 1
+   REP
+      help := max (help, begin of part i plus 1 - end of part i - 1)
+   PER;
+   help.
+
+platz vor erster partition :
+   part first track (part list (1)).
+
+platz hinter letzter partition :
+   zylinder - part last track (part list (partitions)) - 1.
+
+begin of part i plus 1 :
+   part first track (part list (i + 1)).
+
+end of part i :
+   part last track (part list (i)).
+
+END PROC maximaler zwischenraum;
+
+PROC activate partition :
+   enter part number;
+   IF NOT escaped THEN set partition active  FI.
+
+set partition active :
+   IF yes ("Partition mit Typnummer " + text (part type (partition)) + " aktivieren", FALSE)
+   THEN active partition := partition;
+        put actual partition data
+   FI.
+
+enter part number :
+   cursor (60, startzeile menu); put ("Abbruch mit <ESC>");
+   cursor ( 1, startzeile menu);
+   put ("Welche Partition wollen Sie aktivieren :");
+   get cursor (cx, cy);
+   REP
+      REP cursor (cx, cy);
+          partition := get choice (1, 4, retchar);
+          IF sure escaped THEN LEAVE activate partition FI;
+          partition := part list (partition)
+      UNTIL NOT escaped PER;
+      IF NOT partition exists (partition) THEN fehler melden FI
+   UNTIL partition exists (partition) PER;
+   cl eol (60, startzeile menu);
+   cl eop (1, cy + 2).
+
+fehler melden :
+   partition gibt es nicht.
+
+partition gibt es nicht :
+   fehler;
+   put ("Diese Partition gibt es nicht.").
+
+END PROC activate partition;
+
+PROC delete partition :
+   enter part number;
+   IF NOT escaped THEN
+      IF yes ("Partition mit Typnummer " + text (part type (partition)) + " löschen", FALSE)
+      AND ganz sicher
+          THEN rubout partition
+   FI FI.
+
+enter part number :
+   cursor (60, startzeile menu); put ("Abbruch mit <ESC>");
+   cursor ( 1, startzeile menu);
+   put ("Welche Partition wollen Sie löschen :");
+   get cursor (cx, cy);
+   REP
+      REP cursor (cx, cy);
+          partition := get choice (1, 4, retchar);
+          IF sure escaped THEN LEAVE delete partition FI;
+          partition := part list (partition)
+      UNTIL NOT escaped PER;
+   IF NOT (partition exists (partition) AND is eumel (partition)) THEN fehler melden FI
+   UNTIL partition gueltig AND is eumel (partition) PER;
+   cl eol (60, startzeile menu);
+   cl eop (1, cy + 2).
+   
+fehler melden :
+   IF NOT partition exists (partition) THEN partition gibt es nicht
+                                       ELSE keine eumel partition
+   FI.
+
+partition gibt es nicht :
+   fehler;
+   put ("Diese Partition gibt es nicht.").
+
+ganz sicher :
+   line;
+   yes ("Sind Sie sich ganz sicher", FALSE).
+   
+END PROC delete partition;
+
+PROC delete partition table :
+   cursor ( 1, startzeile menu + 1);
+   put ("Es gehen ALLE Daten verloren, die sich auf Ihrer Platte befinden !");
+   line (2);
+   IF yes ("Wollen Sie wirklich die ganze Partitionstabelle löschen", FALSE)
+      THEN line;
+           IF yes ("Sind Sie sich ganz sicher", FALSE)
+              THEN loesche ganze tabelle
+   FI FI.
+
+loesche ganze tabelle :
+   FOR i FROM 1 UPTO max partitions
+   REP part type  (i) := 0;
+       part first track (i) := 0;
+       part last track   (i) := 0;
+       part start (i) := 0.0;
+       part size (i) := 0.0;
+       part list  (i) := 0
+   PER;
+   partitions := 0;
+   active partition := 0;
+   IF mit schreibzugriff THEN clear partition table (-3475) FI.
+
+END PROC delete partition table;
+
+PROC rubout partition :
+   part type  (partition) := 0;
+   part first track (partition) := 0;
+   part last track   (partition) := 0;
+   IF active partition = partition THEN active partition := 0 FI;
+   del from part list;
+   put actual partition data.
+
+del from part list :
+   search for partition in part list;
+   delete it and set highest to 0;
+   partitions DECR 1.
+
+search for partition in part list :
+   i := 0;
+   REP i INCR 1 UNTIL part list (i) = partition PER.
+
+delete it and set highest to 0 :
+   FOR j FROM i UPTO partitions - 1
+   REP
+      part list (j) := part list (j + 1)
+   PER;
+   part list (partitions) := 0.
+
+END PROC rubout partition;
+
+INT PROC get choice (INT CONST von, bis, TEXT VAR retchar):
+  get choice (von, bis, von, retchar)
+END PROC get choice;
+
+INT PROC get choice (INT CONST von, bis, zusatz, TEXT VAR retchar):
+   LET return  = ""13"",
+       escape  = ""27"",
+       left    = ""8"";
+   TEXT VAR buffer; 
+   INT VAR cx, cy;
+   get cursor (cx, cy); out (" " + left);
+   REP
+      REP 
+         cursor (cx, cy); buffer := incharety;
+      UNTIL input ok OR buffer = escape PER; 
+      IF buffer = escape THEN retchar := escape;
+                              LEAVE get choice WITH 0
+      FI;
+      out (buffer); 
+      leseschleife bis left or ret;
+      IF retchar = left   THEN out (left + " ") FI;
+      IF retchar = escape THEN LEAVE get choice WITH 0 FI
+   UNTIL retchar = return OR retchar = escape PER;
+   int (buffer). 
+ 
+input ok : (buffer >= text (von) AND buffer <= text (bis)) OR buffer = text (zusatz).
+
+leseschleife bis left or ret:
+   REP 
+     inchar (retchar) 
+   UNTIL retchar = return OR retchar = left OR retchar = escape PER.
+
+END PROC get choice;
+
+TEXT PROC inverse (TEXT CONST t):
+  ""15"" + t + " " + ""14""
+END PROC inverse;
+
+PROC put center (TEXT CONST t):
+   put center (t, 80)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t, BOOL CONST inverse):
+   put center (zeile, t, 80, inverse);
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t):
+   put center (zeile, t, 80)
+END PROC put center;
+
+PROC put center (TEXT CONST t, INT CONST gesamtbreite):
+   INT VAR cy;
+   get cursor (cy, cy);
+   put center (cy, t, gesamtbreite)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite):
+   put center (zeile, t, gesamtbreite, FALSE);
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite,
+                   BOOL CONST inverse):
+   IF inverse
+     THEN cursor (1, zeile);
+          out (""15"");
+          gesamtbreite - 2 TIMESOUT " ";
+   FI;
+   cursor ((gesamtbreite - length (t)) DIV 2, zeile);
+   put (t);
+   IF inverse
+     THEN cursor (gesamtbreite - 1, zeile);
+          out (""14"");
+   FI
+END PROC put center;
+
+PROC cl eol: 
+  out (""5"") 
+END PROC cl eol;
+
+PROC cl eop: 
+  out (""4"") 
+END PROC cl eop; 
+ 
+PROC cl eol (INT CONST cx, cy): 
+   cursor (cx, cy); 
+   cl eol 
+END PROC cl eol; 
+ 
+PROC cl eop (INT CONST cx, cy): 
+   cursor (cx, cy); 
+   cl eop 
+END PROC cl eop; 
+
+INT PROC partition groesse (INT CONST part) :
+   part last track (part) - part first track (part) + 1
+END PROC partition groesse;
+
+BOOL PROC is eumel (INT CONST partition) :
+   part type (partition) >= 69 AND part type (partition) <= 72
+END PROC is eumel;
+
+BOOL PROC partition exists (INT CONST partition) :
+   IF partition > 0 AND partition <= max partitions
+      THEN part type (partition) <> 0
+      ELSE FALSE
+   FI
+END PROC partition exists;.
+
+part groesse : partition groesse (partition).
+
+part name :
+   SELECT part type (partition) OF
+     CASE 1, 4           : "DOS"
+     CASE 69, 70, 71, 72 : "EUMEL"
+     OTHERWISE text (part type (partition))
+   END SELECT.
+
+escaped : retchar = escape.
+
+sure escaped :
+   IF escaped THEN cl eop (1, 20); cursor (1, 22);
+                   yes ("Vorgang abbrechen", TRUE)
+              ELSE FALSE
+   FI.
+
+partition gueltig :
+       partition > 0
+   AND partition <= max partitions.
+
+freie zylinder :
+   zylinder - belegte zylinder.
+
+belegte zylinder :
+   help := 0;
+   FOR i FROM 1 UPTO partitions REP
+      help INCR partition groesse (part list (i))
+   PER;
+   help.
+
+keine eumel partition :
+   fehler;
+   put line ("Sie dürfen mit diesem System nur 'EUMEL' - Partitionen manipulieren.");
+   put      ("Die Partition " + text (partition) + " ist nicht vom Typ 'EUMEL' !").
+
+fehler :
+   cl eop (1, 20);
+   put (""7"" + inverse ("FEHLER :")); line (2).
+
+loesche eingabepuffer :
+   REP UNTIL incharety = "" PER. ;
+
+PROC logo :
+  page;
+  put center (3, "S E T U P - E U M E L   "+ setup version);
+  put center (5, "für");
+  put center (7, "M O D U L - S H A R D");
+  put center (13, "======================================================");
+  put center (15, "(für IBM " + typ + " und Kompatible)");
+  put center (20, stand);
+  pause (50);
+  collect heap garbage.
+
+typ :
+  IF at version THEN "AT" ELSE "XT"  FI.
+END PROC logo;
+
+END PACKET setup eumel;
+
+setup eumel
+
+
+
+
+
+
+
diff --git a/system/setup/3.1/src/setup eumel erzeugen b/system/setup/3.1/src/setup eumel erzeugen
new file mode 100644
index 0000000..7a50898
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel erzeugen
@@ -0,0 +1,15 @@
+check off;
+insert("setup eumel -1: mini eumel dummies");
+insert("setup eumel 0: /S");
+insert("setup eumel 1: basisoperationen");
+insert("setup eumel 2: modulzugriffe");
+insert("setup eumel 3: modulkonfiguration");
+insert("setup eumel 5: partitionierung");
+insert("setup eumel 6: shardmontage");
+insert("setup eumel 7: setupeumel");
+putline("Jetzt 'setup eumel endlos' nicht vergessen");
+ 
+
+
+
+
diff --git a/system/setup/3.1/src/setup eumel erzeugen-M b/system/setup/3.1/src/setup eumel erzeugen-M
new file mode 100644
index 0000000..ad85301
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel erzeugen-M
@@ -0,0 +1,14 @@
+check off;
+insert("setup eumel 0: /M");
+insert("setup eumel 1: basisoperationen");
+insert("setup eumel 2: modulzugriffe");
+insert("setup eumel 3: modulkonfiguration");
+insert("setup eumel 5: partitionierung");
+insert("setup eumel 6: shardmontage");
+insert("setup eumel 7: setupeumel");
+putline("Jetzt 'setup eumel endlos' nicht vergessen");
+ 
+
+
+
+
diff --git a/system/setup/3.1/src/shget.exe b/system/setup/3.1/src/shget.exe
new file mode 100644
index 0000000..902d697
--- /dev/null
+++ b/system/setup/3.1/src/shget.exe