From 04e68443040c7abad84d66477e98f93bed701760 Mon Sep 17 00:00:00 2001
From: Lars-Dominik Braun <lars@6xq.net>
Date: Mon, 4 Feb 2019 13:09:03 +0100
Subject: Initial import
---
system/setup/3.1/source-disk | 1 +
system/setup/3.1/src/AT-4.x | Bin 0 -> 1024 bytes
system/setup/3.1/src/SHARD | Bin 0 -> 7680 bytes
system/setup/3.1/src/SHard Basis | Bin 0 -> 7680 bytes
system/setup/3.1/src/bootblock | Bin 0 -> 4608 bytes
system/setup/3.1/src/configuration | 2 +
system/setup/3.1/src/neu | 34 +
.../3.1/src/setup eumel -1: mini eumel dummies | 28 +
system/setup/3.1/src/setup eumel 0: -M | 32 +
system/setup/3.1/src/setup eumel 0: -S | 35 +
.../setup/3.1/src/setup eumel 1: basisoperationen | 1071 +++++++++++++++++
system/setup/3.1/src/setup eumel 2: modulzugriffe | 441 +++++++
.../3.1/src/setup eumel 3: modulkonfiguration | 854 ++++++++++++++
.../setup/3.1/src/setup eumel 4: dienstprogramme | 218 ++++
.../setup/3.1/src/setup eumel 5: partitionierung | 435 +++++++
system/setup/3.1/src/setup eumel 6: shardmontage | 389 ++++++
system/setup/3.1/src/setup eumel 7: setupeumel | 1238 ++++++++++++++++++++
system/setup/3.1/src/setup eumel erzeugen | 15 +
system/setup/3.1/src/setup eumel erzeugen-M | 14 +
system/setup/3.1/src/shget.exe | Bin 0 -> 1536 bytes
20 files changed, 4807 insertions(+)
create mode 100644 system/setup/3.1/source-disk
create mode 100644 system/setup/3.1/src/AT-4.x
create mode 100644 system/setup/3.1/src/SHARD
create mode 100644 system/setup/3.1/src/SHard Basis
create mode 100644 system/setup/3.1/src/bootblock
create mode 100644 system/setup/3.1/src/configuration
create mode 100644 system/setup/3.1/src/neu
create mode 100644 system/setup/3.1/src/setup eumel -1: mini eumel dummies
create mode 100644 system/setup/3.1/src/setup eumel 0: -M
create mode 100644 system/setup/3.1/src/setup eumel 0: -S
create mode 100644 system/setup/3.1/src/setup eumel 1: basisoperationen
create mode 100644 system/setup/3.1/src/setup eumel 2: modulzugriffe
create mode 100644 system/setup/3.1/src/setup eumel 3: modulkonfiguration
create mode 100644 system/setup/3.1/src/setup eumel 4: dienstprogramme
create mode 100644 system/setup/3.1/src/setup eumel 5: partitionierung
create mode 100644 system/setup/3.1/src/setup eumel 6: shardmontage
create mode 100644 system/setup/3.1/src/setup eumel 7: setupeumel
create mode 100644 system/setup/3.1/src/setup eumel erzeugen
create mode 100644 system/setup/3.1/src/setup eumel erzeugen-M
create mode 100644 system/setup/3.1/src/shget.exe
(limited to 'system/setup')
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
Binary files /dev/null and b/system/setup/3.1/src/AT-4.x differ
diff --git a/system/setup/3.1/src/SHARD b/system/setup/3.1/src/SHARD
new file mode 100644
index 0000000..c1619b3
Binary files /dev/null and b/system/setup/3.1/src/SHARD differ
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
Binary files /dev/null and b/system/setup/3.1/src/SHard Basis differ
diff --git a/system/setup/3.1/src/bootblock b/system/setup/3.1/src/bootblock
new file mode 100644
index 0000000..00b56a2
Binary files /dev/null and b/system/setup/3.1/src/bootblock differ
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
Binary files /dev/null and b/system/setup/3.1/src/shget.exe differ
--
cgit v1.2.3