summaryrefslogtreecommitdiff
path: root/system/std.zusatz
diff options
context:
space:
mode:
authorLars-Dominik Braun <lars@6xq.net>2019-02-04 13:09:03 +0100
committerLars-Dominik Braun <lars@6xq.net>2019-02-04 13:09:03 +0100
commit04e68443040c7abad84d66477e98f93bed701760 (patch)
tree2b6202afae659e773bf6916157d23e83edfa44e3 /system/std.zusatz
downloadeumel-src-04e68443040c7abad84d66477e98f93bed701760.tar.gz
eumel-src-04e68443040c7abad84d66477e98f93bed701760.tar.bz2
eumel-src-04e68443040c7abad84d66477e98f93bed701760.zip
Initial import
Diffstat (limited to 'system/std.zusatz')
-rw-r--r--system/std.zusatz/1.8.7/source-disk1
-rw-r--r--system/std.zusatz/1.8.7/src/AT Generator135
-rw-r--r--system/std.zusatz/1.8.7/src/AT Utilities1057
-rw-r--r--system/std.zusatz/1.8.7/src/AT install93
-rw-r--r--system/std.zusatz/1.8.7/src/complex115
-rw-r--r--system/std.zusatz/1.8.7/src/crypt138
-rw-r--r--system/std.zusatz/1.8.7/src/eumel printer.53473
-rw-r--r--system/std.zusatz/1.8.7/src/eumelmeter131
-rw-r--r--system/std.zusatz/1.8.7/src/font convertor 91095
-rw-r--r--system/std.zusatz/1.8.7/src/free channel430
-rw-r--r--system/std.zusatz/1.8.7/src/longint423
-rw-r--r--system/std.zusatz/1.8.7/src/matrix482
-rw-r--r--system/std.zusatz/1.8.7/src/port server164
-rw-r--r--system/std.zusatz/1.8.7/src/printer server99
-rw-r--r--system/std.zusatz/1.8.7/src/purge85
-rw-r--r--system/std.zusatz/1.8.7/src/referencer1077
-rw-r--r--system/std.zusatz/1.8.7/src/reporter531
-rw-r--r--system/std.zusatz/1.8.7/src/scheduler420
-rw-r--r--system/std.zusatz/1.8.7/src/spool cmd178
-rw-r--r--system/std.zusatz/1.8.7/src/spool manager1058
-rw-r--r--system/std.zusatz/1.8.7/src/std analysator68
-rw-r--r--system/std.zusatz/1.8.7/src/vector213
22 files changed, 11466 insertions, 0 deletions
diff --git a/system/std.zusatz/1.8.7/source-disk b/system/std.zusatz/1.8.7/source-disk
new file mode 100644
index 0000000..085c0a7
--- /dev/null
+++ b/system/std.zusatz/1.8.7/source-disk
@@ -0,0 +1 @@
+grundpaket/04_std.zusatz.img
diff --git a/system/std.zusatz/1.8.7/src/AT Generator b/system/std.zusatz/1.8.7/src/AT Generator
new file mode 100644
index 0000000..d3bfd6d
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/AT Generator
@@ -0,0 +1,135 @@
+(*************************************************************************)
+(*** Generiert Für IBM-AT einen neuen SYSUR-Zweig. ***)
+(*** Danach wird die eingebaute Hardwareuhr für die Systemzeit benutzt ***)
+(*** und andere Partitionen können mit neuem 'shutup' gebootet werden. ***)
+(*** ***)
+(*** Autor : W. Sauerwein Stand : 15.07.86 ***)
+(*************************************************************************)
+
+LET ack = 0,
+ nak = 1;
+
+cl eop (1, 4);
+erzeuge collector;
+erzeuge archive manager;
+erzeuge operator;
+erzeuge configurator;
+loesche collector;
+forget ("AT Generator", quiet);
+break.
+
+loesche collector :
+ end (/"colly");
+ put ("Collector gelöscht.");
+ line (2).
+
+erzeuge collector :
+ put line ("Generating 'Collector'...");
+ begin ("colly", PROC generate collector, t);
+ warte auf meldung;
+ IF answer = nak THEN end (/"colly");
+ errorstop (meldung)
+ FI.
+ TASK VAR t.
+
+erzeuge archive manager :
+ put line ("Generating 'ARCHIVE'...");
+ end (/"ARCHIVE");
+ begin ("ARCHIVE", PROC archive manager, t).
+
+erzeuge operator :
+ put line ("Generating 'OPERATOR'...");
+ end (/"OPERATOR");
+ begin ("OPERATOR", PROC monitor, t).
+
+erzeuge configurator :
+ put line ("Generating 'configurator'...");
+ end (/"configurator");
+ begin ("configurator", PROC generate configurator, t);
+ warte auf meldung;
+ IF answer = nak THEN errorstop (meldung) FI.
+
+warte auf meldung :
+ DATASPACE VAR ds; INT VAR answer;
+ wait (ds, answer, t);
+ BOUND TEXT VAR m := ds;
+ TEXT VAR meldung := m;
+ forget (ds).
+
+PROC generate collector :
+
+ disable stop;
+ fetch all (/"configurator");
+ DATASPACE VAR ds := nilspace;
+ BOUND TEXT VAR m := ds; m := "";
+ send (father, mess, ds);
+ forget (ds);
+ free global manager.
+
+mess : IF is error THEN m := error message;
+ nak
+ ELSE ack FI.
+
+END PROC generate collector;
+
+PROC generate configurator :
+
+ disable stop;
+ fetch all (/"colly");
+ DATASPACE VAR ds := nilspace;
+ BOUND TEXT VAR m := ds; m := "";
+ send (father, mess, ds);
+ forget (ds);
+ enable stop;
+ new configuration;
+ setup;
+ global manager (PROC ( DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ configuration manager with time).
+
+mess : IF is error THEN m := error message;
+ nak
+ ELSE ack FI.
+
+END PROC generate configurator;
+
+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):
+ 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):
+ cursor ((gesamtbreite - length (t)) DIV 2, zeile);
+ put (t).
+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;
+
diff --git a/system/std.zusatz/1.8.7/src/AT Utilities b/system/std.zusatz/1.8.7/src/AT Utilities
new file mode 100644
index 0000000..760e728
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/AT Utilities
@@ -0,0 +1,1057 @@
+(*************************************************************************)
+(*** AT-spezifische Software, die zum Lesen der Hardwareuhr und ***)
+(*** Booten in anderen Partitionen benötigt wird. ***)
+(*** ***)
+(*** Zusammengestellt und geändert : Werner Sauerwein, GMD ***)
+(*** Stand : 31.10.86 ***)
+(*************************************************************************)
+
+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
+
+ 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),
+ 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),
+ 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;
+
+END PACKET basic block io;
+
+
+PACKET utilities DEFINES getchoice, cleol, cleop, inverse, put center:
+
+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;
+
+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;
+
+
+PROC cl eol:
+ out (""5"")
+END PROC cl eol;
+
+PROC cl eop:
+ out (""4"")
+END PROC cl eop;
+
+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):
+ 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):
+ cursor ((gesamtbreite - length (t)) DIV 2, zeile);
+ put (t).
+END PROC put center;
+
+END PACKET utilities
+
+
+PACKET part DEFINES activate, show actual partition table:
+ (* Copyright (C) 1985 *)
+ (* Martin Schönbeck, Spenge *)
+ (* Stand : 02.02.86 *)
+ (* Changed by : W.Sauerwein *)
+ (* I.Ley *)
+ (* Stand : 03.10.86 *)
+ LET fd channel = 28;
+
+ROW 256 INT VAR boot block;
+INT VAR boot block session := session - 1;
+
+PROC get boot block:
+ IF boot block session <> session
+ THEN hole aktuellen boot block
+ FI.
+
+hole aktuellen boot block:
+ 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 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 type (INT CONST partition):
+ low byte (boot block [entry (partition) + 2])
+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]).
+
+END PROC partition start;
+
+INT PROC partition word 0 (INT CONST partition):
+ boot block (entry (partition))
+END PROC partition word 0;
+
+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;
+
+BOOL PROC partition activ (INT CONST partition):
+ low byte (boot block [entry (partition)]) = 128
+END PROC partition activ;
+
+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]).
+
+END PROC partition size;
+
+INT PROC tracks:
+ get value (-10, fd channel)
+END PROC tracks;
+
+PROC activate (INT CONST part type):
+ IF partition type exists AND is possible type
+ THEN deactivate all partitions and
+ activate desired partition
+ ELSE errorstop ("Gewünschte Partitionart gibt es nicht")
+ FI.
+
+is possible type:
+ part type > 0 AND
+ part type < 256.
+
+partition type exists:
+ INT VAR partition;
+ FOR partition FROM 1 UPTO 4 REP
+ IF partition type (partition) = part type
+ THEN LEAVE partition type exists WITH TRUE
+ FI;
+ PER;
+ FALSE.
+
+deactivate all partitions and activate desired partition:
+ FOR partition FROM 1 UPTO 4 REP
+ deactivate this partition;
+ IF partition type (partition) = part type
+ THEN activate partition
+ FI
+ PER;
+ put boot block.
+
+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 partition:
+ set bit (boot block [entry (partition)], 7)
+
+END PROC activate;
+
+INT PROC entry (INT CONST partition):
+ get boot block;
+ 256 - 5 * 8 + (partition * 8)
+END PROC entry;
+
+INT PROC get value (INT CONST control code, channel for value):
+ enable stop;
+ INT VAR old channel := channel;
+ continue (channel for value);
+ INT VAR value;
+ control (control code, 0, 0, value);
+ continue (old channel);
+ 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;
+
+(**************************************************************************)
+
+ LET max partitions = 4;
+ 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,
+ active partition,
+ partitions,
+ partition, i, j, help;
+
+
+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 activ (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 show partition table :
+ headline;
+ devide table;
+ columns;
+ underlines;
+ rows;
+ footlines.
+
+head line :
+ cl eop (1, startzeile tabelle);
+ put center (inverse (" "
+ + "Aktuelle Partitions - Tabelle"
+ + " ")).
+
+devide table :
+ FOR i FROM 1 UPTO 8
+ REP
+ cursor (50, startzeile tabelle + i); out (inverse (""))
+ PER.
+
+columns :
+ cursor ( 1, startzeile tabelle + 2);
+ out (" Nr. System Typ-Nr. Zustand Größe Start Ende");
+ cursor (54, startzeile tabelle + 2);
+ out ("Plattengröße / Zylinder ").
+
+underlines :
+ cursor ( 1, startzeile tabelle + 3);
+ out ("-------------------------------------------------");
+ cursor (52, startzeile tabelle + 3);
+ out ("--------------------------").
+
+rows :
+ FOR i FROM 1 UPTO max partitions
+ REP cursor (2, startzeile tabelle + 3 + i);
+ put (text (i) + " :")
+ PER.
+
+footlines:
+ cursor (1, startzeile tabelle + 9);
+ put center (inverse (75 * " ")).
+
+END PROC show partition table;
+
+PROC update table :
+ get actual partition data;
+ FOR i FROM 1 UPTO partitions REP update partition PER;
+ FOR i FROM partitions + 1 UPTO max partitions REP rubout partition PER;
+ zeige plattengroesse.
+
+update partition :
+ partition := part list (i);
+ show partition.
+
+rubout partition :
+ cursor (6, startzeile tabelle + 3 + i);
+ out (" ").
+
+show partition :
+ cursor (6, startzeile tabelle + 3 + i);
+ put (name + type + zustand + groesse + startspur + endspur).
+
+name : subtext (subtext (part name, 1, 9)
+ + " ", 1, 10).
+
+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 (54, startzeile tabelle + 6);
+ put ("max. zusammenh. : " + text (maximaler zwischenraum, 4)).
+
+put gesamt :
+ cursor (54, startzeile tabelle + 4);
+ put ("insgesamt : " + text (zylinder, 4)).
+
+put noch freie :
+ cursor (54, startzeile tabelle + 5);
+ put ("davon noch frei : " + text (freie zylinder, 4)).
+
+part groesse :
+ partition groesse (partition).
+
+part name :
+ SELECT part type (partition) OF
+ CASE 1 : "DOS"
+ CASE 69, 70, 71, 72 : "EUMEL"
+ OTHERWISE text (part type (partition))
+ END SELECT.
+
+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.
+
+END PROC update table;
+
+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;
+
+INT PROC partition groesse (INT CONST part) :
+ part last track (part) - part first track (part) + 1
+END PROC partition groesse;
+
+PROC show actual partition table:
+ show partition table;
+ update table;
+ line (4)
+END PROC show actual partition table;
+
+PROC show actual partition table (ROW max partitions INT VAR typnr):
+ show actual partition table;
+ FOR i FROM 1 UPTO max partitions REP
+ typnr (i) := partition type (part list (i))
+ PER;
+END PROC show actual partition table;
+
+END PACKET part;
+
+
+PACKET hw clock DEFINES hw clock: (* Copyright (C) 1985 *)
+ (* Martin Schönbeck, Spenge *)
+LET clock length = 7, (* Stand: 06.11.85 *)
+ clock command = 4;
+
+BOUND STRUCT (ALIGN dummy,
+ ROW clock length INT clock field) VAR clock data;
+
+REAL PROC hw clock:
+
+ disable stop;
+ get clock;
+ hw date + hw time.
+
+get clock:
+ DATASPACE VAR ds := nilspace;
+ clock data := ds;
+ INT VAR return code, actual channel := channel;
+ go to shard channel;
+ blockin (ds, 2, -clock command, 0, return code);
+ IF actual channel = 0 THEN break (quiet)
+ ELSE continue (actual channel)
+ FI;
+ IF return code <> 0
+ THEN errorstop ("Keine Hardware Uhr vorhanden");
+ FI;
+ put clock into text;
+ forget (ds).
+
+put clock into text:
+ TEXT VAR clock text := clock length * " ";
+ INT VAR i;
+ FOR i FROM 1 UPTO clock length REP
+ replace (clock text, i, clock data. clock field [i]);
+ PER.
+
+go to shard channel:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 20 REP
+ continue (32);
+ IF is error
+ THEN clear error;
+ pause (30)
+ FI;
+ UNTIL channel = 32 PER.
+
+hw date:
+ date (day + "." + month + "." + year).
+
+day: subtext (clock text, 7, 8).
+
+month: subtext (clock text, 5, 6).
+
+year: subtext (clock text, 1, 4).
+
+hw time:
+ time (hour + ":" + minute + ":" + second).
+
+hour: subtext (clock text, 9, 10).
+
+minute: subtext (clock text, 11, 12).
+
+second: subtext (clock text, 13, 14).
+
+END PROC hw clock;
+
+END PACKET hw clock
+
+
+PACKET old shutup DEFINES old shutup, (* Copyright (C) 1985 *)
+ old save system: (* Martin Schönbeck, Spenge *)
+ (* Stand: 06.11.85 *)
+PROC old shutup : shutup END PROC old shutup;
+
+PROC old save system : save system END PROC old save system;
+
+END PACKET old shutup;
+
+
+PACKET new shutup DEFINES shutup,
+ shutup dialog,
+ save system,
+ generate shutup manager,
+ generate shutup dialog manager:
+
+LET ack = 0;
+
+PROC shutup:
+
+ system down (PROC old shutup)
+
+END PROC shutup;
+
+PROC shutup (INT CONST new system):
+
+ IF new system <> 0
+ THEN prepare for new system
+ FI;
+ system down (PROC old shutup).
+
+prepare for new system:
+ activate (new system);
+ prepare for rebooting.
+
+prepare for rebooting:
+ INT VAR old channel := channel;
+ continue (32);
+ INT VAR dummy;
+ control (-5, 0, 0, dummy);
+ break (quiet);
+ continue (old channel).
+
+END PROC shutup;
+
+PROC save system:
+
+ IF yes ("Leere Floppy eingelegt")
+ THEN system down (PROC old save system)
+ FI
+
+END PROC save system;
+
+PROC system down (PROC operation):
+
+ BOOL VAR dialogue :: command dialogue;
+ command dialogue (FALSE);
+ operation;
+ command dialogue (dialogue);
+ IF command dialogue
+ THEN wait for configurator;
+ show date;
+ FI.
+
+show date:
+ page;
+ line (2);
+ put (" Heute ist der"); putline (date);
+ put (" Es ist"); put (time of day); putline ("Uhr");
+ line (2).
+
+END PROC system down;
+
+DATASPACE VAR ds := nilspace;
+
+PROC wait for configurator:
+
+ INT VAR i, receipt;
+ FOR i FROM 1 UPTO 20 WHILE configurator exists REP
+ pause (30);
+ forget (ds);
+ ds := nilspace;
+ ping pong (configurator, ack, ds, receipt)
+ UNTIL receipt >= 0 PER.
+
+configurator exists:
+ disable stop;
+ TASK VAR configurator := task ("configurator");
+ clear error;
+ NOT is niltask (configurator).
+
+END PROC wait for configurator;
+
+PROC generate shutup manager:
+
+ generate shutup manager ("shutup", 0);
+
+END PROC generate shutup manager;
+
+PROC generate shutup manager (TEXT CONST name, INT CONST new system):
+
+ TASK VAR son;
+ shutup question := name;
+ new system for manager := new system;
+ begin (name, PROC shutup manager, son)
+
+END PROC generate shutup manager;
+
+INT VAR new system for manager;
+TEXT VAR shutup question;
+
+PROC shutup manager:
+
+ disable stop;
+ command dialogue (TRUE);
+ REP
+ break;
+ line ;
+ IF yes (shutup question)
+ THEN clear error;
+ shutup (new system for manager);
+ pause (300);
+ FI;
+ PER
+
+END PROC shutup manager;
+
+PROC shutup dialog:
+ init;
+ show actual partition table (typnr);
+ REP
+ enter part number;
+ get cursor (cx, cy);
+ IF NOT escaped CAND yes (shutup question)
+ THEN message;
+ shutup (partition type);
+ LEAVE shutup dialog
+ FI;
+ PER.
+
+shutup question:
+ IF partition null
+ THEN "Shutup ausführen"
+ ELSE "Shutup nach Partition mit Typnummer " + text (typnr (partition)) + " ausführen"
+ FI.
+
+message:
+ cl eol (1, cy);
+ put line ("Bitte auf ENDE - Meldung warten !").
+
+partition type:
+ IF partition = 0
+ THEN 0
+ ELSE typnr (partition)
+ FI.
+
+init:
+ LET startzeile menu = 12,
+ escape = ""27"",
+ max partitions = 4;
+
+ ROW max partitions INT VAR typnr;
+ INT VAR partition, cx, cy;
+ TEXT VAR retchar.
+
+partition null:
+ partition = 0 COR typnr (partition) = 0.
+
+enter part number :
+ cl eop (1, startzeile menu);
+ cursor (54, startzeile menu ); put ("Abbruch mit <ESC>");
+ cursor (54, startzeile menu + 1); put ("Shutup ohne Wechsel mit <0>");
+ cursor ( 1, startzeile menu);
+ put ("Zu welcher Partition wollen Sie wechseln :");
+ get cursor (cx, cy);
+ REP
+ REP cursor (cx, cy);
+ partition := get choice (0, 4, retchar);
+ IF sure escaped THEN LEAVE shutup dialog FI;
+ UNTIL NOT escaped PER;
+ IF partition <> 0 CAND NOT partition exists
+ THEN fehler;
+ put ("Diese Partition gibt es nicht")
+ FI;
+ UNTIL partition = 0 OR partition exists PER;
+ cl eol (54, startzeile menu);
+ cl eol (54, startzeile menu + 1);
+ cl eop (1, cy + 2).
+
+partition exists:
+ typnr (partition) <> 0.
+
+escaped :
+ retchar = escape.
+
+sure escaped :
+ IF escaped THEN cl eop (1, 20); cursor (1, 22);
+ IF yes ("Shutup-Dialog abbrechen") THEN TRUE
+ ELSE cl eop (1, 20);
+ FALSE
+ FI
+ ELSE FALSE
+ FI.
+
+fehler :
+ cl eop (1, 20);
+ put (""7"" + inverse ("FEHLER :")); line (2).
+
+END PROC shutup dialog;
+
+PROC generate shutup dialog manager:
+ TASK VAR son;
+ begin ("shutup dialog", PROC shutup dialog manager, son)
+END PROC generate shutup dialog manager;
+
+PROC shutup dialog manager:
+ disable stop;
+ command dialogue (TRUE);
+ REP
+ break; line;
+ clear error;
+ INT VAR sess := session;
+ shutup dialog;
+ IF sess <> session THEN pause (300) FI;
+ PER;
+END PROC shutup dialog manager;
+
+END PACKET new shutup
+
+
+PACKET config manager with time DEFINES configuration manager ,
+ configuration manager with time :
+ (* Copyright (C) 1985 *)
+INT VAR old session := 0; (* Martin Schönbeck, Spenge *)
+ (* Stand: 06.11.85 *)
+PROC configuration manager:
+
+ configurate;
+ break;
+ global manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ configuration manager with time)
+
+END PROC configuration manager;
+
+PROC configuration manager with time (DATASPACE VAR ds, INT CONST order,
+ phase, TASK CONST order task):
+
+ IF old session <> session
+ THEN
+ disable stop;
+ set clock (hw clock);
+ set clock (hw clock); (* twice, to avoid all paging delay *)
+ IF is error THEN IF online THEN put error; clear error; pause (100)
+ ELSE clear error
+ FI FI;
+ old session := session;
+ set autonom;
+ FI;
+ configuration manager (ds, order, phase, order task);
+
+END PROC configuration manager with time;
+
+END PACKET config manager with time;
+
diff --git a/system/std.zusatz/1.8.7/src/AT install b/system/std.zusatz/1.8.7/src/AT install
new file mode 100644
index 0000000..11f9b55
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/AT install
@@ -0,0 +1,93 @@
+(*************************************************************************)
+(*** Insertiert alle notwendigen Pakete, damit ein AT-System generiert ***)
+(*** werden kann, das die Hardwareuhr lesen und Partitionen bedienen ***)
+(*** kann. Startet den "AT Generator". ***)
+(*** ***)
+(*** Autor : W. Sauerwein Stand : 15.07.86 ***)
+(*************************************************************************)
+
+erste bildschirmmeldung;
+IF ich bin single THEN putline ("Die AT-spezifische Software ist nur auf Multi-User-Systemen benutzbar !")
+ ELSE hole dateien vom archiv;
+ insertiere alle pakete;
+ put line ("Running ""AT Generator""...");
+ run ("AT Generator")
+FI;
+forget ("AT install", quiet).
+
+ich bin single : (pcb (9) AND 255) <= 1.
+
+insertiere alle pakete :
+ insert and say ("AT Utilities").
+
+erste bildschirmmeldung :
+ page;
+ put center (" Generator für AT-spezifische Software gestartet."); line;
+ put center ("--------------------------------------------------");
+ line (2).
+
+hole dateien vom archiv :
+ TEXT VAR datei;
+ datei := "AT Utilities"; hole wenn noetig;
+ datei := "AT Generator"; hole wenn noetig;
+ release (archive);
+ line.
+
+hole wenn noetig :
+ IF NOT exists (datei) THEN
+ put line ("Loading """ + datei + """...");
+ fetch (datei, archive)
+ FI.
+
+PROC insert and say (TEXT CONST datei) :
+
+ INT VAR cx, cy;
+ put line ("Inserting """ + datei + """...");
+ get cursor (cx, cy);
+ insert (datei);
+ cl eop (cx, cy); line;
+ forget (datei, quiet).
+
+END PROC insert and say;
+
+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):
+ 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):
+ cursor ((gesamtbreite - length (t)) DIV 2, zeile);
+ put (t).
+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;
+
diff --git a/system/std.zusatz/1.8.7/src/complex b/system/std.zusatz/1.8.7/src/complex
new file mode 100644
index 0000000..e2139d0
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/complex
@@ -0,0 +1,115 @@
+
+PACKET complex DEFINES COMPLEX,:=,complex zero,complex one,complex i,
+ complex,realpart,imagpart,CONJ,+,-,*,/,=,<>,
+ put,get, ABS, sqrt, phi, dphi :
+
+TYPE COMPLEX = STRUCT(REAL re,im);
+COMPLEX PROC complex zero: COMPLEX :(0.0,0.0). END PROC complex zero;
+COMPLEX PROC complex one : COMPLEX :(1.0,0.0). END PROC complex one;
+COMPLEX PROC complex i : COMPLEX :(0.0,1.0). END PROC complex i;
+
+OP := (COMPLEX VAR dest, COMPLEX CONST source) :
+
+ CONCR (dest) := CONCR (source)
+
+ENDOP := ;
+
+COMPLEX PROC complex(REAL CONST re,im):
+ COMPLEX :(re,im).
+END PROC complex;
+
+REAL PROC realpart(COMPLEX CONST number):
+ number.re.
+END PROC realpart;
+
+REAL PROC imagpart(COMPLEX CONST number):
+ number.im.
+END PROC imagpart ;
+
+COMPLEX OP CONJ(COMPLEX CONST number):
+ COMPLEX :( number.re,- number.im).
+END OP CONJ;
+
+BOOL OP =(COMPLEX CONST a,b):
+ IF a.re=b.re
+ THEN a.im=b.im
+ ELSE FALSE
+ FI.
+END OP =;
+
+BOOL OP <>(COMPLEX CONST a,b):
+ IF a.re=b.re
+ THEN a.im<>b.im
+ ELSE TRUE
+ FI.
+END OP <>;
+
+COMPLEX OP +(COMPLEX CONST a,b):
+ COMPLEX :(a.re+b.re,a.im+b.im).
+END OP +;
+
+COMPLEX OP -(COMPLEX CONST a,b):
+ COMPLEX :(a.re-b.re,a.im-b.im).
+END OP -;
+
+COMPLEX OP *(COMPLEX CONST a,b):
+ REAL VAR re of a::a.re,im of a ::a.im,
+ re of b::b.re,im of b ::b.im;
+ COMPLEX :(re of a*re of b- im of a *im of b,
+ re of a*im of b+ im of a*re of b).
+END OP *;
+
+COMPLEX OP /(COMPLEX CONST a,b):
+ REAL VAR re of a::a.re,im of a::a.im,
+ re of b::b.re,im of b::b.im;
+ REAL VAR sqare sum of re and im ::b.re*b.re+b.im*b.im;
+ COMPLEX :( (re of a * re of b + im of a * im of b)/sqare sum of re and im,
+ (im of a *re of b - re of a*im of b)/sqare sum of re and im).
+END OP /;
+
+PROC get(COMPLEX VAR a):
+ REAL VAR realpart,imagpart;
+ get(realpart);get(imagpart);
+ a:= COMPLEX :(realpart,imagpart);
+END PROC get;
+
+PROC put(COMPLEX CONST a):
+ put(a.re);put(" ");put(a.im);
+END PROC put;
+
+REAL PROC dphi(COMPLEX CONST x):
+ IF imagpart(x)=0.0 THEN reell
+ ELIF realpart(x)=0.0 THEN imag
+ ELIF realpart(x)>0.0 THEN realpositiv
+ ELSE realnegativ
+ FI.
+reell: IF sign(realpart(x)) < 0 THEN 180.0 ELSE 0.0 FI.
+imag: IF imagpart(x)>0.0 THEN 90.0 ELSE 270.0 FI.
+realpositiv:IF imagpart(x)>0.0 THEN arctand(realpart(x)/imagpart(x))
+ ELSE
+arctand(realpart(x)/imagpart(x))+360.0 FI.
+realnegativ: arctand(realpart(x)/imagpart(x))+180.0.
+END PROC dphi;
+
+REAL PROC phi(COMPLEX CONST x):
+dphi(x)*3.141592653689793/180.0.
+END PROC phi;
+
+COMPLEX PROC sqrt(COMPLEX CONST x):
+IF x=complex zero THEN x
+ELIF realpart(x)<0.0 THEN
+complex(imagpart(x)/(2.0*real(sign(imagpart(x)))
+ *sqrt((ABSx-realpart(x))/2.0)),
+ real(sign(imagpart(x)))*sqrt((ABS x-realpart(x))/2.0))
+ELSE complex(sqrt((ABS x+realpart(x))/2.0),
+ imagpart(x)/(2.0*sqrt((ABS x+realpart(x))/2.0)))
+FI.
+
+END PROC sqrt;
+
+REAL OP ABS(COMPLEX CONST x):
+ sqrt(realpart(x)*realpart(x)+imagpart(x)*imagpart(x)).
+END OP ABS;
+
+END PACKET complex;
+
diff --git a/system/std.zusatz/1.8.7/src/crypt b/system/std.zusatz/1.8.7/src/crypt
new file mode 100644
index 0000000..b04728a
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/crypt
@@ -0,0 +1,138 @@
+(* ------------------- VERSION 2 vom 21.04.86 ------------------- *)
+PACKET cryptograf DEFINES (* Autor: J.Liedtke *)
+
+ crypt ,
+ decrypt :
+
+TEXT VAR char , in buffer, out buffer ;
+INT VAR in pos , key index ;
+DATASPACE VAR scratch space ;
+FILE VAR in, out;
+
+PROC crypt (TEXT CONST file, key) :
+
+ open (file) ;
+ initialize crypt (key) ;
+ WHILE NOT eof REP
+ read char ;
+ crypt char ;
+ write char
+ PER ;
+ close (file) .
+
+crypt char :
+ char := code (( character + random char + key char ) MOD 250) ;
+ IF key index = LENGTH key
+ THEN key index := 1
+ ELSE key index INCR 1
+ FI .
+
+character : code (char) .
+
+random char : random (0,250).
+
+key char : code (key SUB key index) .
+
+ENDPROC crypt ;
+
+PROC decrypt (TEXT CONST file, key) :
+
+ open (file) ;
+ initialize crypt (key) ;
+ WHILE NOT eof REP
+ read char ;
+ decrypt char ;
+ write char
+ PER ;
+ close (file) .
+
+decrypt char :
+ char := code (( character - random char - key char ) MOD 250) ;
+ IF key index = LENGTH key
+ THEN key index := 1
+ ELSE key index INCR 1
+ FI .
+
+character : code (char) .
+
+random char : random (0,250) .
+
+key char : code (key SUB key index) .
+
+ENDPROC decrypt ;
+
+PROC initialize crypt (TEXT CONST key) :
+
+ INT VAR random key := 0 ;
+ FOR key index FROM 1 UPTO LENGTH key REP
+ random key := (random key + code (key SUB key index)) MOD 32000
+ PER ;
+ initialize random (random key) ;
+ key index := 1
+
+ENDPROC initialize crypt ;
+
+PROC open (TEXT CONST source file) :
+
+ in := sequential file (input, source file) ;
+ getline (in, in buffer) ;
+ in pos := 1 ;
+ forget (scratch space) ;
+ scratch space := nilspace ;
+ out := sequential file (output, scratch space) ;
+ out buffer := "" .
+
+ENDPROC open ;
+
+PROC close (TEXT CONST source file) :
+
+ IF out buffer <> ""
+ THEN putline (out, out buffer)
+ FI ;
+ forget (source file, quiet) ;
+ copy (scratch space, source file) ;
+ forget (scratch space) .
+
+ENDPROC close ;
+
+BOOL PROC eof :
+
+ IF in pos > LENGTH in buffer
+ THEN eof (in)
+ ELSE FALSE
+ FI
+
+ENDPROC eof ;
+
+PROC read char :
+
+ IF in pos > 250
+ THEN getline (in, in buffer) ;
+ in pos := 1 ;
+ read char
+ ELIF in pos > LENGTH in buffer
+ THEN in pos := 1 ;
+ getline (in, in buffer) ;
+ char := ""13""
+ ELSE char := in buffer SUB in pos ;
+ in pos INCR 1
+ FI .
+
+ENDPROC read char ;
+
+PROC write char :
+
+ IF char = ""13""
+ THEN putline (out, out buffer) ;
+ out buffer := ""
+ ELSE out buffer CAT char
+ FI ;
+ IF LENGTH out buffer = 250
+ THEN putline (out, out buffer) ;
+ out buffer := ""
+ FI .
+
+ENDPROC write char ;
+
+ENDPACKET cryptograf ;
+
diff --git a/system/std.zusatz/1.8.7/src/eumel printer.5 b/system/std.zusatz/1.8.7/src/eumel printer.5
new file mode 100644
index 0000000..e61a073
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/eumel printer.5
@@ -0,0 +1,3473 @@
+PACKET eumel printer (* Autor : Rudolf Ruland *)
+ (* Version : 5 *)
+ (* Stand : 25.04.88 *)
+ DEFINES print,
+ with elan listings,
+ is elan source,
+ bottom label for elan listings,
+ x pos,
+ y pos,
+ y offset index,
+ line type,
+ material,
+ pages printed,
+
+(* >>> ***************************************************************** <<< *)
+(* >>> Aus Kompatibilitätsgründen zur Textverarbeitung der Version 1.8.0 <<< *)
+(* >>> siehe bei 'Berechnung des Zeilenvorschubs' <<< *)
+
+ old linefeed :
+
+BOOL VAR old linefeed calculation := TRUE;
+
+PROC old linefeed (BOOL CONST value) : old linefeed calculation := value END PROC old linefeed;
+
+BOOL PROC old linefeed : old linefeed calculation END PROC old linefeed;
+
+(* >>> ***************************************************************** <<< *)
+
+INT CONST int length := length of one int;
+
+. length of one int :
+ INT VAR int counter := 0, int value := max int;
+ REP int counter INCR 1;
+ int value := int value DIV 256;
+ UNTIL int value = 0 PER;
+ int counter
+.;
+
+(* >>> ***************************************************************** <<< *)
+
+LET std x wanted = 2.54,
+ std y wanted = 2.35,
+ std limit = 16.0,
+ std pagelength = 25.0,
+ std linefeed faktor = 1.0,
+ std material = "";
+
+LET blank = " ",
+ blank code 1 = 33,
+ geschuetztes blank = ""223"",
+ keine blankanalyse = 0,
+ einfach blank = 1,
+ doppel blank = 2,
+
+ anweisungszeichen = "#",
+ anweisungszeichen code 1 = 36,
+ geschuetztes anweisungszeichen = ""222"",
+ druckerkommando zeichen = "/",
+ quote = """",
+ kommentar zeichen = "-",
+
+ punkt = ".",
+
+ leer = 0,
+
+ kommando token = 0,
+ text token = 1,
+
+ underline linetype = 1,
+(* fraction linetype = 2,
+ root linetype = 3,
+*)
+ underline bit = 0,
+ bold bit = 1,
+ italics bit = 2,
+ modifikations liste = "ubir",
+ anzahl modifikationen = 4,
+
+ document = 1,
+ page = 2,
+
+ write text = 1,
+ write cmd = 2,
+ carriage return = 3,
+ move = 4,
+ draw = 5,
+ on = 6,
+ off = 7,
+ type = 8,
+
+ text code = 1,
+(* error code = 2, *)
+ token code = 3,
+
+ tag type = 1,
+ bold type = 2,
+ number type = 3,
+ text type = 4,
+ delimiter type = 6,
+ eof type = 7;
+
+
+INT CONST null ausgang := minint,
+ erweiterungs ausgang := maxint,
+ blank ausgang := maxint - 1,
+ anweisungs ausgang := maxint - 2,
+ d code ausgang := maxint - 3,
+ max breite := maxint - 4,
+
+ linien token := -1;
+
+ROW anzahl modifikationen INT CONST modifikations werte :=
+ ROW anzahl modifikationen INT : (1, 2, 4, 8);
+
+TEXT CONST anweisungsliste :=
+ "type:1.1on:2.1off:3.1center:4.0right:5.0u:6.0d:7.0e:8.0b:9.0" +
+ "fillchar:10.1mark:11.2markend:12.0" +
+ "ub:13.0ue:14.0fb:15.0fe:16.0" +
+ "block:20.0columns:21.2columnsend:22.0free:23.1limit:24.1linefeed:25.1" +
+ "material:26.1page:27.01pagelength:29.1start:30.2" +
+ "table:31.0tableend:32.0clearpos:33.01" +
+ "lpos:35.1rpos:36.1cpos:37.1dpos:38.2bpos:39.2" +
+ "textbegin:40.02textend:42.0" +
+ "indentation:43.1ytab:44.1";
+
+LET a type = 1, a block = 20,
+ a on = 2, a columns = 21,
+ a off = 3, a columnsend = 22,
+ a center = 4, a free = 23,
+ a right = 5, a limit = 24,
+ a up = 6, a linefeed = 25,
+ a down = 7, a material = 26,
+ a end up or down = 8, a page0 = 27,
+ a bsp = 9, a page1 = 28,
+ a fill char = 10, a pagelength = 29,
+ a mark = 11, a start = 30,
+ a markend = 12, a table = 31,
+ a ub = 13, a tableend = 32,
+ a ue = 14, a clearpos0 = 33,
+ a fb = 15, a clearpos1 = 34,
+ a fe = 16, a lpos = 35,
+ a rpos = 36,
+ a cpos = 37,
+ a dpos = 38,
+ a bpos = 39,
+ a textbegin0 = 40,
+ a textbegin2 = 41,
+ a textend = 42,
+ a indentation = 43,
+ a y tab = 44;
+
+INT VAR a xpos, a breite, a font, a modifikationen,
+ a modifikationen fuer x move, a ypos, aktuelle ypos,
+ letzter font, letzte modifikationen,
+ d ypos, d xpos, d font, d modifikationen,
+
+ zeilenpos, alte zeilenpos, zeilen laenge, anzahl zeichen, ausgang,
+ anzahl einrueck blanks, blankbreite, fuehrende anweisungen,
+ einrueckbreite, aktuelle einrueckbreite, alte einrueckbreite,
+ aktuelle zeilentiefe der letzten zeile,
+ blankmodus, alter blankmodus,
+ token zeiger, erstes token der zeile,
+
+ erstes tab token, tab anfang, anzahl blanks,
+ d code 1, d pitch, fuell zeichen breite, erstes fuell token,
+ letztes fuell token,
+
+ x size, y size, x wanted, y wanted, x start, y start,
+ pagelength, limit, indentation,
+ left margin, top margin, seitenlaenge,
+ papierlaenge, papierbreite,
+ luecke, anzahl spalten, aktuelle spalte,
+
+ verschiebung, linien verschiebung,
+ rest, neue modifikationen, modifikations modus, pass,
+
+ int param, anweisungs index, anzahl params,
+
+ gedruckte seiten;
+
+BOOL VAR zeile ist absatzzeile, letzte zeile war absatzzeile,
+ zeile muss geblockt werden, rechts, a block token, offsets,
+ tabellen modus, block modus, center modus, right modus,
+ seite ist offen, vor erster seite;
+
+REAL VAR linefeed faktor, real param;
+
+TEXT VAR zeile, anweisung, par1, par2, material wert, replacements,
+ fuell zeichen, d string, font offsets;
+
+ROW 256 INT VAR zeichenbreiten, replacement tabelle, zeichen zaehler;
+
+INITFLAG VAR in dieser task := FALSE;
+
+. zeile ist zu ende : zeilenpos > zeilen laenge
+
+. zeilen breite : a xpos - left margin
+
+. naechstes zeichen ist blank : pos (zeile, blank, zeilenpos + 1, zeilenpos + 1) <> 0
+
+. naechstes nicht blankes zeichen : pos (zeile, ""33"", ""255"", zeilenpos)
+
+. in letzter spalte : aktuelle spalte >= anzahl spalten
+
+. anfangs blankmodus :
+ INT VAR dummy;
+ IF center modus OR right modus
+ THEN dummy
+ ELIF index zaehler = 0
+ THEN blankmodus
+ ELSE alter blankmodus
+ FI
+
+. initialisiere tab variablen :
+ erstes tab token := token index f + 1;
+ tab anfang := zeilen breite;
+ anzahl blanks := 0;
+ a block token := FALSE;
+.;
+
+(******************************************************************)
+
+LET zeilen nr laenge = 4,
+ teil einrueckung = 5,
+
+ headline pre = "Zeile **** E L A N EUMEL 1.8.2 **** ",
+ headline post = " **** ";
+
+INT VAR zeilen nr, rest auf seite,
+ max zeichen zeile, max zeichen fuss, layout laenge, layout laenge name,
+ symbol type, naechster symbol type, select counter;
+
+BOOL VAR vor erstem packet, innerhalb einer liste;
+
+TEXT VAR bottom label, dateiname, layout blanks, refinement layout zeile;
+
+
+. symbol : fuell zeichen
+. naechstes symbol : d string
+. elan text : d token. text
+.;
+
+(******************************************************************)
+(*** Berechnung des Zeilenvorschubs ***)
+
+INT VAR fonthoehe, fonttiefe, fontdurchschuss,
+ groesste fonthoehe, groesste fonttiefe,
+ groesste analysatorhoehe, groesste analysatortiefe,
+ letzte zeilenhoehe, letzte zeilentiefe,
+ aktuelle zeilenhoehe, aktuelle zeilentiefe;
+REAL VAR real fontgroesse;
+
+. fontgroesse : fonthoehe + fonttiefe
+. groesste fontgroesse : groesste fonthoehe + groesste fonttiefe
+. letzte zeilengroesse : letzte zeilenhoehe + letzte zeilentiefe
+. aktuelle zeilengroesse : aktuelle zeilenhoehe + aktuelle zeilentiefe
+
+.
+ initialisiere zeilenvorschub :
+ aktuelle zeilenhoehe := letzte zeilenhoehe;
+ aktuelle zeilentiefe := letzte zeilentiefe;
+ groesste fonthoehe := fonthoehe;
+ groesste fonttiefe := fonttiefe;
+ groesste analysatorhoehe := 0;
+ groesste analysatortiefe := 0;
+
+.
+ ueberpruefe groesste fontgroesse :
+ IF old linefeed calculation
+ THEN
+(* >>> Maximumsbestimmung über Fontgröße ******************************* <<< *)
+ IF fontgroesse >= groesste fontgroesse
+ THEN groesste fonthoehe := fonthoehe;
+ groesste fonttiefe := fonttiefe;
+ FI;
+ ELSE
+(* >>> Maximumsbestimmung über Fonthöhe und Fonttiefe ****************** <<< *)
+ groesste fonthoehe := max (fonthoehe, groesste fonthoehe);
+ groesste fonttiefe := max (fonttiefe, groesste fonttiefe);
+ FI;
+
+.
+ berechne fontgroesse :
+ fonthoehe INCR (fontdurchschuss DIV 2 + fontdurchschuss MOD 2);
+ fonttiefe INCR fontdurchschuss DIV 2;
+ real fontgroesse := real (fontgroesse);
+
+.
+ berechne letzte zeilengroesse :
+ REAL CONST zeilengroesse := real fontgroesse * linefeed faktor;
+ letzte zeilenhoehe := int (real (fonthoehe) * zeilengroesse / real fontgroesse + 0.5);
+ letzte zeilentiefe := int (zeilengroesse + 0.5) - letzte zeilenhoehe;
+.;
+
+PROC berechne aktuelle zeilengroesse :
+
+ IF linefeed faktor >= 1.0
+ THEN aktuelle zeilenhoehe := max (groesste fonthoehe, letzte zeilenhoehe);
+ aktuelle zeilentiefe := max (groesste fonttiefe, letzte zeilentiefe);
+ ELSE
+ IF old linefeed calculation
+ THEN
+(* >>> Maximumsbestimmung über Fontgröße ******************************* <<< *)
+ IF letzte zeilengroesse >= aktuelle zeilengroesse
+ THEN aktuelle zeilenhoehe := letzte zeilenhoehe;
+ aktuelle zeilentiefe := letzte zeilentiefe;
+ FI;
+ ELSE
+(* >>> Maximumsbestimmung über Fonthöhe und Fonttiefe ****************** <<< *)
+ aktuelle zeilenhoehe := max (letzte zeilenhoehe, aktuelle zeilenhoehe);
+ aktuelle zeilentiefe := max (letzte zeilentiefe, aktuelle zeilentiefe);
+ FI;
+ FI;
+ aktuelle zeilenhoehe := max (groesste analysatorhoehe, aktuelle zeilenhoehe);
+ aktuelle zeilentiefe := max (groesste analysatortiefe, aktuelle zeilentiefe);
+
+END PROC berechne aktuelle zeilengroesse;
+
+(******************************************************************)
+(*** tokenspeicher ***)
+
+LET max number token = 3000,
+ max number ypos = 1000,
+
+ TOKEN = STRUCT (TEXT text,
+ INT xpos, breite, font, modifikationen,
+ modifikationen fuer x move,
+ offset index, naechster token index,
+ BOOL block token ),
+
+ YPOS = STRUCT (INT ypos, vorheriger ypos index, naechster ypos index,
+ erster token index, letzter token index ),
+
+ TOKENLISTE = STRUCT (ROW max number token TOKEN token liste,
+ ROW max number ypos YPOS ypos liste );
+
+DATASPACE VAR ds;
+
+BOUND TOKENLISTE VAR tokenspeicher;
+
+TOKEN VAR d token, offset token;
+
+INT VAR erster ypos index a, letzter ypos index a,
+ erster ypos index d, letzter ypos index d,
+ ypos index, ypos index f, ypos index a, ypos index d,
+ token index, token index f;
+
+. t : tokenspeicher. token liste (token index)
+. tf : tokenspeicher. token liste (token index f)
+
+. y : tokenspeicher. ypos liste (ypos index)
+. yf : tokenspeicher. ypos liste (ypos index f)
+. ya : tokenspeicher. ypos liste (ypos index a)
+. yd : tokenspeicher. ypos liste (ypos index d)
+
+. loesche druckspeicher :
+ erster ypos index d := 0;
+ ypos index f := 0;
+ token index f := 0;
+
+. druckspeicher ist nicht leer :
+ erster ypos index d <> 0
+
+. loesche analysespeicher :
+ erster ypos index a := 0;
+
+. analysespeicher ist nicht leer :
+ erster ypos index a <> 0
+.;
+
+(******************************************************************)
+(*** anweisungsspeicher ***)
+
+INT VAR anweisungszaehler;
+TEXT VAR anweisungs indizes, params1 zeiger, params2 zeiger;
+THESAURUS VAR params1, params2;
+
+PROC loesche anweisungsspeicher :
+
+ anweisungs zaehler := 0;
+ anweisungs indizes := "";
+ params1 zeiger := "";
+ params2 zeiger := "";
+ params1 := empty thesaurus;
+ params2 := empty thesaurus;
+
+END PROC loesche anweisungsspeicher;
+
+(******************************************************************)
+(*** indexspeicher ***)
+
+INT VAR index zaehler, hoechster index zaehler;
+TEXT VAR letzte index breite, xpos vor index, zeilenpos nach index, grosse fonts,
+ index verschiebung;
+
+PROC loesche indexspeicher :
+
+ index zaehler := 0;
+ hoechster index zaehler := 0;
+ letzte index breite := "";
+ xpos vor index := "";
+ zeilenpos nach index := "";
+ index verschiebung := "";
+ grosse fonts := "";
+
+END PROC loesche indexspeicher;
+
+
+PROC loesche hoehere index level :
+
+ IF hoechster index zaehler > index zaehler
+ THEN letzte index breite := subtext (letzte index breite, 1, int length * index zaehler);
+ xpos vor index := subtext (xpos vor index, 1, int length * index zaehler);
+ zeilenpos nach index := subtext (zeilenpos nach index, 1, int length * index zaehler);
+ index verschiebung := subtext (index verschiebung, int length * index zaehler);
+ grosse fonts := subtext (grosse fonts, 1, int length * index zaehler);
+ hoechster index zaehler := index zaehler;
+ FI;
+
+END PROC loesche hoehere index level;
+
+(******************************************************************)
+(*** tabellenspeicher ***)
+
+LET max tabs = 30,
+ TABELLENEINTRAG = STRUCT (INT tab typ, tab position, tab param);
+
+TEXT VAR tab liste, fill char;
+THESAURUS VAR d strings;
+ROW max tabs TABELLENEINTRAG VAR tabspeicher;
+
+INT VAR tab index;
+
+. tab typ : tab speicher (tab liste ISUB tab index). tab typ
+. tab position : tab speicher (tab liste ISUB tab index). tab position
+. tab param : tab speicher (tab liste ISUB tab index). tab param
+. anzahl tabs : LENGTH tab liste DIV int length
+.;
+
+PROC loesche tabellenspeicher :
+
+ fill char := " ";
+ tabliste := "";
+ d strings := empty thesaurus;
+ FOR tab index FROM 1 UPTO max tabs
+ REP tab speicher (tab index). tab typ := leer PER;
+
+END PROC loesche tabellenspeicher;
+
+(******************************************************************)
+(*** markierungsspeicher ***)
+
+INT VAR mark index l, mark index r, alter mark index l, alter mark index r;
+
+ROW 4 TOKEN VAR mark token;
+
+. markierung links : mark index l > 0
+. markierung rechts : mark index r > 0
+.;
+
+PROC loesche markierung :
+
+ mark index l := 0;
+ mark index r := 0;
+
+END PROC loesche markierung;
+
+
+PROC loesche alte markierung :
+
+ alter mark index l := 0;
+ alter mark index r := 0;
+
+END PROC loesche alte markierung;
+
+
+PROC initialisiere markierung :
+
+ FOR mark index l FROM 1 UPTO 4
+ REP mark token (mark index l). modifikationen fuer x move := 0;
+ mark token (mark index l). offset index := text token;
+ mark token (mark index l). block token := FALSE;
+ mark token (mark index l). naechster token index := 0;
+ PER;
+
+END PROC initialisiere markierung;
+
+(******************************************************************)
+(*** durchschuss ***)
+
+INT VAR durchschuss 1, durchschuss 2, anzahl durchschuss 1,
+ anzahl durchschuss, zeilen zaehler;
+
+BOOL VAR wechsel := TRUE;
+
+INT PROC durchschuss :
+
+ zeilen zaehler INCR 1;
+ IF zeilen zaehler <= anzahl durchschuss 1
+ THEN durchschuss 1
+ ELIF zeilen zaehler <= anzahl durchschuss
+ THEN durchschuss 2
+ ELSE 0
+ FI
+
+END PROC durchschuss;
+
+
+PROC neuer durchschuss (INT CONST anzahl, rest l) :
+
+ zeilen zaehler := 0;
+ anzahl durchschuss := anzahl;
+ IF anzahl > 0
+ THEN IF wechsel
+ THEN durchschuss 1 := rest l DIV anzahl durchschuss;
+ durchschuss 2 := durchschuss 1 + sign (rest l);
+ anzahl durchschuss 1 := anzahl durchschuss -
+ abs (rest l) MOD anzahl durchschuss;
+ wechsel := FALSE;
+ ELSE durchschuss 2 := rest l DIV anzahl durchschuss;
+ durchschuss 1 := durchschuss 2 + sign (rest l);
+ anzahl durchschuss 1 := abs (rest l) MOD anzahl durchschuss;
+ wechsel := TRUE;
+ FI;
+ ELSE loesche durchschuss
+ FI;
+
+END PROC neuer durchschuss;
+
+
+PROC loesche durchschuss :
+
+ durchschuss 1 := 0;
+ durchschuss 2 := 0;
+ anzahl durchschuss 1 := 0;
+ anzahl durchschuss := 0;
+ zeilen zaehler := 0;
+
+END PROC loesche durchschuss;
+
+(****************************************************************)
+
+PROC initialisierung :
+
+ INT VAR index;
+ forget (ds);
+ ds := nilspace; tokenspeicher := ds;
+ loesche druckspeicher;
+ loesche anweisungsspeicher;
+ loesche indexspeicher;
+ initialisiere markierung;
+ right modus := FALSE;
+ center modus := FALSE;
+ seite ist offen := FALSE;
+ pass := 0;
+ a breite := 0;
+ a modifikationen fuer x move := 0;
+ aktuelle zeilentiefe der letzten zeile := 0;
+ d code 1 := leer;
+ erstes fuell token := leer;
+ IF two bytes
+ THEN FOR index FROM 1 UPTO 129 REP zeichen zaehler (index) := 1 PER;
+ FOR index FROM 130 UPTO 160 REP zeichen zaehler (index) := - maxint PER;
+ FOR index FROM 161 UPTO 224 REP zeichen zaehler (index) := 1 PER;
+ FOR index FROM 225 UPTO 240 REP zeichen zaehler (index) := - maxint PER;
+ FOR index FROM 241 UPTO 256 REP zeichen zaehler (index) := 1 PER;
+ ELSE FOR index FROM 1 UPTO 256 REP zeichen zaehler (index) := 1 PER;
+ FI;
+
+END PROC initialisierung;
+
+(****************************************************************)
+(*** print - Kommando ***)
+
+BOOL VAR elan listings erlaubt;
+FILE VAR eingabe;
+THESAURUS VAR elan bolds := empty thesaurus;
+
+insert (elan bolds, "PACKET"); insert (elan bolds, "PROC");
+insert (elan bolds, "PROCEDURE"); insert (elan bolds, "OP");
+insert (elan bolds, "OPERATOR"); insert (elan bolds, "LET");
+insert (elan bolds, "ROW"); insert (elan bolds, "STRUCT");
+insert (elan bolds, "TYPE"); insert (elan bolds, "BOUND");
+insert (elan bolds, "IF"); insert (elan bolds, "REP");
+insert (elan bolds, "REPEAT"); insert (elan bolds, "FOR");
+insert (elan bolds, "WHILE"); insert (elan bolds, "SELECT");
+
+with elan listings (TRUE);
+
+PROC with elan listings (BOOL CONST flag) :
+ elan listings erlaubt := flag;
+END PROC with elan listings;
+
+BOOL PROC with elan listings : elan listings erlaubt END PROC with elan listings;
+
+
+PROC print (FILE VAR file,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ eingabe := file;
+ input (eingabe);
+ print (PROC (TEXT VAR) lese zeile, BOOL PROC is eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) std analysator,
+ elan listings erlaubt CAND is elan source (eingabe),
+ headline (eingabe) );
+
+END PROC print;
+
+
+PROC print (FILE VAR file,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator ) :
+
+ eingabe := file;
+ input (eingabe);
+ print (PROC (TEXT VAR) lese zeile, BOOL PROC is eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator,
+ elan listings erlaubt CAND is elan source (eingabe),
+ headline (eingabe) );
+
+END PROC print;
+
+PROC lese zeile (TEXT VAR zeile l) : getline (eingabe, zeile l) END PROC lese zeile;
+
+BOOL PROC is eof : eof (eingabe) END PROC is eof;
+
+
+BOOL PROC is elan source (FILE VAR eingabe l) :
+
+hole erstes symbol;
+elan programm tag COR elan programm bold COR kommentar COR elanlist anweisung
+
+. elan programm tag :
+ symbol type = tag type CAND pos (zeile, ";") > 0
+
+. elan programm bold :
+ symbol type = bold type CAND is elan bold
+
+ . is elan bold :
+ (elan bolds CONTAINS symbol) COR deklaration COR proc oder op (naechstes symbol)
+
+ . deklaration :
+ next symbol (naechstes symbol);
+ naechstes symbol = "VAR" OR naechstes symbol = "CONST"
+
+. kommentar :
+ pos (zeile, "(*") > 0 OR pos (zeile, "{") > 0
+
+. elanlist anweisung :
+ symbol = "#" AND elanlist folgt
+
+ . elanlist folgt :
+ next symbol (naechstes symbol);
+ naechstes symbol = "elanlist"
+
+.
+ hole erstes symbol :
+ hole erstes nicht blankes symbol;
+ scan (zeile);
+ next symbol (symbol, symbol type);
+
+ . hole erstes nicht blankes symbol :
+ IF eof (eingabe l) THEN LEAVE is elan source WITH FALSE FI;
+ REP getline (eingabe l, zeile);
+ UNTIL pos (zeile, ""33"",""254"", 1) > 0 OR eof (eingabe l) PER;
+ reset (eingabe l);
+
+END PROC is elan source;
+
+(****************************************************************)
+
+bottom label for elan listings ("");
+
+PROC bottom label for elan listings (TEXT CONST label) :
+ bottom label := label;
+END PROC bottom label for elan listings;
+
+TEXT PROC bottom label for elan listings : bottom label END PROC bottom label for elan listings;
+
+
+PROC print (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator,
+ BOOL CONST elan listing, TEXT CONST file name) :
+
+disable stop;
+gedruckte seiten := 0;
+drucke datei (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator,
+ elan listing, file name );
+IF is error THEN behandle fehlermeldung FI;
+
+. behandle fehlermeldung :
+ TEXT CONST fehler meldung := error message;
+ INT CONST fehler zeile := error line,
+ fehler code := error code;
+ clear error;
+ IF NOT vor erster seite
+ THEN IF seite ist offen
+ THEN schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute )
+ FI;
+ clear error;
+ close (document, 0);
+ clear error;
+ FI;
+ initialisierung;
+ errorstop (fehler code, fehler meldung (* + " -> " + text (fehler zeile) *) );
+
+END PROC print;
+
+d xpos := 0;
+d ypos := 0;
+d token. offset index := 1;
+material wert := "";
+gedruckte seiten := 0;
+
+INT PROC x pos : d xpos END PROC x pos;
+INT PROC y pos : d ypos END PROC y pos;
+INT PROC y offset index : d token. offset index END PROC y offset index;
+INT PROC linetype : - d token. offset index END PROC linetype;
+TEXT PROC material : material wert END PROC material;
+INT PROC pages printed : gedruckte seiten END PROC pages printed;
+
+(****************************************************************)
+
+PROC drucke datei (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator,
+ BOOL CONST elan listing, TEXT CONST file name ) :
+
+
+enable stop;
+IF elan listing
+ THEN dateiname := file name;
+ drucke elan listing;
+ ELSE drucke text datei;
+FI;
+
+.
+ drucke text datei :
+ initialisiere druck;
+ WHILE NOT eof
+ REP next line (zeile);
+ analysiere zeile (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ drucke token soweit wie moeglich;
+ werte anweisungsspeicher aus;
+ PER;
+ schliesse druck ab;
+
+.
+ initialisiere druck :
+ IF NOT initialized (in dieser task)
+ THEN ds := nilspace;
+ initialisierung
+ FI;
+ vor erster seite := TRUE;
+ tabellen modus := FALSE;
+ block modus := FALSE;
+ zeile ist absatzzeile := TRUE;
+ x wanted := x step conversion (std x wanted);
+ y wanted := y step conversion (std y wanted);
+ limit := x step conversion (std limit);
+ pagelength := y step conversion (std pagelength);
+ linefeed faktor := std linefeed faktor;
+ material wert := std material;
+ indentation := 0;
+ modifikations modus := maxint;
+ seitenlaenge := maxint;
+ papierlaenge := maxint;
+ left margin := 0;
+ top margin := 0;
+ a ypos := top margin;
+ a font := -1;
+ a modifikationen := 0;
+ aktuelle spalte := 1;
+ anzahl spalten := 1;
+ stelle neuen font ein (1);
+ loesche tabellenspeicher;
+ loesche markierung;
+ loesche alte markierung;
+ loesche durchschuss;
+
+.
+ schliesse druck ab :
+ IF NOT vor erster seite
+ THEN IF seite ist offen
+ THEN schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute )
+ FI;
+ close (document, 0);
+ FI;
+
+.
+ drucke token soweit wie moeglich :
+ IF analysespeicher ist nicht leer
+ THEN letztes token bei gleicher ypos;
+ IF NOT seite ist offen
+ THEN eroeffne seite (x wanted, y wanted,
+ PROC (INT CONST, INT VAR, INT VAR) open);
+ FI;
+ IF seitenlaenge ueberschritten OR papierlaenge ueberschritten
+ THEN neue seite oder spalte;
+ analysiere zeile nochmal;
+ ELSE sortiere neue token ein;
+ IF in letzter spalte
+ THEN drucke tokenspeicher (a ypos,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ FI;
+ FI;
+
+ . seitenlaenge ueberschritten :
+ a ypos + aktuelle zeilentiefe > seitenlaenge
+
+ . papierlaenge ueberschritten :
+ a ypos + aktuelle zeilentiefe > papierlaenge
+
+ . neue seite oder spalte :
+ IF in letzter spalte
+ THEN INT CONST aktuelles y wanted := y wanted bei seitenwechel ohne page;
+ schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ eroeffne seite (x wanted, aktuelles y wanted,
+ PROC (INT CONST, INT VAR, INT VAR) open);
+ ELSE neue spalte;
+ FI;
+
+ . y wanted bei seitenwechel ohne page :
+ IF seitenlaenge ueberschritten
+ THEN y wanted
+ ELSE 0
+ FI
+
+ . analysiere zeile nochmal :
+ setze auf alte werte zurueck;
+ loesche anweisungsspeicher;
+ analysiere zeile (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ letztes token bei gleicher ypos;
+ sortiere neue token ein;
+
+ . setze auf alte werte zurueck :
+ zeile ist absatzzeile := letzte zeile war absatzzeile;
+ a modifikationen := letzte modifikationen;
+ stelle neuen font ein (letzter font);
+
+.
+ werte anweisungsspeicher aus :
+ INT VAR index;
+ FOR index FROM 1 UPTO anweisungszaehler
+ REP
+ SELECT anweisungs indizes ISUB index OF
+ CASE a block : block anweisung
+ CASE a columns : columns anweisung
+ CASE a columnsend : columnsend anweisung
+ CASE a free : free anweisung
+ CASE a limit : limit anweisung
+ CASE a linefeed : linefeed anweisung
+ CASE a material : material anweisung
+ CASE a page0, a page1 : page anweisung
+ CASE a pagelength : pagelength anweisung
+ CASE a start : start anweisung
+ CASE a table : table anweisung
+ CASE a tableend : tableend anweisung
+ CASE a clearpos0 : clearpos0 anweisung
+ CASE a clearpos1 : clearpos1 anweisung
+ CASE a lpos, a rpos, a cpos, a dpos
+ : lpos rpos cpos dpos anweisung
+ CASE a bpos : bpos anweisung
+ CASE a fillchar : fillchar anweisung
+ CASE a textbegin0 : textbegin0 anweisung
+ CASE a textbegin2 : textbegin2 anweisung
+ CASE a textend : textend anweisung
+ CASE a indentation : indentation anweisung
+ CASE a y tab : y tab anweisung
+ END SELECT
+ PER;
+ loesche anweisungsspeicher;
+
+ . block anweisung :
+ blockmodus := TRUE;
+
+ . columns anweisung :
+ IF anzahl spalten = 1 AND int conversion ok (param1)
+ AND real conversion ok (param2)
+ THEN anzahl spalten := max (1, int param);
+ luecke := x step conversion (real param);
+ FI;
+
+ . columnsend anweisung :
+ anzahl spalten := 1;
+ aktuelle spalte := 1;
+ left margin := x wanted - x start + indentation;
+
+ . free anweisung :
+ IF real conversion ok (param1) THEN a ypos INCR y step conversion (real param) FI;
+
+ . limit anweisung :
+ IF real conversion ok (param1) THEN limit := x step conversion (real param) FI;
+
+ . linefeed anweisung :
+ IF real conversion ok (param1)
+ THEN linefeed faktor := real param;
+ berechne letzte zeilengroesse;
+ FI;
+
+ . material anweisung :
+ material wert := param1;
+
+ . page anweisung :
+ IF seite ist offen
+ THEN IF NOT in letzter spalte
+ THEN neue spalte
+ ELSE schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ papier laenge := maxint;
+ FI;
+ ELSE a ypos := top margin;
+ papier laenge := maxint;
+ FI;
+
+ . pagelength anweisung :
+ IF real conversion ok (param1)
+ THEN pagelength := y step conversion (real param);
+ FI;
+
+ . start anweisung :
+ IF real conversion ok (param1) THEN x wanted := x step conversion (real param) FI;
+ IF real conversion ok (param2) THEN y wanted := y step conversion (real param) FI;
+
+ . table anweisung :
+ tabellenmodus := TRUE;
+
+ . tableend anweisung :
+ tabellenmodus := FALSE;
+
+ . clearpos0 anweisung :
+ loesche tabellenspeicher;
+
+ . clearpos1 anweisung :
+ IF real conversion ok (param1)
+ THEN int param := x step conversion (real param);
+ FOR tab index FROM 1 UPTO anzahl tabs
+ REP IF tab position = int param
+ THEN tab typ := leer;
+ delete int (tab liste, tab index);
+ LEAVE clearpos1 anweisung;
+ FI;
+ PER;
+ FI;
+
+ . lpos rpos cpos dpos anweisung :
+ IF real conversion ok (param1)
+ THEN neuer tab eintrag (anweisungs indizes ISUB index, param2) FI;
+
+ . bpos anweisung :
+ IF real conversion ok (param2) CAND real conversion ok (param1)
+ CAND real (param2) > real param
+ THEN neuer tab eintrag (a bpos, param2) FI;
+
+ . fillchar anweisung :
+ fill char := param1;
+
+ . textbegin0 anweisung :
+ aktuelle einrueckbreite := alte einrueckbreite;
+ mark index l := alter mark index l;
+ mark index r := alter mark index r;
+ loesche alte markierung;
+
+ . textbegin2 anweisung :
+ aktuelle einrueckbreite := alte einrueckbreite;
+ mark index l := alter mark index l;
+ mark index r := alter mark index r;
+ loesche alte markierung;
+ neuer durchschuss (int (param1), y step conversion (real (param 2)));
+
+ . textend anweisung :
+ alte einrueckbreite := aktuelle einrueckbreite;
+ alter mark index l := mark index l;
+ alter mark index r := mark index r;
+ loesche markierung;
+ loesche durchschuss;
+
+ . indentation anweisung :
+(**) IF real conversion ok (param1)
+ THEN int param := x step conversion (real param);
+ left margin INCR (int param - indentation);
+ indentation := int param;
+ FI;
+(**)
+ . y tab anweisung :
+(**) IF real conversion ok (param1)
+ THEN int param := y step conversion (real param);
+ IF int param <= seitenlaenge THEN a ypos := int param FI;
+ FI;
+(**)
+ . param1 :
+ IF (params1 zeiger ISUB index) <> 0
+ THEN name (params1, params1 zeiger ISUB index)
+ ELSE ""
+ FI
+
+ . param2 :
+ IF (params2 zeiger ISUB index) <> 0
+ THEN name (params2, params2 zeiger ISUB index)
+ ELSE ""
+ FI
+
+
+.
+ drucke elan listing :
+ initialisiere elan listing;
+ WHILE NOT eof
+ REP next line (zeile);
+ zeilen nr INCR 1;
+ drucke elan zeile;
+ PER;
+ schliesse elan listing ab;
+
+.
+ initialisiere elan listing :
+ open document cmd;
+ hole elan list font;
+ initialisiere variablen;
+ elan fuss und kopf (1,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ . open document cmd :
+ material wert := "";
+ d token. offset index := 1;
+ erster ypos index d := 0;
+ vor erster seite := FALSE;
+ seite ist offen := TRUE;
+ open (document, x size, y size);
+ vor erster seite := FALSE;
+
+ . hole elan list font :
+ d font := max (1, font ("elanlist"));
+ get replacements (d font, replacements, replacement tabelle);
+ einrueckbreite := indentation pitch (d font) ;
+ font hoehe := font lead (d font) + font height (d font) + font depth (d font);
+
+ . initialisiere variablen :
+ innerhalb einer liste := FALSE;
+ vor erstem packet := TRUE;
+ zeilen nr := 0;
+ select counter := 0;
+ y wanted := y size DIV 23;
+ pagelength := y size - y wanted - y wanted;
+ x wanted := (min (x size DIV 10, x step conversion (2.54))
+ DIV einrueckbreite) * einrueckbreite;
+ max zeichen zeile := (x size - x wanted - (x wanted DIV 3)) DIV einrueckbreite;
+ max zeichen fuss := fusszeilenbreite;
+ layout laenge := min (38, max zeichen zeile DIV 3);
+ layout laenge name := layout laenge - zeilen nr laenge - 8;
+ layout blanks := (layout laenge - zeilen nr laenge - 1) * " ";
+ refinement layout zeile := (layout laenge - 1) * " " ;
+ refinement layout zeile CAT "|" ;
+ IF pagelength DIV fonthoehe - 6 < 35 OR max zeichen zeile < 65
+ THEN errorstop ("Schreibfeld fuer 'elan listing' zu klein") FI;
+
+ . fusszeilenbreite :
+ INT CONST dina 4 breite := x step conversion (21.0);
+ IF x size <= dina 4 breite
+ THEN (x size - 2 * x wanted) DIV einrueckbreite
+ ELIF 120 * einrueckbreite <= dina 4 breite - 2 * x wanted
+ THEN (dina 4 breite - 2 * x wanted) DIV einrueckbreite
+ ELSE min (120, (x size - 2 * x wanted) DIV einrueckbreite)
+ FI
+
+.
+ schliesse elan listing ab :
+ elan fuss und kopf (-1,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ close (document, 0);
+
+.
+ drucke elan zeile :
+ IF pos (zeile, "#page#") = 1
+ THEN IF nicht am seiten anfang THEN seiten wechsel FI;
+ ELIF pos (zeile, "#elanlist#") <> 1
+ THEN bestimme elan layout;
+ bestimme elan zeile;
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ seitenwechsel wenn noetig;
+ FI;
+
+ . nicht am seitenanfang :
+ rest auf seite < pagelength - 3 * font hoehe
+
+ . seiten wechsel :
+ elan fuss und kopf (0,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+.
+ bestimme elan layout :
+ IF innerhalb einer liste
+ THEN leeres layout;
+ pruefe ende der liste
+ ELIF pos (zeile, "P") <> 0 COR pos (zeile, ":") <> 0
+ THEN analysiere elan zeile
+ ELIF innerhalb einer select kette
+ THEN leeres layout;
+ pruefe ende der select kette
+ ELIF pos (zeile, "SELECT") <> 0
+ THEN analysiere select kette
+ ELSE leeres layout
+ FI;
+ elan text CAT "|";
+
+ . leeres layout :
+ elan text := text (zeilen nr, zeilen nr laenge);
+ elan text CAT layout blanks;
+
+ . analysiere elan zeile :
+ scan (zeile);
+ next symbol (symbol, symbol type);
+ next symbol (naechstes symbol, naechster symbol type);
+ IF packet anfang
+ THEN packet layout
+ ELIF type anfang
+ THEN type layout
+ ELIF proc op anfang
+ THEN proc op layout
+ ELSE IF innerhalb einer select kette
+ THEN pruefe ende der select kette;
+ leeres layout
+ ELIF refinement anfang
+ THEN refinement layout
+ ELSE leeres layout
+ FI;
+ FI;
+
+
+ . packet anfang :
+ symbol = "PACKET"
+
+ . type anfang :
+ symbol = "TYPE"
+
+ . proc op anfang :
+ IF proc oder op (symbol)
+ THEN naechster symbol type <> delimiter type
+ ELIF (symbol <> "END") AND proc oder op (naechstes symbol)
+ THEN symbol := naechstes symbol;
+ next symbol (naechstes symbol, naechster symbol type);
+ naechster symbol type <> delimiter type
+ ELSE FALSE
+ FI
+
+ . refinement anfang :
+ symbol type = tag type AND naechstes symbol = ":"
+
+ . packet layout :
+ IF nicht am seiten anfang AND
+ (NOT vor erstem packet OR gedruckte seiten > 1)
+ THEN seiten wechsel
+ FI;
+ layout (" ", naechstes symbol, "*") ;
+ vor erstem packet := FALSE;
+ select counter := 0;
+ innerhalb einer liste := TRUE;
+ pruefe ende der liste;
+
+ . type layout :
+ layout (" ", naechstes symbol, ".");
+ select counter := 0;
+
+ . proc op layout :
+ IF keine vier zeilen mehr
+ THEN seiten wechsel
+ ELIF nicht am seitenanfang
+ THEN cr plus lf (2, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI ;
+ layout (" ", naechstes symbol, ".");
+ select counter := 0;
+ innerhalb einer liste := TRUE;
+ pruefe ende der liste;
+
+ . keine vier zeilen mehr :
+ rest auf seite <= 8 * font hoehe
+
+ . refinement layout :
+ IF keine drei zeilen mehr
+ THEN seiten wechsel
+ ELIF nicht am seitenanfang
+ THEN elan text := refinement layout zeile;
+ gib elan text aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI ;
+ layout (" ", symbol, " ");
+
+ . keine drei zeilen mehr :
+ rest auf seite <= 7 * font hoehe
+
+ . pruefe ende der liste :
+ IF pos (zeile, ":") <> 0
+ THEN scan (zeile);
+ WHILE innerhalb einer liste
+ REP next symbol (symbol);
+ IF symbol = ":" THEN innerhalb einer liste := FALSE FI;
+ UNTIL symbol = "" PER;
+ FI;
+
+ . innerhalb einer select kette :
+ select counter > 0
+
+ . analysiere select kette :
+ scan (zeile);
+ naechstes symbol := "";
+ REP symbol := naechstes symbol;
+ next symbol (naechstes symbol);
+ IF naechstes symbol = "SELECT" CAND symbol <> "END"
+ THEN select counter := 1;
+ untersuche select kette;
+ FI;
+ UNTIL naechstes symbol = "" PER;
+ leeres layout;
+
+ . pruefe ende der select kette :
+ IF pos (zeile, "SELECT") <> 0
+ THEN scan (zeile);
+ naechstes symbol := "";
+ untersuche select kette;
+ FI;
+
+ . untersuche select kette :
+ REP symbol := naechstes symbol;
+ next symbol (naechstes symbol);
+ IF naechstes symbol = "SELECT"
+ THEN select counter INCR select step
+ ELIF naechstes symbol = "ENDSELECT"
+ THEN select counter DECR 1
+ FI;
+ UNTIL naechstes symbol = "" PER;
+
+ . select step :
+ IF symbol = "END" THEN -1 ELSE 1 FI
+
+.
+ bestimme elan zeile :
+ IF zeile ist nicht zu lang
+ THEN elan text CAT zeile;
+ ELSE drucke zeile in teilen
+ FI;
+
+ . zeile ist nicht zu lang :
+ zeilen laenge := LENGTH zeile;
+ zeilen laenge <= rest auf zeile
+
+ . rest auf zeile :
+ max zeichen zeile - LENGTH elan text
+
+ . drucke zeile in teilen :
+ zeilen pos := 1;
+ bestimme einrueckung;
+ WHILE zeile noch nicht ganz gedruckt REP teil layout PER;
+
+ . bestimme einrueckung :
+ anzahl einrueck blanks := naechstes nicht blankes zeichen - 1;
+ IF anzahl einrueck blanks > rest auf zeile - 20
+ THEN anzahl einrueck blanks := 0 FI;
+
+ . zeile noch nicht ganz gedruckt :
+ bestimme zeilenteil;
+ NOT zeile ist zu ende
+
+ . bestimme zeilenteil :
+ bestimme laenge;
+ zeilen teil := subtext (zeile, zeilen pos, zeilen pos + laenge - 1);
+ elan text CAT zeilen teil;
+ zeilen pos INCR laenge;
+
+ . zeilen teil : par1
+
+ . bestimme laenge :
+ INT VAR laenge := zeilen laenge - zeilen pos + 1;
+ IF laenge > rest auf zeile
+ THEN laenge := rest auf zeile;
+ WHILE (zeile SUB (zeilen pos + laenge - 1)) <> " "
+ REP laenge DECR 1 UNTIL laenge = 0 PER;
+ IF laenge = 0 THEN laenge := rest auf zeile FI;
+ FI;
+
+ . teil layout :
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ elan text := (zeilen nr laenge - 1) * " ";
+ elan text CAT "+";
+ elan text CAT layout blanks;
+ elan text CAT "|";
+ elan text cat blanks (anzahl einrueck blanks + teil einrueckung);
+
+.
+ seiten wechsel wenn noetig :
+ IF keine zeilen mehr AND NOT eof THEN seiten wechsel FI;
+
+ . keine zeilen mehr :
+ rest auf seite <= 4 * font hoehe
+
+END PROC drucke datei;
+
+
+BOOL PROC real conversion ok (TEXT CONST param) :
+ real param := real (param);
+ last conversion ok AND real param >= 0.0
+END PROC real conversion ok;
+
+
+BOOL PROC int conversion ok (TEXT CONST param) :
+ int param := int (param);
+ last conversion ok AND int param >= 0
+END PROC int conversion ok;
+
+
+PROC neuer tab eintrag (INT CONST typ, TEXT CONST param) :
+
+ suche neuen eintrag;
+ sortiere neue tab position ein;
+ tab typ := typ;
+ tab position := neue tab position;
+ tab param := eventueller parameter;
+
+ . suche neuen eintrag :
+ INT VAR index := 0;
+ REP index INCR 1;
+ IF tab speicher (index). tab typ = leer
+ THEN LEAVE suche neuen eintrag FI;
+ UNTIL index = max tabs PER;
+ LEAVE neuer tab eintrag;
+
+ . sortiere neue tab position ein :
+ INT VAR neue tab position := x step conversion (real param);
+ FOR tab index FROM 1 UPTO anzahl tabs
+ REP IF tab position = neue tab position
+ THEN LEAVE neuer tab eintrag
+ ELIF tab position > neue tab position
+ THEN insert int (tab liste, tab index, index);
+ LEAVE sortiere neue tab position ein;
+ FI;
+ PER;
+ tab liste CAT index;
+ tab index := anzahl tabs;
+
+ . eventueller parameter :
+ INT VAR link;
+ SELECT typ OF
+ CASE a dpos : insert (d strings, param, link); link
+ CASE a bpos : x step conversion (real(param))
+ OTHERWISE : 0
+ END SELECT
+
+END PROC neuer tab eintrag;
+
+
+PROC neue spalte :
+ a ypos := top margin;
+ aktuelle zeilentiefe der letzten zeile := 0;
+ left margin INCR (limit + luecke);
+ aktuelle spalte INCR 1;
+END PROC neue spalte ;
+
+
+BOOL PROC proc oder op (TEXT CONST symbol) :
+
+ symbol = "PROC" OR symbol = "PROCEDURE"
+ OR symbol = "OP" OR symbol = "OPERATOR"
+
+ENDPROC proc oder op ;
+
+
+PROC layout (TEXT CONST pre, TEXT VAR name, TEXT CONST post) :
+
+name := subtext (name, 1, layout laenge name) ;
+elan text := text (zeilen nr, zeilen nr laenge);
+elan text CAT pre;
+elan text CAT name;
+elan text CAT " ";
+generiere strukturiertes layout;
+
+. generiere strukturiertes layout :
+ INT VAR index;
+ FOR index FROM 1 UPTO layout laenge - LENGTH elan text - 1
+ REP elan text CAT post PER;
+
+END PROC layout ;
+
+
+PROC elan text cat blanks (INT CONST anzahl) :
+
+ par2 := anzahl * " ";
+ elan text CAT par2;
+
+END PROC elan text cat blanks;
+
+
+(***********************************************************************)
+
+PROC analysiere zeile (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator) :
+
+loesche analysespeicher;
+behandle fuehrende blanks;
+pruefe ob markierung links;
+
+IF tabellen modus
+ THEN analysiere tabellenzeile
+ELIF letzte zeile war absatzzeile
+ THEN analysiere zeile nach absatzzeile
+ ELSE analysiere zeile nach blockzeile
+FI;
+
+pruefe center und right modus;
+pruefe ob tabulation vorliegt;
+werte indexspeicher aus;
+IF zeile ist keine anweisungszeile
+ THEN berechne zeilenvorschub;
+ pruefe ob markierung rechts;
+ ELSE behandle anweisungszeile;
+FI;
+
+.
+ analysiere zeile nach absatzzeile :
+ test auf aufzaehlung;
+ IF zeile muss geblockt werden
+ THEN analysiere blockzeile nach absatzzeile
+ ELSE analysiere absatzzeile nach absatzzeile
+ FI;
+.
+ analysiere zeile nach blockzeile :
+ IF zeile muss geblockt werden
+ THEN analysiere blockzeile nach blockzeile
+ ELSE analysiere absatzzeile nach blockzeile
+ FI;
+
+
+.
+ behandle fuehrende blanks :
+ zeilenpos := 1;
+ zeilenpos := naechstes nicht blankes zeichen;
+ letzte zeile war absatzzeile := zeile ist absatzzeile;
+ IF letzte zeile war absatzzeile THEN neue einrueckung FI;
+ IF zeilenpos = 0
+ THEN behandle leerzeile;
+ LEAVE analysiere zeile;
+ ELSE initialisiere analyse;
+ FI;
+
+ . behandle leerzeile :
+ a ypos INCR (letzte zeilenhoehe +
+ aktuelle zeilentiefe der letzten zeile + durchschuss);
+ aktuelle zeilentiefe der letzten zeile := letzte zeilentiefe;
+ zeile ist absatzzeile := LENGTH zeile > 0;
+ pruefe ob markierung links;
+ pruefe ob markierung rechts;
+
+ . neue einrueckung :
+ aktuelle einrueckbreite := einrueckbreite;
+
+ . initialisiere analyse :
+ zeile ist absatzzeile := (zeile SUB LENGTH zeile) = blank;
+ zeile muss geblockt werden := block modus AND NOT zeile ist absatzzeile;
+ erstes token der zeile := token index f + 1;
+ zeilen laenge := laenge der zeile;
+ anzahl einrueck blanks := zeilen pos - 1;
+ anzahl zeichen := anzahl einrueck blanks;
+ a xpos := left margin + anzahl zeichen * aktuelle einrueckbreite;
+ a modifikationen fuer x move := 0;
+ letzter font := a font;
+ letzte modifikationen := a modifikationen;
+ fuehrende anweisungen := 0;
+ initialisiere zeilenvorschub;
+ IF zeile muss geblockt werden THEN initialisiere tab variablen FI;
+ IF hoechster index zaehler > 0 THEN loesche index speicher FI;
+
+ . laenge der zeile :
+ IF zeile ist absatzzeile
+ THEN LENGTH zeile - 1
+ ELSE LENGTH zeile
+ FI
+
+.
+ pruefe ob markierung links :
+ INT VAR linkes markierungs token;
+ IF markierung links
+ THEN mark token (mark index l). xpos :=
+ left margin - mark token (mark index l). breite;
+ linkes markierungs token := token index f + 1;
+ lege markierungs token an (mark index l);
+ erstes token der zeile := token index f + 1;
+ initialisiere tab variablen;
+ ELSE linkes markierungs token := 0;
+ FI;
+
+.
+ analysiere tabellenzeile :
+ anfangs blankmodus := doppel blank;
+ alte zeilenpos := zeilen pos;
+ a xpos := left margin;
+ FOR tab index FROM 1 UPTO anzahl tabs
+ REP lege fuell token an wenn noetig;
+ initialisiere tab variablen;
+ SELECT tab typ OF
+ CASE a lpos : linksbuendige spalte
+ CASE a rpos : rechtsbuendige spalte
+ CASE a cpos : zentrierte spalte
+ CASE a dpos : dezimale spalte
+ CASE a bpos : geblockte spalte
+ END SELECT;
+ berechne fuell token wenn noetig;
+ tabulation;
+ PER;
+ analysiere rest der zeile;
+
+ . lege fuell token an wenn noetig :
+ IF fill char <> blank
+ THEN fuellzeichen := fill char;
+ fuellzeichen breite := string breite (fuellzeichen);
+ token zeiger := zeilen pos;
+ erstes fuell token := token index f + 1;
+ lege token an (zeile, token zeiger, zeilen pos - 1, text token);
+ letztes fuell token := token index f;
+ a modifikationen fuer x move := a modifikationen
+ FI;
+
+ . berechne fuell token wenn noetig :
+ IF erstes fuell token <> leer
+ THEN IF letztes fuell token <> token index f
+ THEN berechne fuell token;
+ ELSE loesche letzte token;
+ FI;
+ erstes fuell token := leer
+ FI;
+
+ . berechne fuell token :
+ INT VAR anzahl fuellzeichen, fuell breite;
+ token index := erstes fuell token;
+ anzahl fuellzeichen := (tab anfang - t. xpos + left margin)
+ DIV fuellzeichen breite;
+ rest := (tab anfang - t. xpos + left margin)
+ MOD fuellzeichen breite;
+ IF anzahl fuell zeichen > 0
+ THEN fuell text := anzahl fuellzeichen * fuellzeichen;
+ fuell breite := anzahl fuellzeichen * fuellzeichen breite;
+ FOR token index FROM erstes fuell token UPTO letztes fuell token
+ REP t. text := fuell text;
+ t. breite := fuell breite;
+ IF erstes fuell token <> erstes token der zeile
+ THEN t. xpos INCR rest DIV 2;
+ t. modifikationen fuer x move := t. modifikationen;
+ FI;
+ PER;
+ FI;
+
+ . fuell text : par1
+
+ . loesche letzte token :
+ FOR token index FROM letztes fuell token DOWNTO erstes fuell token
+ REP loesche letztes token PER;
+
+ . tabulation :
+ alte zeilenpos := zeilenpos;
+ zeilenpos := naechstes nicht blankes zeichen;
+ IF zeilenpos = 0
+ THEN zeilenpos := zeilenlaenge + 1;
+ LEAVE analysiere tabellenzeile;
+ FI;
+ anzahl zeichen INCR zeilenpos - alte zeilenpos;
+
+ . linksbuendige spalte :
+ a xpos := left margin + tab position;
+ tab anfang := tab position;
+ bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+
+ . rechtsbuendige spalte :
+ bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ schreibe zeile rechtsbuendig (tab position);
+
+ . zentrierte spalte :
+ bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ zentriere zeile (tab position);
+
+ . dezimale spalte :
+ d string := name (d strings, tab param);
+ d code 1 := code (d string SUB 1) + 1;
+ d pitch := zeichenbreiten (d code 1);
+ zeichenbreiten (d code 1) := d code ausgang;
+ bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ zeichenbreiten (d code 1) := d pitch;
+ d code 1 := leer;
+ schreibe zeile rechtsbuendig (tab position);
+ IF zeichen ist dezimal zeichen
+ THEN IF tab position <> zeilen breite
+ THEN a xpos := left margin + tab position;
+ tab anfang := tab position;
+ FI;
+ bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ FI;
+
+ . zeichen ist dezimal zeichen :
+ pos (zeile, d string, zeilen pos) = zeilen pos
+
+ . geblockte spalte :
+ blankmodus := einfach blank;
+ a xpos := left margin + tab position;
+ tab anfang := tab position;
+ REP bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ IF zeile ist zu ende OR naechstes zeichen ist blank
+ THEN blocke spalte wenn noetig;
+ LEAVE geblockte spalte;
+ ELSE dehnbares blank gefunden;
+ FI;
+ PER;
+
+ . blocke spalte wenn noetig :
+ IF letztes zeichen ist kein geschuetztes blank
+ THEN blocke zeile (tab param) FI;
+ blank modus := doppel blank;
+
+ . letztes zeichen ist kein geschuetztes blank :
+ pos (zeile, geschuetztes blank, zeilen pos - 1, zeilen pos - 1) = 0
+ AND NOT within kanji (zeile, zeilen pos - 2)
+
+ . analysiere rest der zeile :
+ blankmodus := keine blankanalyse;
+ zeilen pos := alte zeilenpos;
+ bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+
+.
+ test auf aufzaehlung :
+ anfangs blankmodus := einfach blank;
+ bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ IF zeile ist zu ende
+ THEN LEAVE analysiere zeile nach absatzzeile
+ ELSE aufzaehlung moeglich
+ FI;
+
+ . aufzaehlung moeglich :
+ bestimme letztes zeichen;
+ IF (anzahl zeichen bei aufzaehlung < 2 AND letztes zeichen = "-")
+ OR (anzahl zeichen bei aufzaehlung < 20 AND letztes zeichen = ":")
+ OR (anzahl zeichen bei aufzaehlung < 7
+ AND pos (".)", letztes zeichen) <> 0)
+ OR naechstes zeichen ist blank
+ THEN tabulator position gefunden;
+ ELIF zeile muss geblockt werden
+ THEN dehnbares blank gefunden;
+ FI;
+
+ . bestimme letztes zeichen :
+ token index := token index f;
+ WHILE token index >= erstes token der zeile
+ REP IF token ist text token
+ THEN letztes zeichen := t. text SUB LENGTH t. text;
+ LEAVE bestimme letztes zeichen;
+ FI;
+ token index DECR 1;
+ PER;
+ letztes zeichen := "";
+
+ . letztes zeichen : par1
+
+ . anzahl zeichen bei aufzaehlung :
+ anzahl zeichen - anzahl einrueck blanks
+
+ . token ist text token :
+ t. offset index >= text token
+.
+ analysiere blockzeile nach absatzzeile :
+ REP bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ IF zeile ist zu ende
+ THEN blocke zeile (limit);
+ LEAVE analysiere blockzeile nach absatzzeile
+ ELSE analysiere blank in blockzeile nach absatzzeile
+ FI;
+ PER;
+
+ . analysiere blank in blockzeile nach absatzzeile :
+ IF naechstes zeichen ist blank
+ THEN tabulator position gefunden;
+ ELSE dehnbares blank gefunden;
+ FI;
+
+.
+ analysiere absatzzeile nach absatzzeile :
+ blankmodus := doppel blank;
+ REP bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ IF zeile ist zu ende
+ THEN LEAVE analysiere absatzzeile nach absatzzeile
+ ELSE tabulator position gefunden
+ FI;
+ PER;
+
+.
+ analysiere blockzeile nach blockzeile :
+ anfangs blankmodus := einfach blank;
+ REP bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ IF zeile ist zu ende
+ THEN blocke zeile (limit);
+ LEAVE analysiere blockzeile nach blockzeile
+ ELSE dehnbares blank gefunden
+ FI;
+ PER;
+
+.
+ analysiere absatzzeile nach blockzeile :
+ anfangs blankmodus := keine blankanalyse;
+ bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+
+
+.
+ dehnbares blank gefunden :
+ anzahl zeichen INCR 1;
+ zeilenpos INCR 1;
+ a xpos INCR blankbreite;
+ a modifikationen fuer x move := a modifikationen;
+ IF NOT a block token
+ THEN anzahl blanks INCR 1;
+ a block token := TRUE;
+ FI;
+.
+ tabulator position gefunden :
+ alte zeilenpos := zeilenpos;
+ zeilenpos := naechstes nicht blankes zeichen;
+ IF zeilenpos = 0
+ THEN zeilenpos := zeilen laenge + 1;
+ ELSE IF erstes token der zeile > token index f
+ THEN token zeiger := zeilen pos;
+ lege token an (zeile, token zeiger, zeilen pos - 1, text token);
+ FI;
+ anzahl zeichen INCR (zeilenpos - alte zeilenpos);
+ a xpos := left margin + anzahl zeichen * aktuelle einrueckbreite;
+ a modifikationen fuer x move := a modifikationen;
+ IF zeile muss geblockt werden THEN initialisiere tab variablen FI;
+ FI;
+
+.
+ pruefe center und right modus :
+ IF center modus THEN zentriere zeile (limit DIV 2) FI;
+ IF right modus THEN schreibe zeile rechtsbuendig (limit) FI;
+.
+ pruefe ob tabulation vorliegt:
+ IF analyse speicher ist nicht leer CAND a xpos > tf. xpos + tf. breite
+ THEN a modifikationen fuer x move := a modifikationen;
+ token zeiger := zeilen pos;
+ lege token an (zeile, token zeiger, zeilen pos - 1, text token);
+ FI;
+.
+ werte indexspeicher aus :
+ INT VAR index;
+ IF index zaehler > 0
+ THEN FOR index FROM index zaehler DOWNTO 1
+ REP a ypos DECR (index verschiebung ISUB index);
+ IF (letzte index breite ISUB index) <> 0
+ THEN a xpos := (xpos vor index ISUB index) +
+ min (a xpos - (xpos vor index ISUB index),
+ letzte index breite ISUB index);
+ FI;
+ PER;
+ stelle neuen font ein (grosse fonts ISUB 1);
+ FI;
+.
+ zeile ist keine anweisungszeile :
+ fuehrende anweisungen <> zeilen laenge
+.
+ berechne zeilenvorschub :
+ verschiebung := aktuelle zeilenhoehe +
+ aktuelle zeilentiefe der letzten zeile + durchschuss;
+ aktuelle zeilentiefe der letzten zeile := aktuelle zeilentiefe;
+ a ypos INCR verschiebung;
+ verschiebe token ypos (verschiebung);
+
+.
+ pruefe ob markierung rechts :
+ IF markierung rechts
+ THEN mark token (mark index r). xpos := left margin + limit;
+ lege markierungs token an (mark index r);
+ FI;
+.
+ behandle anweisungszeile :
+ IF linkes markierungs token > 0
+ THEN IF erstes token der zeile = token index f + 1
+ THEN loesche analysespeicher;
+ ELSE FOR token index FROM linkes markierungs token
+ UPTO erstes token der zeile - 1
+ REP t. text := "";
+ t. xpos := 0;
+ t. breite := 0;
+ PER;
+ FI;
+ FI;
+
+END PROC analysiere zeile;
+
+
+PROC blocke zeile (INT CONST rechter rand) :
+
+rest := rechter rand - zeilen breite;
+IF rest > 0 AND anzahl blanks > 0
+ THEN INT CONST schmaler schritt := rest DIV anzahl blanks,
+ breiter schritt := schmaler schritt + 1,
+ anzahl breite schritte := rest MOD anzahl blanks;
+ IF rechts
+ THEN blocke token xpos (breiter schritt, schmaler schritt,
+ anzahl breite schritte);
+ rechts := FALSE;
+ ELSE blocke token xpos (schmaler schritt, breiter schritt,
+ anzahl blanks - anzahl breite schritte);
+ rechts := TRUE;
+ FI;
+ a xpos INCR ( breiter schritt * anzahl breite schritte +
+ schmaler schritt * (anzahl blanks - anzahl breite schritte) );
+FI;
+
+END PROC blocke zeile;
+
+
+PROC zentriere zeile (INT CONST zentrier pos) :
+
+IF erstes tab token <= token index f
+ THEN verschiebung := zentrier pos - tab anfang -
+ (zeilen breite - tab anfang) DIV 2;
+ verschiebe token xpos (verschiebung);
+ a xpos INCR verschiebung;
+ tab anfang INCR verschiebung;
+FI;
+center modus := FALSE;
+
+END PROC zentriere zeile;
+
+
+PROC schreibe zeile rechtsbuendig (INT CONST rechte pos) :
+
+IF erstes tab token <= token index f
+ THEN verschiebung := rechte pos - zeilen breite;
+ verschiebe token xpos (verschiebung);
+ a xpos INCR verschiebung;
+ tab anfang INCR verschiebung;
+FI;
+right modus := FALSE;
+
+
+END PROC schreibe zeile rechtsbuendig;
+
+
+PROC bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator):
+
+token zeiger := zeilen pos;
+REP stranalyze (zeichenbreiten, a breite, max breite,
+ zeile, zeilen pos, zeilen laenge,
+ ausgang);
+ zeilen pos INCR 1;
+ IF ausgang = blank ausgang
+ THEN analysiere blank
+ ELIF ausgang = anweisungs ausgang
+ THEN anweisung gefunden
+ ELIF ausgang = d code ausgang
+ THEN analysiere d string
+ ELIF ausgang = erweiterungs ausgang
+ THEN erweiterung gefunden
+ ELSE terminator oder zeilenende gefunden
+ FI;
+PER;
+
+. analysiere blank :
+ IF blankmodus = einfach blank OR
+ (blankmodus = doppel blank AND naechstes zeichen ist blank)
+ THEN terminator oder zeilenende gefunden
+ ELSE a breite INCR blankbreite;
+ zeilenpos INCR 1;
+ FI;
+
+. analysiere d string :
+ IF pos (zeile, d string, zeilen pos) = zeilen pos
+ THEN terminator oder zeilenende gefunden
+ ELSE IF d pitch = maxint
+ THEN erweiterung gefunden
+ ELIF d pitch < 0
+ THEN a breite INCR (d pitch XOR - maxint - 1);
+ zeilen pos INCR 2;
+ ELSE a breite INCR d pitch;
+ zeilenpos INCR 1;
+ FI;
+ FI;
+
+. erweiterung gefunden :
+ a breite INCR extended char pitch (a font, zeile SUB zeilen pos,
+ zeile SUB zeilen pos + 1);
+ zeilen pos INCR 2;
+
+. anweisung gefunden :
+ gegebenfalls neues token gefunden;
+ analysiere anweisung (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ IF zeile ist zu ende
+ THEN LEAVE bestimme token bis terminator oder zeilenende FI;
+ token zeiger := zeilenpos;
+
+. terminator oder zeilenende gefunden :
+ IF ausgang = null ausgang THEN zeilen laenge DECR 1 FI;
+ gegebenfalls neues token gefunden;
+ LEAVE bestimme token bis terminator oder zeilenende;
+
+ . gegebenfalls neues token gefunden :
+ IF token zeiger < zeilenpos
+ THEN lege token an (zeile, token zeiger, zeilen pos - 1, text token) FI;
+
+END PROC bestimme token bis terminator oder zeilen ende;
+
+
+PROC analysiere anweisung (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator) :
+
+ bestimme anweisung;
+ IF anweisung ist kommando
+ THEN lege token an (anweisung, 1, maxint, kommando token);
+ ELIF anweisung ist kein kommentar
+ THEN werte anweisung aus;
+ FI;
+
+ . anweisungsende : zeilen pos - 2
+
+ . erstes zeichen : par1
+
+. bestimme anweisung :
+ INT CONST anweisungsanfang := zeilenpos + 1;
+ zeilen pos := pos (zeile, anweisungszeichen, anweisungsanfang, zeilenlaenge);
+ IF zeilenpos = 0
+ THEN zeilenpos := anweisungsanfang - 1;
+ replace (zeile, zeilenpos, geschuetztes anweisungszeichen);
+ LEAVE analysiere anweisung;
+ FI;
+ IF fuehrende anweisungen = anweisungsanfang - 2 THEN fuehrende anweisungen := zeilen pos FI;
+ zeilen pos INCR 1;
+ anweisung := subtext (zeile, anweisungsanfang, anweisungsende);
+ erstes zeichen := anweisung SUB 1;
+
+. anweisung ist kommando :
+ IF erstes zeichen = quote
+ THEN scan (anweisung);
+ next symbol (anweisung, symbol type);
+ next symbol (par2, naechster symbol type);
+ IF symbol type <> text type OR naechster symbol type <> eof type
+ THEN LEAVE analysiere anweisung FI;
+ TRUE
+ ELIF erstes zeichen = druckerkommando zeichen
+ THEN delete char (anweisung, 1);
+ TRUE
+ ELSE FALSE
+ FI
+
+. anweisung ist kein kommentar :
+ erstes zeichen <> kommentar zeichen
+
+.
+ werte anweisung aus :
+ analyze command (anweisungs liste, anweisung, number type,
+ anweisungs index, anzahl params, par1, par2);
+ SELECT anweisungs index OF
+ CASE a type : type anweisung
+ CASE a on : on anweisung
+ CASE a off : off anweisung
+ CASE a ub, a fb : ub fb anweisung
+ CASE a ue, a fe : ue fe anweisung
+ CASE a center : center anweisung
+ CASE a right : right anweisung
+ CASE a up, a down : index anweisung
+ CASE a end up or down : end index anweisung
+ CASE a bsp : bsp anweisung
+ CASE a fillchar : fillchar anweisung
+ CASE a mark : mark anweisung
+ CASE a markend : markend anweisung
+ OTHERWISE : IF anweisungs index > 0
+ THEN speichere anweisung
+ ELSE rufe analysator
+ FI;
+ END SELECT;
+
+ . type anweisung :
+ change all (par1, " ", "");
+ stelle neuen font ein (font (par1));
+ a modifikationen := 0;
+ ueberpruefe groesste fontgroesse;
+ IF nicht innerhalb eines indexes
+ THEN berechne aktuelle zeilengroesse FI;
+
+ . nicht innerhalb eines indexes :
+ index zaehler = 0
+
+ . on anweisung :
+ par1 := par1 SUB 1;
+ IF pos (modifikations liste, par1) > 0
+ THEN set bit (a modifikationen, pos (modifikations liste, par1) - 1 );
+ FI;
+
+ . off anweisung :
+ par1 := par1 SUB 1;
+ IF pos (modifikations liste, par1) > 0
+ THEN reset bit (a modifikationen, pos (modifikations liste, par1) - 1 );
+ FI;
+
+ . ub fb anweisung :
+ IF anweisungs index = a ub
+ THEN par1 := "u"
+ ELSE par1 := "b"
+ FI;
+ on anweisung;
+
+ . ue fe anweisung :
+ IF anweisungs index = a ue
+ THEN par1 := "u"
+ ELSE par1 := "b"
+ FI;
+ off anweisung;
+
+ . center anweisung :
+ IF NOT zeile muss geblockt werden AND NOT tabellen modus
+ AND NOT right modus
+ THEN center modus := TRUE;
+ blankmodus := keine blankanalyse;
+ initialisiere tab variablen;
+ FI;
+
+ . right anweisung :
+ IF NOT zeile muss geblockt werden AND NOT tabellen modus
+ THEN IF center modus THEN zentriere zeile (limit DIV 2) FI;
+ right modus := TRUE;
+ blankmodus := keine blankanalyse;
+ initialisiere tab variablen;
+ FI;
+
+ . index anweisung :
+ INT CONST grosser font := a font,
+ grosse fonthoehe := fonthoehe, grosse fonttiefe := fonttiefe;
+ INT VAR kleiner font;
+ IF next smaller font exists (grosser font, kleiner font)
+ THEN stelle neuen font ein (kleiner font) FI;
+ IF font hoehe < grosse fonthoehe
+ THEN verschiebung := verschiebung fuer kleinen font
+ ELSE verschiebung := verschiebung fuer grossen font
+ FI;
+ a ypos INCR verschiebung;
+ merke index werte;
+
+ . verschiebung fuer kleinen font :
+ IF anweisungs index = a down
+ THEN 15 PROZENT (grosse fonthoehe + grosse fonttiefe)
+ ELSE - ( 4 PROZENT (grosse fonthoehe + grosse fonttiefe) )
+ - (grosse fonthoehe + grosse fonttiefe - fonthoehe - fonttiefe)
+ FI
+
+ . verschiebung fuer grossen font :
+ IF anweisungs index = a down
+ THEN 25 PROZENT (fonthoehe + fonttiefe)
+ ELSE - (50 PROZENT (fonthoehe + fonttiefe) )
+ FI
+
+ . merke index werte :
+ index zaehler INCR 1;
+ IF hoechster index zaehler < index zaehler
+ THEN neues index level
+ ELSE altes index level
+ FI;
+ IF index zaehler = 1
+ THEN alter blankmodus := blankmodus;
+ blankmodus := keine blankanalyse;
+ FI;
+
+ . neues index level :
+ hoechster index zaehler := index zaehler;
+ letzte index breite CAT 0;
+ xpos vor index CAT a xpos;
+ zeilenpos nach index CAT -1;
+ index verschiebung CAT verschiebung;
+ grosse fonts CAT grosser font;
+
+ . altes index level :
+ IF (zeilenpos nach index ISUB index zaehler) = anweisungsanfang - 1
+ AND sign (index verschiebung ISUB index zaehler) <> sign (verschiebung)
+ THEN doppelindex gefunden;
+ ELSE replace (xpos vor index, index zaehler, a xpos);
+ FI;
+ replace (index verschiebung, index zaehler, verschiebung);
+ replace (grosse fonts, index zaehler, grosser font);
+
+ . doppelindex gefunden :
+ replace (letzte index breite, index zaehler,
+ a xpos - (xpos vor index ISUB index zaehler));
+ a xpos := xpos vor index ISUB index zaehler;
+
+ . end index anweisung :
+ IF index zaehler > 0
+ THEN schalte auf alte index werte zurueck;
+ FI;
+
+ . schalte auf alte index werte zurueck :
+ IF index zaehler = 1 THEN blankmodus := alter blankmodus FI;
+ a ypos DECR (index verschiebung ISUB index zaehler);
+ stelle neuen font ein (grosse fonts ISUB index zaehler);
+ IF (letzte index breite ISUB index zaehler) <> 0
+ THEN berechne doppelindex
+ ELSE replace (zeilenpos nach index, index zaehler, zeilenpos);
+ FI;
+ index zaehler DECR 1;
+
+ . berechne doppelindex :
+ a xpos := (xpos vor index ISUB index zaehler) +
+ max (a xpos - (xpos vor index ISUB index zaehler),
+ letzte index breite ISUB index zaehler);
+ replace (zeilenpos nach index, index zaehler, -1);
+ replace (letzte index breite, index zaehler, 0);
+
+ . bsp anweisung :
+ INT VAR breite davor, breite dahinter;
+ IF anweisungs anfang - 2 >= 1 AND anweisungs ende + 2 <= zeilen laenge
+ THEN IF is kanji esc (zeile SUB anweisungs anfang - 3)
+ THEN zeichen davor := subtext (zeile, anweisungs anfang - 3,
+ anweisungs anfang - 2);
+ ELSE zeichen davor := zeile SUB anweisungs anfang - 2;
+ FI;
+ IF is kanji esc (zeile SUB anweisungs ende + 2)
+ THEN zeichen dahinter := subtext (zeile, anweisungs ende + 2,
+ anweisungs ende + 3 );
+ ELSE zeichen dahinter := zeile SUB anweisungs ende + 2;
+ FI;
+ IF pos (" #", zeichen davor) = 0 AND pos (" #", zeichen dahinter) = 0
+ THEN breite davor := char pitch (a font, zeichen davor);
+ breite dahinter := char pitch (a font, zeichen dahinter);
+ IF breite davor < breite dahinter THEN vertausche zeichen FI;
+ lege token fuer zeichen dahinter an;
+ a xpos INCR (breite davor - breite dahinter) DIV 2;
+ FI;
+ FI;
+
+ . zeichen davor : par1
+ . zeichen dahinter : par2
+
+ . vertausche zeichen :
+ change (zeile, anweisungs anfang - 2 - LENGTH zeichen davor + 1,
+ anweisungs anfang - 2, zeichen dahinter);
+ change (zeile, anweisungs ende + 2,
+ anweisungs ende + 2 + LENGTH zeichen dahinter - 1, zeichen davor);
+ change (tf. text, LENGTH tf. text - LENGTH zeichen davor + 1,
+ LENGTH tf. text, zeichen dahinter);
+ tf. breite INCR (breite dahinter - breite davor);
+ a xpos INCR (breite dahinter - breite davor);
+ int param := breite davor;
+ breite davor := breite dahinter;
+ breite dahinter := int param;
+
+ . lege token fuer zeichen dahinter an :
+ token zeiger := zeilen pos;
+ a breite := breite dahinter;
+ zeilen pos INCR LENGTH zeichen dahinter;
+ a xpos DECR (breite davor + breite dahinter) DIV 2;
+ lege token an (zeile, token zeiger, zeilen pos - 1, text token);
+ anzahl zeichen DECR 1;
+
+ . fillchar anweisung :
+ IF par1 = "" THEN par1 := " " FI;
+ fill char := par1;
+ speichere anweisung;
+
+ . mark anweisung :
+ IF par1 <> ""
+ THEN mark index l := (alter mark index l MOD 2) + 1;
+ neue markierung (par1, mark index l);
+ ELSE mark index l := 0;
+ FI;
+ IF par2 <> ""
+ THEN mark index r := (alter mark index r MOD 2) + 3;
+ neue markierung (par2, mark index r);
+ ELSE mark index r := 0;
+ FI;
+
+ . markend anweisung :
+ loesche markierung;
+
+ . speichere anweisung :
+ anweisungs zaehler INCR 1;
+ anweisungs indizes CAT anweisungs index;
+ IF par1 <> ""
+ THEN insert (params1, par1);
+ params1 zeiger CAT highest entry (params1);
+ ELSE params1 zeiger CAT 0;
+ FI;
+ IF par2 <> ""
+ THEN insert (params2, par2);
+ params2 zeiger CAT highest entry (params2);
+ ELSE params2 zeiger CAT 0;
+ FI;
+
+ . rufe analysator :
+ INT CONST alte xpos := a xpos, alte y pos := a ypos;
+ INT VAR analysatorbreite, analysatorhoehe, analysatortiefe,
+ analysator font := a font,
+ analysator modifikationen := a modifikationen;
+ zeilen pos := anweisungsanfang - 1;
+disable stop;
+ analysator (text code, zeile, zeilen pos,
+ analysator font, analysator modifikationen,
+ analysatorbreite, analysatorhoehe, analysatortiefe, dummy);
+IF is error
+ THEN par1 := error message;
+ par1 CAT " a1-> ";
+ par1 CAT text (errorline);
+ clear error;
+ errorstop (par1);
+FI;
+enable stop;
+ hole token der analyse;
+ a xpos := alte xpos + analysatorbreite;
+ a ypos := alte ypos;
+ a modifikationen := analysator modifikationen;
+ groesste analysatorhoehe := max (analysatorhoehe, groesste analysator hoehe);
+ groesste analysatortiefe := max (analysatortiefe, groesste analysator tiefe);
+ IF analysator font <> a font
+ THEN stelle neuen font ein (analysator font);
+ ueberpruefe groesste fontgroesse;
+ IF nicht innerhalb eines indexes
+ THEN berechne aktuelle zeilengroesse FI;
+ ELSE aktuelle zeilenhoehe := max (groesste analysatorhoehe,
+ aktuelle zeilenhoehe);
+ aktuelle zeilentiefe := max (groesste analysatortiefe,
+ aktuelle zeilentiefe);
+ FI;
+
+ . hole token der analyse :
+ INT VAR token nr := 0, token font, token xpos, token ypos, token typ;
+ BOOL VAR font changed := FALSE;
+ token text := "";
+ REP
+disable stop;
+ analysator (token code, token text, token nr,
+ token font, a modifikationen, a breite,
+ token xpos, token ypos, token typ);
+IF is error
+ THEN par1 := error message;
+ par1 CAT " a2-> ";
+ par1 CAT text (errorline);
+ clear error;
+ errorstop (par1);
+FI;
+enable stop;
+ IF token nr = 0
+ THEN IF font changed THEN a font := -1 FI;
+ LEAVE hole token der analyse
+ FI;
+ IF token font <> a font
+ THEN a font := token font;
+ font offsets := y offsets (a font);
+ offsets := LENGTH font offsets > 2;
+ font changed := TRUE;
+ FI;
+ a xpos := alte xpos + token xpos;
+ a ypos := alte ypos + token ypos;
+ lege token an (token text, 1, max int, token typ)
+ PER;
+
+ . token text : par1
+
+END PROC analysiere anweisung;
+
+
+PROC stelle neuen font ein (INT CONST font nr ) :
+
+ IF font nr <> a font THEN neuer font FI;
+
+ . neuer font :
+ a font := max (1, font nr);
+ get font (a font, einrueckbreite, fontdurchschuss, fonthoehe, fonttiefe,
+ zeichenbreiten);
+ blankbreite := zeichenbreiten (blank code 1);
+ zeichenbreiten (blank code 1) := blank ausgang;
+ zeichenbreiten (anweisungs zeichen code 1) := anweisungs ausgang;
+ font offsets := y offsets (a font);
+ offsets := LENGTH font offsets > int length;
+ berechne fontgroesse;
+ berechne letzte zeilengroesse;
+ IF d code 1 <> leer
+ THEN d pitch := zeichenbreiten (d code 1);
+ zeichenbreiten (d code 1) := d code ausgang;
+ FI;
+
+END PROC stelle neuen font ein;
+
+
+INT OP PROZENT (INT CONST prozent, wert) :
+
+ (wert * prozent + 99) DIV 100
+
+END OP PROZENT;
+
+
+PROC neue markierung (TEXT CONST text, INT CONST mark index) :
+
+ mark token (mark index). text := text;
+ mark token (mark index). breite := string breite (text);
+ mark token (mark index). font := a font;
+ mark token (mark index). modifikationen := a modifikationen;
+
+END PROC neue markierung;
+
+
+INT PROC string breite (TEXT CONST string) :
+
+ INT VAR summe := 0, pos := 1;
+ REP stranalyze (zeichenbreiten, summe, max breite, string, pos, maxint, ausgang);
+ IF ausgang = erweiterungs ausgang
+ THEN summe INCR extended char pitch (a font,
+ string SUB pos+1, string SUB pos+2);
+ pos INCR 3;
+ ELIF ausgang = blank ausgang
+ THEN summe INCR blankbreite;
+ pos INCR 2;
+ ELIF ausgang = anweisungs ausgang
+ THEN summe INCR char pitch (a font, anweisungszeichen);
+ pos INCR 2;
+ ELSE LEAVE string breite WITH summe
+ FI;
+ PER;
+ 0
+
+END PROC string breite;
+
+(*******************************************************************)
+
+PROC lege token an (TEXT CONST token text,
+ INT CONST token anfang, token ende, token typ) :
+
+ INT VAR anfang := token anfang;
+ aktuelle ypos := a ypos + (font offsets ISUB 1);
+ neuer token index;
+ uebertrage token (tf, token text, token anfang, token ende, token typ);
+ IF token typ >= text token
+ THEN IF offsets THEN lege offsets an (font offsets) FI;
+ stranalyze (zeichen zaehler, anzahl zeichen, max int,
+ token text, anfang, token ende, ausgang);
+ a xpos INCR a breite;
+ FI;
+ a breite := 0;
+ a modifikationen fuer x move := 0;
+ a block token := FALSE;
+
+END PROC lege token an;
+
+
+PROC uebertrage token (TOKEN VAR tf, TEXT CONST token text,
+ INT CONST token anfang, token ende, token typ) :
+
+ tf. text := subtext (token text, token anfang, token ende);
+ tf. xpos := a xpos;
+ tf. breite := a breite;
+ tf. font := a font;
+ tf. modifikationen := a modifikationen;
+ tf. modifikationen fuer x move := a modifikationen fuer x move;
+ tf. offset index := token typ;
+ tf. block token := a block token;
+
+END PROC uebertrage token;
+
+
+PROC lege markierungs token an (INT CONST mark index) :
+
+ aktuelle ypos := a ypos + (mark font offsets ISUB 1);
+ neuer token index;
+ tf := mark token (mark index);
+ IF mark offsets THEN lege offsets an (mark font offsets) FI;
+
+ . mark font offsets : y offsets (mark token (mark index). font)
+
+ . mark offsets : LENGTH mark font offsets > int length
+
+END PROC lege markierungs token an;
+
+
+PROC lege offsets an (TEXT CONST offsets l) :
+
+ INT CONST anzahl offsets := LENGTH offsets l DIV int length;
+ INT VAR index;
+ offset token := tf;
+ offset token. block token := FALSE;
+ reset bit (offset token. modifikationen, underline bit);
+ reset bit (offset token. modifikationen fuer x move, underline bit);
+ FOR index FROM 2 UPTO anzahl offsets
+ REP aktuelle ypos := a ypos + (offsets l ISUB index);
+ neuer token index;
+ tf := offset token;
+ tf. offset index := index;
+ PER;
+
+END PROC lege offsets an;
+
+
+PROC neuer token index :
+
+IF erster ypos index a = 0
+ THEN erste ypos
+ELIF ya. ypos = aktuelle ypos
+ THEN neues token bei gleicher ypos
+ ELSE fuege neue ypos ein
+FI;
+
+ . erste ypos :
+ ypos index f INCR 1;
+ erster ypos index a := ypos index f;
+ letzter ypos index a := ypos index f;
+ yf. vorheriger ypos index := 0;
+ yf. naechster ypos index := 0;
+ erstes token bei neuer ypos;
+
+ . fuege neue ypos ein :
+ letztes token bei gleicher ypos;
+ IF ya. ypos > aktuelle ypos
+ THEN richtige ypos ist oberhalb
+ ELSE richtige ypos ist unterhalb
+ FI;
+
+ . richtige ypos ist oberhalb :
+ REP ypos index a := ya. vorheriger ypos index;
+ IF ypos index a = 0
+ THEN fuege ypos vor erstem ypos index ein;
+ LEAVE richtige ypos ist oberhalb;
+ ELIF ya. ypos = aktuelle ypos
+ THEN neues token bei neuer ypos;
+ LEAVE richtige ypos ist oberhalb;
+ ELIF ya. ypos < aktuelle ypos
+ THEN fuege ypos nach ypos index ein;
+ LEAVE richtige ypos ist oberhalb;
+ FI;
+ PER;
+
+ . richtige ypos ist unterhalb :
+ REP ypos index a := ya. naechster ypos index;
+ IF ypos index a = 0
+ THEN fuege ypos nach letztem ypos index ein;
+ LEAVE richtige ypos ist unterhalb;
+ ELIF ya. ypos = aktuelle ypos
+ THEN neues token bei neuer ypos;
+ LEAVE richtige ypos ist unterhalb;
+ ELIF ya. ypos > aktuelle ypos
+ THEN fuege ypos vor ypos index ein;
+ LEAVE richtige ypos ist unterhalb;
+ FI;
+ PER;
+
+ . fuege ypos vor erstem ypos index ein :
+ ypos index f INCR 1;
+ yf. vorheriger ypos index := 0;
+ yf. naechster ypos index := erster ypos index a;
+ erster ypos index a := ypos index f;
+ ypos index a := yf. naechster ypos index;
+ ya. vorheriger ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+ . fuege ypos nach ypos index ein :
+ ypos index f INCR 1;
+ yf. vorheriger ypos index := ypos index a;
+ yf. naechster ypos index := ya. naechster ypos index;
+ ya. naechster ypos index := ypos index f;
+ ypos index a := yf. naechster ypos index;
+ ya. vorheriger ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+ . fuege ypos vor ypos index ein :
+ ypos index f INCR 1;
+ yf. naechster ypos index := ypos index a;
+ yf. vorheriger ypos index := ya. vorheriger ypos index;
+ ya. vorheriger ypos index := ypos index f;
+ ypos index a := yf. vorheriger ypos index;
+ ya. naechster ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+ . fuege ypos nach letztem ypos index ein :
+ ypos index f INCR 1;
+ yf. naechster ypos index := 0;
+ yf. vorheriger ypos index := letzter ypos index a;
+ letzter ypos index a := ypos index f;
+ ypos index a := yf. vorheriger ypos index;
+ ya. naechster ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+END PROC neuer token index;
+
+
+PROC erstes token bei neuer ypos :
+ token index f INCR 1;
+ ypos index a := ypos index f;
+ ya. erster token index := token index f;
+ ya. ypos := aktuelle ypos;
+END PROC erstes token bei neuer ypos;
+
+
+PROC neues token bei neuer ypos :
+ token index f INCR 1;
+ ya. ypos := aktuelle ypos;
+ token index := ya. letzter token index;
+ t. naechster token index := token index f;
+END PROC neues token bei neuer ypos;
+
+
+PROC neues token bei gleicher ypos :
+ tf. naechster token index := token index f + 1;
+ token index f INCR 1;
+END PROC neues token bei gleicher ypos;
+
+
+PROC letztes token bei gleicher ypos :
+ tf. naechster token index := 0;
+ ya. letzter token index := token index f;
+END PROC letztes token bei gleicher ypos;
+
+
+PROC loesche letztes token :
+
+ IF token index f = ya. erster token index
+ THEN loesche ypos
+ ELSE token index f DECR 1;
+ FI;
+
+ . loesche ypos :
+ kette vorgaenger um;
+ kette nachfolger um;
+ bestimme letzten ypos index;
+
+ . kette vorgaenger um :
+ ypos index := ya. vorheriger ypos index;
+ IF ypos index = 0
+ THEN erster ypos index a := ya. naechster ypos index;
+ ELSE y. naechster ypos index := ya. naechster ypos index;
+ FI;
+
+ . kette nachfolger um :
+ ypos index := ya. naechster ypos index;
+ IF ypos index = 0
+ THEN letzter ypos index a := ya. vorheriger ypos index;
+ ELSE y. vorheriger ypos index := ya. vorheriger ypos index;
+ FI;
+
+ . bestimme letzten ypos index :
+ IF ypos index a = ypos index f THEN ypos index f DECR 1 FI;
+ token index f DECR 1;
+ ypos index a := letzter ypos index a;
+ WHILE ypos index a <> 0
+ CAND ya. letzter token index <> token index f
+ REP ypos index a := ya. vorheriger ypos index PER;
+
+END PROC loesche letztes token;
+
+
+PROC blocke token xpos (INT CONST dehnung 1, dehnung 2,
+ anzahl dehnungen fuer dehnung 1 ) :
+
+ INT VAR dehnung := 0, anzahl dehnungen := 0;
+ token index := erstes tab token;
+ WHILE token index <= token index f
+ REP erhoehe token xpos bei block token;
+ t. xpos INCR dehnung;
+ token index INCR 1;
+ PER;
+
+ . erhoehe token xpos bei block token :
+ IF t. block token
+ THEN IF anzahl dehnungen < anzahl dehnungen fuer dehnung 1
+ THEN anzahl dehnungen INCR 1;
+ dehnung INCR dehnung 1;
+ ELSE dehnung INCR dehnung 2;
+ FI;
+ FI;
+
+END PROC blocke token xpos;
+
+
+PROC verschiebe token xpos (INT CONST verschiebung l) :
+
+ token index := erstes tab token;
+ WHILE token index <= token index f
+ REP t. xpos INCR verschiebung l;
+ token index INCR 1;
+ PER;
+
+END PROC verschiebe token xpos;
+
+
+PROC verschiebe token ypos (INT CONST verschiebung l) :
+
+ ypos index := erster ypos index a;
+ WHILE ypos index <> 0
+ REP y. ypos INCR verschiebung l;
+ ypos index := y. naechster ypos index;
+ PER;
+
+END PROC verschiebe token ypos;
+
+
+PROC sortiere neue token ein :
+
+INT VAR index;
+IF analysespeicher ist nicht leer
+ THEN IF druckspeicher ist nicht leer
+ THEN sortiere neue token in sortierte liste ein
+ ELSE sortierte liste ist leer
+ FI;
+FI;
+
+. sortierte liste ist leer :
+ IF erster ypos index a <> 0
+ THEN erster ypos index d := erster ypos index a;
+ letzter ypos index d := letzter ypos index a;
+ ypos index d := letzter ypos index a;
+ FI;
+
+. sortiere neue token in sortierte liste ein :
+ gehe zum ersten neuen token;
+ bestimme erste einsortierposition;
+ WHILE es gibt noch neue token
+ REP IF ypos index d = 0
+ THEN haenge neue token ans ende der sortierten liste
+ ELIF ya. ypos > yd. ypos
+ THEN naechste ypos der sortierten liste
+ ELIF ya. ypos = yd. ypos
+ THEN neues token auf gleicher ypos
+ ELSE neue token vor ypos
+ FI;
+ PER;
+
+ . gehe zum ersten neuen token :
+ ypos index a := erster ypos index a;
+
+ . bestimme erste einsortierposition :
+ WHILE ypos index d <> 0 CAND ya. ypos < yd. ypos
+ REP ypos index d := yd. vorheriger ypos index PER;
+ IF ypos index d = 0 THEN erste neue token vor listen anfang FI;
+
+ . erste neue token vor listen anfang :
+ ypos index d := erster ypos index d;
+ erster ypos index d := erster ypos index a;
+ REP ypos index a := ya. naechster ypos index;
+ IF ypos index a = 0
+ THEN verkette letztes ya mit yd;
+ LEAVE sortiere neue token in sortierte liste ein
+ ELIF ya. ypos = yd. ypos
+ THEN verkette ya mit yd;
+ LEAVE erste neue token vor listen anfang
+ ELIF ya. ypos > yd. ypos
+ THEN verkette vorheriges ya mit yd;
+ ypos index d := yd. naechster ypos index;
+ LEAVE erste neue token vor listen anfang
+ FI;
+ PER;
+
+ . es gibt noch neue token :
+ ypos index a <> 0
+
+ . haenge neue token ans ende der sortierten liste :
+ ypos index d := letzter ypos index d;
+ yd. naechster ypos index := ypos index a;
+ ya. vorheriger ypos index := ypos index d;
+ letzter ypos index d := letzter ypos index a;
+ ypos index d := letzter ypos index a;
+ ypos index a := 0;
+
+ . naechste ypos der sortierten liste :
+ ypos index d := yd. naechster ypos index;
+
+ . neues token auf gleicher ypos :
+ token index := yd. letzter token index;
+ t . naechster token index := ya. erster token index;
+ yd. letzter token index := ya. letzter token index;
+ ypos index a := ya. naechster ypos index;
+ ypos index d := yd. naechster ypos index;
+ IF ypos index d = 0 THEN ypos index d := letzter ypos index d FI;
+
+ . neue token vor ypos :
+ verkette ya mit vorherigem yd;
+ REP ypos index a := ya. naechster ypos index;
+ IF ypos index a = 0
+ THEN verkette letztes ya mit yd;
+ LEAVE sortiere neue token in sortierte liste ein
+ ELIF ya. ypos = yd. ypos
+ THEN verkette ya mit yd;
+ LEAVE neue token vor ypos
+ ELIF ya. ypos > yd. ypos
+ THEN verkette vorheriges ya mit yd;
+ ypos index d := yd. naechster ypos index;
+ LEAVE neue token vor ypos
+ FI;
+ PER;
+
+
+. verkette ya mit vorherigem yd :
+ index := ypos index d;
+ ypos index d := yd. vorheriger ypos index;
+ yd. naechster ypos index := ypos index a;
+ ya. vorheriger ypos index := ypos index d;
+ ypos index d := index;
+
+. verkette letztes ya mit yd :
+ ypos index a := letzter ypos index a;
+ yd. vorheriger ypos index := ypos index a;
+ ya. naechster ypos index := ypos index d;
+ ypos index a := 0;
+
+. verkette vorheriges ya mit yd :
+ index := ypos index a;
+ ypos index a := ya. vorheriger ypos index;
+ yd. vorheriger ypos index := ypos index a;
+ ya. naechster ypos index := ypos index d;
+ ypos index a := index;
+
+. verkette ya mit yd :
+ verkette vorheriges ya mit yd;
+ neues token auf gleicher ypos;
+
+END PROC sortiere neue token ein;
+
+(***************************************************************)
+
+PROC drucke tokenspeicher
+ (INT CONST max ypos,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+IF druckspeicher ist nicht leer
+ THEN gehe zur ersten ypos;
+ WHILE yd. ypos <= max ypos
+ REP drucke token bei ypos;
+ gehe zur naechsten ypos;
+ PER;
+ loesche gedruckte token;
+FI;
+
+. gehe zur ersten ypos :
+ ypos index d := erster ypos index d;
+
+. drucke token bei ypos :
+ IF yd. ypos >= - y start
+ THEN druck durchgang;
+ IF bold pass THEN fett durchgang FI;
+ IF underline pass THEN unterstreich durchgang FI;
+ FI;
+
+ . bold pass : bit (pass, bold bit)
+
+ . underline pass : bit (pass, underline bit)
+
+. gehe zur naechsten ypos :
+ IF ypos index d = letzter ypos index d
+ THEN loesche druckspeicher;
+ LEAVE drucke tokenspeicher;
+ FI;
+ ypos index d := yd. naechster ypos index;
+
+. loesche gedruckte token :
+ erster ypos index d := ypos index d;
+ yd. vorheriger ypos index := 0;
+
+.
+ druck durchgang :
+ verschiebung := yd. ypos - d ypos;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ gehe zum ersten token dieser ypos;
+ REP drucke token UNTIL kein token mehr vorhanden PER;
+
+ . drucke token :
+ IF NOT token passt in zeile
+ THEN IF token ist text token
+ THEN berechne token teil
+ ELSE LEAVE drucke token
+ FI;
+ FI;
+ font wechsel wenn noetig;
+ x move mit modifikations ueberpruefung;
+ IF token ist text token
+ THEN gib text token aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ ELIF token ist linien token
+ THEN gib linien token aus
+ ELSE gib kommando token aus
+ FI;
+
+ . gib linien token aus :
+ linien verschiebung := d token. breite;
+ ziehe horizontale linie (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ . gib kommando token aus :
+ execute (write cmd, d token. text, 1, LENGTH d token. text)
+
+ . berechne token teil :
+ INT CONST fuenf punkte := 5 * char pitch (d token. font, punkt);
+ INT VAR token pos, token breite, anzahl punkte, zeichen laenge, zeichen breite;
+ IF d token. xpos < - x start
+ AND d token. xpos + d token. breite > - x start
+ THEN berechne token teil von links
+ ELIF d token. xpos < papierbreite
+ AND d token. xpos + d token. breite > papierbreite
+ THEN berechne token teil nach rechts
+ ELSE LEAVE drucke token
+ FI;
+
+ . berechne token teil von links :
+ rest := min (x size, d token. xpos + d token. breite + x start);
+ d token. xpos := - x start;
+ IF rest <= fuenf punkte
+ THEN anzahl punkte := rest DIV char pitch (d token. font, punkt);
+ d token. text := anzahl punkte * punkt;
+ d token. breite := anzahl punkte * char pitch (d token. font, punkt);
+ ELSE token pos := LENGTH d token. text + 1;
+ token breite := fuenf punkte;
+ berechne token teil breite von hinten;
+ change (d token. text, 1, token pos - 1, 5 * punkt);
+ d token. breite := token breite;
+ FI;
+
+ . berechne token teil breite von hinten :
+ WHILE naechstes zeichen passt noch davor
+ REP token breite INCR zeichen breite;
+ token pos DECR zeichen laenge;
+ PER;
+
+ . naechstes zeichen passt noch davor :
+ IF within kanji (d token. text, token pos - 1)
+ THEN zeichen laenge := 2
+ ELSE zeichen laenge := 1
+ FI;
+ zeichen breite := char pitch (d token. font,
+ subtext (d token. text, token pos - zeichen laenge, token pos - 1));
+ token breite + zeichen breite < rest
+
+ . berechne token teil nach rechts :
+ rest := papier breite - d token. xpos;
+ IF rest <= fuenf punkte
+ THEN anzahl punkte := rest DIV char pitch (d token. font, punkt);
+ d token. text := anzahl punkte * punkt;
+ d token. breite := anzahl punkte * char pitch (d token. font, punkt);
+ ELSE token pos := 0;
+ token breite := fuenf punkte;
+ berechne token teil breite von vorne;
+ change (d token. text, token pos + 1, LENGTH d token. text, 5 * punkt);
+ d token. breite := token breite;
+ FI;
+
+ . berechne token teil breite von vorne :
+ WHILE naechstes zeichen passt noch dahinter
+ REP token breite INCR zeichen breite;
+ token pos INCR zeichen laenge;
+ PER;
+
+ . naechstes zeichen passt noch dahinter :
+ IF is kanji esc (d token. text SUB token pos + 1)
+ THEN zeichen laenge := 2
+ ELSE zeichen laenge := 1
+ FI;
+ zeichen breite := char pitch (d token. font,
+ subtext (d token. text, token pos + 1, token pos + zeichen laenge));
+ token breite + zeichen breite < rest
+
+.
+ fett durchgang :
+ reset bit (pass, bold bit);
+ gib cr aus;
+ gehe zum ersten token dieser ypos;
+ REP gib token nochmal aus UNTIL kein token mehr vorhanden PER;
+ schalte modifikationen aus wenn noetig;
+
+ . gib token nochmal aus :
+ INT CONST min verschiebung := bold offset (d token. font);
+ d token. xpos INCR min verschiebung;
+ IF bit (d token. modifikationen, bold bit) AND
+ token passt in zeile AND token ist text token
+ THEN verschiebung := d token. xpos - d xpos;
+ font wechsel wenn noetig;
+ schalte italics ein wenn noetig;
+ x move wenn noetig;
+ gib text token aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ d token. xpos DECR min verschiebung;
+
+ . schalte italics ein wenn noetig :
+ IF bit (d token. modifikationen, italics bit)
+ THEN neue modifikationen := modifikations werte (italics bit + 1);
+ schalte modifikationen ein wenn noetig;
+ ELSE schalte modifikationen aus wenn noetig;
+ FI;
+
+.
+ unterstreich durchgang :
+ INT VAR l xpos := 0;
+ reset bit (pass, underline bit);
+ gib cr aus;
+ schalte modifikationen aus wenn noetig;
+ gehe zum ersten token dieser ypos;
+ REP unterstreiche token UNTIL kein token mehr vorhanden PER;
+
+ . unterstreiche token :
+ IF token muss unterstrichen werden AND
+ token passt in zeile AND token ist text token
+ THEN font wechsel wenn noetig;
+ berechne x move laenge;
+ x move wenn noetig;
+ berechne unterstreich laenge;
+ ziehe horizontale linie (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ l xpos := d token. xpos + d token. breite;
+
+ . token muss unterstrichen werden :
+ bit (d token. modifikationen, underline bit) OR
+ bit (d token. modifikationen fuer x move, underline bit)
+
+ . berechne x move laenge :
+ IF bit (d token. modifikationen fuer x move, underline bit)
+ THEN verschiebung := l xpos - d xpos
+ ELSE verschiebung := d token. xpos - d xpos
+ FI;
+
+ . berechne unterstreich laenge :
+ IF bit (d token. modifikationen, underline bit)
+ THEN linien verschiebung := d token. xpos +
+ d token. breite - d xpos
+ ELSE linien verschiebung := d token. xpos - d xpos
+ FI;
+ d token. offset index := - underline line type;
+
+
+. gehe zum ersten token dieser ypos :
+ token index := yd. erster token index;
+ d token := t;
+
+. kein token mehr vorhanden :
+ token index := d token. naechster token index;
+ IF token index = 0
+ THEN TRUE
+ ELSE d token := t;
+ FALSE
+ FI
+
+. token ist text token :
+ d token. offset index >= text token
+
+. token ist linien token :
+ d token. offset index <= linien token
+
+. token passt in zeile :
+ d token. xpos >= - x start AND
+ d token. xpos + d token. breite <= papier breite
+
+. font wechsel wenn noetig :
+ IF d token. font <> d font
+ THEN font wechsel (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. schalte modifikationen ein wenn noetig :
+ IF d modifikationen <> neue modifikationen
+ THEN schalte modifikationen ein (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. schalte modifikationen aus wenn noetig :
+ IF d modifikationen <> 0
+ THEN schalte modifikationen aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. x move wenn noetig :
+ IF verschiebung <> 0
+ THEN x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+.
+ x move mit modifikations ueberpruefung :
+ verschiebung := d token. xpos - d xpos;
+ IF verschiebung <> 0
+ THEN neue modifikationen := d token. modifikationen fuer x move;
+ schalte modifikationen ein wenn noetig;
+ x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ neue modifikationen := d token. modifikationen;
+ schalte modifikationen ein wenn noetig;
+
+. gib cr aus :
+ IF d xpos <> 0
+ THEN execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ FI;
+
+END PROC drucke tokenspeicher;
+
+
+PROC ziehe horizontale linie (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ IF linien verschiebung > 0
+ THEN disable stop;
+ d xpos INCR linien verschiebung;
+ execute (draw, "", linien verschiebung, 0);
+ IF is error
+ THEN ziehe horizontale linie nach cr;
+ FI;
+ enable stop;
+ FI;
+
+ . ziehe horizontale linie nach cr :
+ clear error;
+ d xpos DECR linien verschiebung;
+ verschiebung := d xpos;
+ gib cr aus;
+ x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ d xpos INCR linien verschiebung;
+ execute (draw, "", linien verschiebung, 0);
+ IF is error
+ THEN clear error;
+ d xpos DECR linien verschiebung;
+ FI;
+
+ . gib cr aus :
+ IF d xpos <> 0
+ THEN execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ FI;
+
+END PROC ziehe horizontale linie;
+
+
+PROC y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ IF verschiebung <> 0
+ THEN gib cr aus;
+ disable stop;
+ d ypos INCR verschiebung;
+ execute (move, "", 0, verschiebung);
+ IF is error
+ THEN clear error;
+ d ypos DECR verschiebung;
+ verschiebung := 0;
+ FI;
+ enable stop;
+ FI;
+
+ . gib cr aus :
+ IF d xpos <> 0
+ THEN execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ FI;
+
+END PROC y move;
+
+
+PROC x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ d xpos INCR verschiebung;
+ execute (move, "", verschiebung, 0);
+ IF is error
+ THEN fuehre x move nach cr aus
+ FI;
+
+ . fuehre x move nach cr aus :
+ clear error;
+ schalte modifikationen aus wenn noetig;
+ gib cr bei x move aus;
+ IF d xpos <> 0
+ THEN execute (move, "", d xpos, 0);
+ IF is error
+ THEN clear error;
+ d xpos := 0;
+ FI
+ FI;
+ schalte modifikationen ein wenn noetig;
+
+ . gib cr bei x move aus :
+ execute (carriage return, "", d xpos - verschiebung, 0);
+
+ . schalte modifikationen aus wenn noetig :
+ neue modifikationen := d modifikationen;
+ IF d modifikationen <> 0
+ THEN schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+
+ . schalte modifikationen ein wenn noetig :
+ IF d modifikationen <> neue modifikationen
+ THEN schalte modifikationen ein
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+
+END PROC x move;
+
+
+PROC schalte modifikationen ein
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ INT VAR index;
+ IF d modifikationen <> 0
+ THEN schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ d modifikationen := neue modifikationen;
+ FOR index FROM 1 UPTO anzahl modifikationen
+ REP IF bit (d modifikationen, modifikations bit)
+ THEN modifikation muss eingeschaltet werden
+ FI;
+ PER;
+
+ . modifikations bit : index - 1
+
+ . modifikation muss eingeschaltet werden :
+ IF bit (modifikations modus, modifikations bit)
+ THEN execute (on, "", modifikations werte (index), 0);
+ IF is error
+ THEN clear error;
+ reset bit (modifikations modus, modifikations bit);
+ set bit (pass, modifikations bit);
+ FI;
+ ELSE set bit (pass, modifikations bit);
+ FI;
+
+END PROC schalte modifikationen ein;
+
+
+PROC schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ INT VAR index;
+ FOR index FROM 1 UPTO anzahl modifikationen
+ REP IF bit (d modifikationen, modifikations bit)
+ THEN modifikation muss ausgeschaltet werden
+ FI;
+ PER;
+ d modifikationen := 0;
+
+ . modifikations bit : index - 1
+
+ . modifikation muss ausgeschaltet werden :
+ IF bit (modifikations modus, modifikations bit)
+ THEN execute (off, "", modifikations werte (index), 0);
+ IF is error THEN clear error FI;
+ FI;
+
+END PROC schalte modifikationen aus;
+
+
+PROC font wechsel
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ d font := d token. font;
+ get replacements (d font, replacements, replacement tabelle);
+ execute (type, "", d font, 0);
+ IF is error THEN font wechsel nach cr FI;
+ enable stop;
+
+ . font wechsel nach cr :
+ clear error;
+ verschiebung := d xpos;
+ gib cr aus;
+ execute (type, "", d font, 0);
+ IF NOT is error
+ THEN schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ x move
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+
+ . gib cr aus :
+ IF d xpos <> 0
+ THEN execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ FI;
+
+END PROC font wechsel;
+
+
+PROC gib text token aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ INT CONST token laenge := LENGTH d token. text;
+ INT VAR token pos := 1, alte token pos, summe := 0;
+ IF token laenge > 0
+ THEN REP alte token pos := token pos;
+ stranalyze (replacement tabelle, summe, 0,
+ d token. text, token pos, token laenge,
+ ausgang);
+ IF ausgang = 0
+ THEN gib token rest aus;
+ ELSE gib token teil aus;
+ gib ersatzdarstellung aus;
+ FI;
+ PER;
+ FI;
+
+ . gib token rest aus :
+ IF token laenge >= alte token pos
+ THEN execute (write text, d token. text, alte token pos, token laenge) FI;
+ d xpos INCR d token. breite;
+ LEAVE gib text token aus;
+
+ . gib token teil aus :
+ IF token pos >= alte token pos
+ THEN execute (write text, d token. text, alte token pos, token pos) FI;
+
+ . gib ersatzdarstellung aus :
+ IF ausgang = maxint
+ THEN ersatzdarstellung := extended replacement (d token. font,
+ d token. text SUB token pos + 1, d token. text SUB token pos + 2);
+ execute (write text, ersatzdarstellung, 1, LENGTH ersatzdarstellung);
+ tokenpos INCR 3;
+ ELSE IF ausgang < 0
+ THEN ausgang := ausgang XOR minint;
+ token pos INCR 1;
+ FI;
+ execute (write text, replacements, ausgang + 1, ausgang + code (replacements SUB ausgang));
+ token pos INCR 2;
+ FI;
+
+ . ersatzdarstellung : par1
+
+END PROC gib text token aus;
+
+
+PROC schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+enable stop;
+gebe restliche token aus;
+gib cr aus;
+seiten ende kommando;
+
+. gebe restliche token aus :
+ IF erster ypos index d <> 0
+ THEN drucke tokenspeicher (maxint,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ rest := papier laenge - d ypos;
+ aktuelle zeilentiefe der letzten zeile := 0;
+
+. gib cr aus :
+ IF d xpos <> 0
+ THEN execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ FI;
+
+. seiten ende kommando :
+ seite ist offen := FALSE;
+ a ypos := top margin;
+ aktuelle spalte := 1;
+ close (page, rest);
+
+END PROC schliesse seite ab;
+
+
+PROC eroeffne seite (INT CONST x wanted l, y wanted l,
+ PROC (INT CONST, INT VAR, INT VAR) open ) :
+
+IF vor erster seite THEN eroeffne druck FI;
+seiten anfang kommando;
+initialisiere neue seite;
+
+. eroeffne druck :
+ open (document, x size, y size);
+ vor erster seite := FALSE;
+ d font := -1;
+ d modifikationen := 0;
+
+. seiten anfang kommando :
+ x start := x wanted l;
+ y start := y wanted l;
+ open (page, x start, y start);
+ gedruckte seiten INCR 1;
+ seite ist offen := TRUE;
+
+. initialisiere neue seite :
+ INT CONST dif left margin := x wanted l - x start - left margin + indentation,
+ dif top margin := y wanted l - y start - top margin;
+ IF dif left margin <> 0
+ THEN erstes tab token := 1;
+ verschiebe token xpos (dif left margin);
+ a xpos INCR dif left margin;
+ left margin INCR dif left margin;
+ FI;
+ IF dif top margin <> 0
+ THEN verschiebe token ypos (dif top margin);
+ a ypos INCR dif top margin;
+ top margin INCR dif top margin;
+ FI;
+ d xpos := 0;
+ d ypos := 0;
+ IF seitenlaenge <= papierlaenge
+ THEN seitenlaenge := top margin + pagelength;
+ ELSE seitenlaenge DECR papierlaenge;
+ FI;
+ papierlaenge := y size - y start;
+ papierbreite := x size - x start;
+
+END PROC eroeffne seite;
+
+(****************************************************************)
+
+PROC elan fuss und kopf (INT CONST fuss oder kopf,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+IF fuss oder kopf <= 0 THEN elan fuss FI;
+IF fuss oder kopf >= 0 THEN elan kopf FI;
+
+.
+ elan fuss :
+ y move zur fusszeile;
+ drucke elan fuss;
+ close page cmd;
+
+. y move zur fusszeile :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ verschiebung := rest auf seite - font hoehe;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+. drucke elan fuss :
+ IF bottom label = ""
+ THEN seiten nr := ""
+ ELSE seiten nr := bottom label;
+ seiten nr CAT "/";
+ FI;
+ seiten nr CAT text (gedruckte seiten);
+ elan text := seiten nr;
+ elan text CAT " ";
+ elan text cat blanks ((max zeichen fuss - LENGTH dateiname) DIV 2 - LENGTH elan text);
+ elan text CAT dateiname;
+ elan text cat blanks (max zeichen fuss - LENGTH seiten nr - LENGTH elan text - 3);
+ elan text CAT " ";
+ elan text CAT seiten nr;
+ IF LENGTH elan text > max zeichen zeile
+ THEN elan text := subtext (elan text, 1, max zeichen zeile) FI;
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ . seiten nr : par1
+
+. close page cmd :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ close (page, papierlaenge - d ypos);
+ seite ist offen := FALSE;
+
+.
+ elan kopf :
+ open page cmd ;
+ y move zur kopfzeile;
+ drucke elan kopf;
+
+. open page cmd :
+ x start := x wanted;
+ y start := y wanted;
+ open (page, x start, y start);
+ IF fuss oder kopf = 1 THEN execute (type, "", d font, 0) FI;
+ gedruckte seiten INCR 1;
+ seite ist offen := TRUE;
+ top margin := y wanted - y start;
+ left margin := x wanted - x start;
+ rest auf seite := pagelength;
+ papierlaenge := y size - y start;
+ d ypos := 0;
+ d xpos := 0;
+
+. y move zur kopf zeile :
+ verschiebung := top margin;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ IF verschiebung = 0 THEN rest auf seite INCR top margin FI;
+
+. drucke elan kopf :
+ elan text := headline pre;
+ elan text CAT date;
+ elan text CAT headline post;
+ elan text CAT datei name;
+ IF LENGTH elan text > max zeichen zeile
+ THEN elan text := subtext (elan text, 1, max zeichen zeile) FI;
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ cr plus lf (2, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ENDPROC elan fuss und kopf;
+
+
+PROC gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+cr plus lf (1, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+linker rand wenn noetig;
+d token. breite := LENGTH elan text * einrueckbreite;
+gib text token aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+. linker rand wenn noetig :
+ IF left margin > 0
+ THEN disable stop;
+ d xpos := left margin;
+ execute (move, "", left margin, 0);
+ IF is error
+ THEN clear error;
+ d xpos := 0;
+ FI;
+ enable stop;
+ FI;
+
+END PROC gib elan text aus;
+
+
+PROC cr plus lf (INT CONST anzahl,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+gib cr aus;
+gib lf aus;
+rest auf seite DECR verschiebung;
+
+. gib cr aus :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+
+. gib lf aus :
+ verschiebung := anzahl * font hoehe;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+END PROC cr plus lf ;
+
+
+END PACKET eumel printer;
+
diff --git a/system/std.zusatz/1.8.7/src/eumelmeter b/system/std.zusatz/1.8.7/src/eumelmeter
new file mode 100644
index 0000000..ba92476
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/eumelmeter
@@ -0,0 +1,131 @@
+ (* Author: J.Liedtke*)
+PACKET eumelmeter DEFINES (* Stand: 11.10.83 *)
+
+ init log ,
+ log :
+
+
+LET snapshot interval = 590.0 ;
+
+REAL VAR next snapshot time ,
+ time , timex ,
+ paging wait , paging wait x ,
+ paging busy , paging busy x ,
+ fore cpu , fore cpu x ,
+ back cpu , back cpu x ,
+ system cpu , system cpu x ,
+ delta t ;
+INT VAR storage max, used ;
+TEXT VAR record ;
+
+PROC init log :
+
+ time := clock (1) ;
+ paging wait := clock (2) ;
+ paging busy := clock (3) ;
+ fore cpu := clock (4) ;
+ back cpu := clock (5) ;
+ system cpu := clock (6) ;
+ next snapshot time := time + snapshot interval
+
+ENDPROC init log ;
+
+PROC log (INT CONST active terminals, active background) :
+
+ new snapshot time if was clock reset ;
+ IF clock (1) >= next snapshot time
+ THEN save values ;
+ get new values ;
+ create stat record ;
+ put log (record) ;
+ define next snapshot time
+ FI .
+
+new snapshot time if was clock reset :
+ IF clock (1) < next snapshot time - snapshot interval
+ THEN next snapshot time := clock (1)
+ FI .
+
+save values :
+ time x := time ;
+ paging wait x := paging wait ;
+ paging busy x := paging busy ;
+ fore cpu x := fore cpu ;
+ back cpu x := back cpu ;
+ system cpu x := system cpu .
+
+get new values :
+ time := clock (1) ;
+ paging wait := clock (2) ;
+ paging busy := clock (3) ;
+ fore cpu := clock (4) ;
+ back cpu := clock (5) ;
+ system cpu := clock (6) ;
+ storage (storage max, used) .
+
+create stat record :
+ record := text (used, 5) ;
+ record CAT text (active terminals,3) ;
+ record CAT text (active background,3) ;
+ delta t := (time - time x) ;
+ percent (paging wait, paging wait x) ;
+ percent (paging busy, paging busy x) ;
+ percent (fore cpu, fore cpu x) ;
+ percent (back cpu, back cpu x) ;
+ percent (system cpu, system cpu x) ;
+ percent (last, 0.0) ;
+ percent (nutz, 0.0) .
+
+last : paging wait + paging busy + fore cpu + back cpu + system cpu
+ - paging waitx - paging busyx - fore cpux - back cpux - system cpux .
+
+nutz : time - paging wait - system cpu
+ - timex + paging waitx + system cpux .
+
+define next snapshot time :
+ next snapshot time := time + snapshot interval .
+
+ENDPROC log ;
+
+PROC percent (REAL CONST neu, alt ) :
+
+ record CAT text ( (neu-alt) / delta t * 100.0, 6,1) + "%"
+
+ENDPROC percent ;
+
+ENDPACKET eumelmeter ;
+
+INT VAR active terminals , active background ;
+
+task password ("-") ;
+break ;
+command dialogue (FALSE) ;
+forget ("eumelmeter") ;
+init log ;
+REP
+ pause (6000) ;
+ count active processes (active terminals, active background) ;
+ log (active terminals, active background)
+PER ;
+
+PROC count active processes (INT VAR active terminals, active background) :
+
+ active terminals := 0 ;
+ active background := 0 ;
+ TASK VAR process := myself ;
+ REP
+ next active (process) ;
+ IF user process
+ THEN IF process at terminal
+ THEN active terminals INCR 1
+ ELSE active background INCR 1
+ FI
+ FI
+ UNTIL process = myself PER .
+
+user process : NOT (process < supervisor) .
+
+process at terminal : channel (process) >= 0 .
+
+ENDPROC count active processes ;
+
diff --git a/system/std.zusatz/1.8.7/src/font convertor 9 b/system/std.zusatz/1.8.7/src/font convertor 9
new file mode 100644
index 0000000..a5d0ea7
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/font convertor 9
@@ -0,0 +1,1095 @@
+PACKET font convertor (* Autor : Rudolf Ruland *)
+ (* Stand : 29.03.88 *)
+ DEFINES create font table ,
+ add fonts,
+ create font file :
+
+(* >>> ***************************************************************** <<< *)
+
+INT CONST int length := length of one int,
+ highest bit := int length * 8 - 1;
+
+. length of one int :
+ INT VAR int counter := 0, int value := max int;
+ REP int counter INCR 1;
+ int value := int value DIV 256;
+ UNTIL int value = 0 PER;
+ int counter
+.;
+
+(* >>> ***************************************************************** <<< *)
+
+LET t tag = 1,
+ t bold = 2,
+ t number = 3,
+ t text = 4,
+ t operator = 5,
+ t delimiter = 6,
+ t end of file = 7,
+
+ nil modus = 0,
+ font table modus = 1,
+ font modus = 2,
+ extension modus = 3,
+
+ x unit = 1,
+ y unit = 2,
+ on string = 3,
+ off string = 4,
+ indentation pitch = 5,
+ font lead = 6,
+ font height = 7,
+ font depth = 8,
+ larger font = 9,
+ smaller font = 10,
+ font string = 11,
+ y off sets = 12,
+ bold off set = 13;
+
+THESAURUS VAR names, english identification := empty thesaurus,
+ german identification := empty thesaurus;
+
+insert (english identification, "xunit");
+insert (english identification, "yunit");
+insert (english identification, "onstring");
+insert (english identification, "offstring");
+insert (english identification, "indentationpitch");
+insert (english identification, "fontlead");
+insert (english identification, "fontheight");
+insert (english identification, "fontdepth");
+insert (english identification, "nextlargerfont");
+insert (english identification, "nextsmallerfont");
+insert (english identification, "fontstring");
+insert (english identification, "yoffsets");
+insert (english identification, "boldoffset");
+
+insert (german identification, "xeinheit");
+insert (german identification, "yeinheit");
+insert (german identification, "onsequenz");
+insert (german identification, "offsequenz");
+insert (german identification, "einrueckbreite");
+insert (german identification, "durchschuss");
+insert (german identification, "fonthoehe");
+insert (german identification, "fonttiefe");
+insert (german identification, "groessererfont");
+insert (german identification, "kleinererfont");
+insert (german identification, "fontsequenz");
+insert (german identification, "yverschiebungen");
+insert (german identification, "boldverschiebung");
+
+INT VAR modus, last modus, symbol type, int symbol, pitch,
+ identification nr, link nr, extension code 1,
+ char code 1, char code, char pos, vorzeichen,
+ replacements length, index;
+TEXT VAR symbol, font table name, replacement, char, buffer, z;
+BOOL VAR english;
+FILE VAR file, font file;
+
+(*****************************************************************)
+
+LET max fonts = 50,
+ max extensions = 120,
+ font table type = 3009,
+
+ FONTTABLE = STRUCT (
+
+ THESAURUS font names,
+
+ TEXT replacements, font name links,
+ extension chars, extension indexes,
+
+ ROW 4 TEXT on strings, off strings,
+
+ REAL x unit, y unit,
+
+ ROW 256 INT replacements table,
+
+ INT last font, last extension,
+
+ ROW max fonts STRUCT (
+ TEXT font string, font name indexes, replacements,
+ extension chars, extension indexes, y offsets,
+ ROW 256 INT pitch table, replacements table,
+ INT indentation pitch, font lead, font height, font depth,
+ next larger font, next smaller font, bold offset ) fonts ,
+
+ ROW max extensions STRUCT (
+ TEXT replacements,
+ ROW 256 INT pitch table, replacements table,
+ INT std pitch ) extensions ,
+
+ );
+
+BOUND FONTTABLE VAR font table;
+
+DATASPACE VAR ds;
+
+INT VAR font nr, extension nr;
+
+. font : font table. fonts (font nr)
+. extension : font table. extensions (extension nr)
+. line nr : line no (file) - 1
+.;
+
+(*****************************************************************)
+
+
+PROC create font table :
+
+ create font table (last param)
+
+END PROC create font table;
+
+
+PROC create font table (TEXT CONST font file name) :
+
+file := sequential file (input, font file name);
+disable stop;
+ds := nilspace;
+modus := nil modus;
+load;
+IF is error THEN error (errormessage) FI;
+forget (ds);
+
+END PROC create font table;
+
+
+PROC add fonts (TEXT CONST font tab name, font file name) :
+
+file := sequential file (input, font file name);
+font table name := font tab name;
+change all (font table name, " ", "");
+IF NOT exists (font table name) COR type (old (font table name)) <> font table type
+ THEN errorstop ("Fonttabelle """ + font table name + """ gibt es nicht")
+FI;
+disable stop;
+ds := old (font table name);
+fonttable := ds;
+modus := font modus;
+font nr := fonttable. last font;
+extension nr := fonttable. last extension;
+load;
+IF is error THEN error (errormessage) FI;
+forget (ds);
+
+END PROC add fonts;
+
+
+PROC load :
+
+enable stop;
+initialize loading;
+REP get kennung;
+ get identification;
+ get char specifications;
+UNTIL symbol type >= t end of file PER;
+font table found;
+
+. initialize loading :
+ scan (file);
+ get next symbol;
+
+. font table found :
+ IF font nr = 0
+ THEN errorstop ("Fonts zur Fonttabelle """
+ + font table name + """ fehlen");
+ ELSE font table. last font := font nr;
+ font table. last extension := extension nr;
+ forget (font table name, quiet);
+ copy (ds, font table name);
+ type (old (font table name), font table type);
+ forget (ds); ds := nilspace;
+ FI;
+
+. get next symbol :
+ next symbol (file, symbol, symbol type);
+
+. get semicolon :
+ get next symbol;
+ IF symbol <> ";" OR symbol type <> t delimiter
+ THEN errorstop ("';' erwartet") FI;
+
+.
+ get kennung :
+ cout (line nr);
+ IF symbol type <> t bold
+ THEN errorstop ("Kennung erwartet") FI;
+ IF symbol = "FONTTABLE" OR symbol = "FONTTABELLE"
+ THEN initialize font table;
+ get font table name;
+ ELIF symbol = "FONT"
+ THEN initialize font;
+ get font names;
+ ELIF symbol = "EXTENSION" OR symbol = "ERWEITERUNG"
+ THEN get extension char;
+ initialize extension;
+ ELIF modus = nil modus
+ THEN errorstop ("Kennung 'FONTTABLE' oder 'FONTTABELLE' zu Beginn der Datei erwartet")
+ ELSE errorstop ("unzulaessige Kennung")
+ FI;
+
+ . initialize font table :
+ IF modus <> nil modus THEN font table found FI;
+ modus := font table modus;
+ font nr := 0;
+ extension nr := 0;
+ font table := ds;
+ font table. font names := empty thesaurus;
+ font table. replacements := "";
+ font table. font name links := "";
+ font table. extension chars := "";
+ font table. extension indexes := "";
+ font table. x unit := 10.0/2.54;
+ font table. y unit := 6.0/2.54;
+ font table. replacements table := 0;
+ FOR index FROM 1 UPTO 4
+ REP font table. on strings (index) := "";
+ font table. off strings (index) := "";
+ PER;
+
+ . get font table name :
+ get name list;
+ symbol type := t text;
+ symbol := name (names, 1);
+ IF exists (symbol)
+ THEN forget (symbol);
+ IF exists (symbol)
+ THEN errorstop ("Fonttabelle existiert schon") FI;
+ FI;
+ font table name := symbol;
+
+ . initialize font :
+ IF font nr = max fonts
+ THEN errorstop ("zu viele Fonts") FI;
+ font nr INCR 1;
+ modus := font modus;
+ replacements length := LENGTH font table. replacements;
+ font. font string := "";
+ font. font name indexes := "";
+ font. replacements := "";
+ font. extension chars := "";
+ font. extension indexes := "";
+ font. y offsets := int length * ""0"";
+ font. indentation pitch := int (font table. x unit * 2.54 / 10.0);
+ font. font lead := 0;
+ font. font height := int (font table. y unit * 2.54 / 6.0);
+ font. font depth := 0;
+ font. next larger font := 0;
+ font. next smaller font := 0;
+ font. bold offset := 0;
+ font. pitch table := font. indentation pitch;
+ font. replacements table := font table. replacements table;
+ FOR index FROM 1 UPTO LENGTH font table. extension chars
+ REP font. replacements table
+ ( code (font table. extension chars SUB index) + 1 ) := maxint;
+ PER;
+
+ . get font names :
+ get name list;
+ index := 0;
+ symbol type := t text;
+ WHILE next font name
+ REP link nr := link (font table. font names, symbol);
+ IF link nr = 0
+ THEN insert (font table. font names, symbol, link nr);
+ font table. font name links CAT font nr;
+ ELIF (font table. font name links ISUB link nr) = 0
+ THEN replace (font table. font name links, link nr, font nr);
+ ELSE errorstop ("Font existiert in Fonttabelle """
+ + font table name + """ schon")
+ FI;
+ font. font name indexes CAT link nr;
+ PER;
+
+ . next font name :
+ get (names, symbol, index);
+ symbol <> ""
+
+ . get extension char :
+ IF NOT two bytes
+ THEN errorstop ("Erweiterungen nur im zwei-Byte-Modus erlaubt") FI;
+ get name list;
+ symbol type := t text;
+ symbol := name (names, 1);
+ IF LENGTH symbol <> 1
+ THEN errorstop ("nur ein Zeichen bei Erweiterung erlaubt") FI;
+ extension code 1 := code (symbol) + 1;
+ IF NOT is kanji esc (symbol)
+ THEN errorstop ("Kanji-ESC-Zeichen erwartet") FI;
+
+ . initialize extension :
+ IF extension nr = max extensions
+ THEN errorstop ("zu viele Erweiterungen") FI;
+ extension nr INCR 1;
+ IF modus <> extension modus THEN last modus := modus FI;
+ modus := extension modus;
+ IF last modus = font table modus
+ THEN initalize font table extension
+ ELSE initalize font extension
+ FI;
+
+ . initalize font table extension :
+ IF pos (font table. extension chars, symbol) <> 0
+ THEN errorstop ("Erweiterung wurde schon definiert") FI;
+ extension. replacements := "";
+ extension. std pitch := 0;
+ extension. pitch table := 0;
+ extension. replacements table := 0;
+ font table. extension chars CAT symbol;
+ font table. extension indexes CAT extension nr;
+ font table. replacements table (extension code 1) := max int;
+ replacements length := 0;
+
+ . initalize font extension :
+ IF pos (font. extension chars, symbol) <> 0
+ THEN errorstop ("Erweiterung wurde schon definiert") FI;
+ extension. replacements := "";
+ extension. std pitch := font. pitch table (extension code 1) XOR (-maxint-1);
+ extension. pitch table := extension. std pitch;
+ font. extension chars CAT symbol;
+ font. extension indexes CAT extension nr;
+ char pos := pos (font table. extension chars, symbol);
+ IF char pos <> 0
+ THEN index := font table. extension indexes ISUB char pos;
+ extension. replacements table :=
+ font table. extensions (index). replacements table;
+ replacements length :=
+ LENGTH font table. extensions (index). replacements;
+ font. replacements table (extension code 1) := max int;
+ ELSE extension. replacements table := 0;
+ replacements length := 0;
+ FI;
+
+.
+ get identification :
+ WHILE identification found
+ REP cout (line nr);
+ determine identification link nr;
+ select identification;
+ PER;
+
+ . identification found :
+ get next symbol;
+ symbol type = t tag
+
+ . determine identification link nr :
+ identification nr := link (english identification, symbol);
+ english := TRUE;
+ IF identification nr = 0
+ THEN identification nr := link (german identification, symbol);
+ english := FALSE;
+ IF identification nr = 0
+ THEN errorstop ("unzulaesige Identifikation") FI;
+ FI;
+
+ . select identification :
+ get next symbol;
+ IF symbol <> "=" OR symbol type <> t operator
+ THEN errorstop ("'=' nach Identifikation fehlt") FI;
+ get next symbol;
+ SELECT identification nr OF
+ CASE x unit : x unit found
+ CASE y unit : y unit found
+ CASE on string : on string found
+ CASE off string : off string found
+ CASE indentation pitch : indentation pitch found
+ CASE font lead : font lead found
+ CASE font height : font height found
+ CASE font depth : font depth found
+ CASE larger font : larger font found
+ CASE smaller font : smaller font found
+ CASE font string : font string found
+ CASE y offsets : y offsets found
+ CASE bold offset : bold offset found
+ END SELECT;
+
+ . x unit found :
+ check modus (font table modus);
+ font table. x unit := real (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("REAL-Denoter nach 'x unit' erwartet")
+ ELSE errorstop ("REAL-Denoter nach 'x einheit' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+ . y unit found :
+ check modus (font table modus);
+ font table. y unit := real (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("REAL-Denoter nach 'y unit' erwartet")
+ ELSE errorstop ("REAL-Denoter nach 'y einheit' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+ . on string found :
+ check modus (font table modus);
+ FOR index FROM 1 UPTO 4
+ REP IF symbol type <> t text
+ THEN IF english
+ THEN errorstop ("TEXT-Denoter nach 'on string' erwartet")
+ ELSE errorstop ("TEXT-Denoter nach 'on sequenz' erwartet")
+ FI;
+ FI;
+ font table. on strings (index) := symbol;
+ get next symbol;
+ IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter
+ THEN errorstop ("',' oder ';' in Liste erwartet") FI;
+ IF symbol = ";" THEN LEAVE on string found FI;
+ IF index = 4 THEN errorstop ("';' erwartet") FI;
+ get next symbol;
+ PER;
+
+ . off string found :
+ check modus (font table modus);
+ FOR index FROM 1 UPTO 4
+ REP IF symbol type <> t text
+ THEN IF english
+ THEN errorstop ("TEXT-Denoter nach 'off string' erwartet")
+ ELSE errorstop ("TEXT-Denoter nach 'off sequenz' erwartet")
+ FI;
+ FI;
+ font table. off strings (index) := symbol;
+ get next symbol;
+ IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter
+ THEN errorstop ("',' oder ';' in Liste erwartet") FI;
+ IF symbol = ";" THEN LEAVE off string found FI;
+ IF index = 4 THEN errorstop ("';' erwartet") FI;
+ get next symbol;
+ PER;
+
+ . indentation pitch found :
+ check modus (font modus);
+ font. indentation pitch := int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'indentation pitch' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'einrueckbreite' erwartet")
+ FI;
+ FI;
+ font. pitch table := font. indentation pitch;
+ get semicolon;
+
+ . font lead found :
+ check modus (font modus);
+ font. font lead := int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'font lead' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'durchschuss' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+ . font height found :
+ check modus (font modus);
+ font. font height := int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'font height' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'fonthoehe' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+ . font depth found :
+ check modus (font modus);
+ font. font depth := int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'font depth' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'fonttiefe' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+ . larger font found :
+ check modus (font modus);
+ IF symbol type <> t text
+ THEN IF english
+ THEN errorstop ("TEXT-Denoter nach 'next larger font' erwartet")
+ ELSE errorstop ("TEXT-Denoter nach 'groesserer font' erwartet")
+ FI;
+ FI;
+ determine link nr;
+ font. next larger font := link nr;
+ get semicolon;
+
+ . smaller font found :
+ check modus (font modus);
+ IF symbol type <> t text
+ THEN IF english
+ THEN errorstop ("TEXT-Denoter nach 'next smaller font' erwartet")
+ ELSE errorstop ("TEXT-Denoter nach 'kleinerer font' erwartet")
+ FI;
+ FI;
+ determine link nr;
+ font. next smaller font := link nr;
+ get semicolon;
+
+ . determine link nr :
+ change all (symbol, " ", "");
+ IF symbol = ""
+ THEN link nr := 0
+ ELSE link nr := link (font table. font names, symbol);
+ IF link nr = 0
+ THEN insert (font table. font names, symbol, link nr);
+ font table. font name links CAT 0;
+ FI;
+ FI;
+
+ . font string found :
+ check modus (font modus);
+ IF symbol type <> t text
+ THEN IF english
+ THEN errorstop ("TEXT-Denoter nach 'font string' erwartet")
+ ELSE errorstop ("TEXT-Denoter nach 'fontsequenz' erwartet")
+ FI;
+ FI;
+ font. font string := symbol;
+ get semicolon;
+
+ . y offsets found :
+ check modus (font modus);
+ font. y offsets := "";
+ REP IF symbol = "-" AND symbol type = t operator
+ THEN vorzeichen := -1;
+ get next symbol;
+ ELSE vorzeichen := 1;
+ FI;
+ int symbol := vorzeichen * int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'y offsets' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'y verschiebungen' erwartet")
+ FI;
+ FI;
+ font. y offsets CAT int symbol;
+ get next symbol;
+ IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter
+ THEN errorstop ("',' oder ';' in Liste erwartet") FI;
+ IF symbol = ";" THEN LEAVE y offsets found FI;
+ get next symbol;
+ PER;
+
+ . bold offset found :
+ check modus (font modus);
+ IF symbol = "-" AND symbol type = t operator
+ THEN vorzeichen := -1;
+ get next symbol;
+ ELSE vorzeichen := 1;
+ FI;
+ font. bold offset := vorzeichen * int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'bold offset' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'bold verschiebungen' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+.
+ get char specifications :
+ WHILE char found
+ REP cout (line nr);
+ char specification;
+ get next symbol;
+ PER;
+
+ . char found :
+ symbol type = t text
+
+ . char specification :
+ IF LENGTH symbol <> 1
+ THEN errorstop ("nur ein Zeichen bei Zeichenangabe erlaubt") FI;
+ char := symbol;
+ char code 1 := code (char) + 1;
+ look for specification;
+ look for specification;
+ get semicolon;
+
+ . look for specification :
+ get next symbol;
+ IF symbol = ";" AND symbol type = t delimiter
+ THEN LEAVE char specification
+ ELIF symbol = "," AND symbol type = t delimiter
+ THEN get specification
+ ELSE errorstop ("',' oder ';' bei Zeichenspezifikation erwartet")
+ FI;
+
+ . get specification :
+ get next symbol;
+ IF symbol type = t number
+ THEN pitch specification;
+ ELIF symbol type = t text
+ THEN replacement specification
+ ELSE errorstop ("unzulaessiger Wert bei Zeichenspezifikation")
+ FI;
+
+ . pitch specification :
+ int symbol := int (symbol);
+ IF NOT last conversion ok
+ THEN errorstop ("INT-Denoter bei Breitenangabe erwartet") FI;
+ IF modus = font modus
+ THEN font. pitch table (char code 1) := int symbol;
+ IF is kanji esc (char)
+ THEN set bit (font. pitch table (char code 1), highest bit) FI;
+ ELIF modus = extension modus
+ THEN IF last modus = font modus AND
+ font. pitch table (extension code 1) <> max int
+ THEN font. pitch table (extension code 1) := max int FI;
+ extension. pitch table (char code 1) := int symbol;
+ FI;
+
+ . replacement specification :
+ IF LENGTH symbol > 255
+ THEN errorstop ("Ersatzdarstellungen duerfen nur 255 Zeichen haben") FI;
+ IF modus = font table modus
+ THEN font table. replacements table (char code 1) :=
+ (LENGTH font table. replacements + 1);
+ font table. replacements CAT code (LENGTH symbol);
+ font table. replacements CAT symbol;
+ IF is kanji esc (char)
+ THEN set bit (font table. replacements table (char code 1), highest bit) FI;
+ ELIF modus = font modus
+ THEN font. replacements table (char code 1) :=
+ (replacements length + LENGTH font. replacements + 1);
+ font. replacements CAT code (LENGTH symbol);
+ font. replacements CAT symbol;
+ IF is kanji esc (char)
+ THEN set bit (font. replacements table (char code 1), highest bit) FI;
+ ELIF modus = extension modus
+ THEN IF last modus = font modus AND
+ font. replacements table (extension code 1) <> max int
+ THEN font. replacements table (extension code 1) := max int FI;
+ extension. replacements table (char code 1) :=
+ (replacements length + LENGTH extension. replacements + 1);
+ extension. replacements CAT code (LENGTH symbol);
+ extension. replacements CAT symbol;
+ FI;
+
+END PROC load;
+
+
+PROC get name list :
+
+ names := empty thesaurus;
+ get next symbol;
+ IF symbol <> ":" OR symbol type <> t delimiter
+ THEN errorstop ("':' nach Kennung erwartet") FI;
+ REP get next symbol;
+ change all (symbol, " ", "");
+ IF symbol type <> t text
+ THEN errorstop ("TEXT-Denoter in Namesliste erwartet") FI;
+ IF symbol = ""
+ THEN errorstop ("'niltext' als Name nicht erlaubt") FI;
+ insert (names, symbol);
+ get next symbol;
+ IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter
+ THEN errorstop ("',' oder ';' in Liste erwartet") FI;
+ UNTIL symbol = ";" PER;
+
+ . get next symbol :
+ next symbol (file, symbol, symbol type);
+
+END PROC get name list;
+
+
+OP := (ROW 256 INT VAR l, INT CONST r) :
+
+INT VAR i;
+IF modus = extension modus OR NOT two bytes
+ THEN FOR i FROM 1 UPTO 256 REP l (i) := r PER;
+ ELSE FOR i FROM 1 UPTO 129 REP l (i) := r PER;
+ FOR i FROM 130 UPTO 160 REP l (i) := r - maxint - 1 PER;
+ FOR i FROM 161 UPTO 224 REP l (i) := r PER;
+ FOR i FROM 225 UPTO 240 REP l (i) := r - maxint - 1 PER;
+ FOR i FROM 241 UPTO 256 REP l (i) := r PER;
+FI;
+
+END OP :=;
+
+
+PROC check modus (INT CONST mod) :
+
+ IF mod <> modus THEN errorstop ("unzulaessige Identifikation") FI;
+
+END PROC check modus;
+
+
+PROC error (TEXT CONST message) :
+
+(*INT CONST l := error line;*)
+ clear error;
+ errorstop ("Zeile " + text (line nr) + " bei " + letztes symbol +
+ " : " + message (* + errorline if neccessary *) );
+
+ . letztes symbol :
+ IF symbol type = t text
+ THEN decode (symbol);
+ """" + symbol + """"
+ ELIF symbol type >= t end of file
+ THEN "EOF"
+ ELSE symbol
+ FI
+(*
+ . errorline if neccessary :
+ IF l = 0
+ THEN ""
+ ELSE " -> " + text (l)
+ FI
+*)
+END PROC error;
+
+
+(*******************************************************************)
+
+
+PROC create font file (TEXT CONST font tab name, font file name) :
+
+enable stop;
+connect font table;
+put font table in font file;
+
+.
+ connect font table :
+ buffer := font tab name;
+ change all (buffer, " ", "");
+ IF NOT exists (buffer) COR type (old (buffer)) <> font table type
+ THEN errorstop ("Fonttabelle """ + buffer + """ gibt es nicht")
+ FI;
+ font table := old (buffer);
+
+.
+ put font table in font file :
+ INT VAR font file nr := 0;
+ enable stop;
+ font file := sequential file (output, font file name);
+ max line length (font file, 16000);
+ check file overflow;
+ z := " ";
+ put font table;
+ FOR font nr FROM 1 UPTO font table. last font REP put font PER;
+
+ . check file overflow :
+ WHILE lines (font file) > 3600
+ REP font file nr INCR 1;
+ font file := sequential file (output, font file name + "." + text (font file nr));
+ max line length (font file, 16000);
+ PER;
+
+. put font table :
+ put z;
+ z CAT "FONTTABLE : """; z CAT buffer; z CAT """;"; put z;
+ z CAT " x unit = "; z CAT text (font table. x unit); z CAT ";"; put z;
+ z CAT " y unit = "; z CAT text (font table. y unit); z CAT ";"; put z;
+ z CAT " on string = """; z cat on strings; z CAT """;"; put z;
+ z CAT " off string = """; z cat off strings; z CAT """;"; put z;
+ put font table replacements;
+ put font table extensions;
+ put z;
+
+ . z cat on strings :
+ FOR index FROM 1 UPTO 4
+ REP buffer := font table. on strings (index);
+ decode (buffer);
+ z CAT buffer;
+ IF index <> 4 THEN z CAT """, """ FI;
+ PER;
+
+ . z cat off strings :
+ FOR index FROM 1 UPTO 4
+ REP buffer := font table. off strings (index);
+ decode (buffer);
+ z CAT buffer;
+ IF index <> 4 THEN z CAT """, """ FI;
+ PER;
+
+ . put font table replacements :
+ put z;
+ FOR char code FROM 0 UPTO 255
+ REP char code 1 := char code + 1;
+ link nr := font table. replacements table (char code 1);
+ reset bit (link nr, highest bit);
+ IF link nr > 0 AND link nr <> maxint
+ THEN z CAT " ";
+ put char code;
+ put font table replacement;
+ put z;
+ FI;
+ PER;
+
+ . put font table replacement :
+ replacement := subtext (font table. replacements, link nr + 1,
+ link nr + code (font table. replacements SUB link nr) );
+ put replacement;
+
+ . put font table extensions :
+ IF font table. extension chars <> ""
+ THEN FOR index FROM 1 UPTO LENGTH font table. extension chars
+ REP put font table extension PER;
+ FI;
+
+ . put font table extension :
+ check file overflow;
+ put z;
+ z CAT " EXTENSION : """"";
+ z CAT text 3 (code (font table. extension chars SUB index));
+ z CAT """"";";
+ put z; put z;
+ replacements length := 0;
+ extension nr := font table. extension indexes ISUB index;
+ FOR char code FROM 0 UPTO 255
+ REP char code 1 := char code + 1;
+ link nr := extension. replacements table (char code 1);
+ IF link nr > 0
+ THEN z CAT " ";
+ put char code;
+ put extension replacement;
+ put z;
+ FI;
+ PER;
+
+. put font :
+ check file overflow;
+ put z;
+ z CAT " FONT : "; z cat font names; z CAT ";"; put z;
+ z CAT " indentation pitch = ";
+ z CAT text(font. indentation pitch);
+ z CAT ";"; put z;
+ IF font. font lead <> 0
+ THEN z CAT " font lead = ";
+ z CAT text(font. font lead);
+ z CAT ";"; put z;
+ FI;
+ z CAT " font height = ";
+ z CAT text(font. font height);
+ z CAT ";"; put z;
+ IF font. font depth <> 0
+ THEN z CAT " font depth = ";
+ z CAT text(font. font depth);
+ z CAT ";"; put z;
+ FI;
+ IF next larger <> ""
+ THEN z CAT " next larger font = """;
+ z CAT next larger;
+ z CAT """;"; put z;
+ FI;
+ IF next smaller <> ""
+ THEN z CAT " next smaller font = """;
+ z CAT next smaller;
+ z CAT """;"; put z;
+ FI;
+ IF font. font string <> ""
+ THEN z CAT " font string = """;
+ z CAT font string;
+ z CAT """;"; put z;
+ FI;
+ IF (font. y offsets ISUB 1) <> 0 OR LENGTH font. y offsets > int length
+ THEN z CAT " y offsets = ";
+ z cat y offsets;
+ z CAT ";"; put z;
+ FI;
+ IF font. bold offset <> 0
+ THEN z CAT " bold offset = ";
+ z CAT text(font. bold offset);
+ z CAT ";"; put z;
+ FI;
+ put font pitches and replacements;
+ put font extensions;
+
+ . next larger : name (font table. font names, font. next larger font)
+ . next smaller : name (font table. font names, font. next smaller font)
+ . font string : buffer := font. font string; decode (buffer); buffer
+
+ . z cat font names :
+ z CAT """";
+ z CAT name (font table. font names, font. font name indexes ISUB 1);
+ z CAT """";
+ FOR index FROM 2 UPTO LENGTH font. font name indexes DIV int length
+ REP z CAT ", """;
+ z CAT name (font table. font names, font. font name indexes ISUB index);
+ z CAT """";
+ PER;
+
+ . z cat y offsets :
+ z CAT text (font. y offsets ISUB 1);
+ FOR index FROM 2 UPTO LENGTH font. y offsets DIV int length
+ REP z CAT ", ";
+ z CAT text (font. y offsets ISUB index);
+ PER;
+
+ . put font pitches and replacements :
+ BOOL VAR ausgabe := FALSE;
+ replacements length := LENGTH font table. replacements;
+ put z;
+ z CAT " ";
+ FOR char code FROM 0 UPTO 255
+ REP char code 1 := char code + 1;
+ pitch := font. pitch table (char code 1);
+ reset bit (pitch, highest bit);
+ link nr := font. replacements table (char code 1);
+ reset bit (link nr, highest bit);
+ IF (pitch <> font. indentation pitch) OR
+ (link nr > replacements length AND link nr <> maxint)
+ THEN put font char pitch and replacement;
+ IF ausgabe
+ THEN put z;
+ ausgabe := FALSE;
+ ELSE ausgabe := TRUE;
+ FI;
+ z CAT " ";
+ FI;
+ PER;
+ IF ausgabe THEN put z ELSE z := " " FI;
+
+ . put font char pitch and replacement :
+ put char code;
+ put font char pitch;
+ IF link nr > replacements length AND link nr <> maxint
+ THEN put font replacement;
+ IF NOT ausgabe THEN z CAT (6 - LENGTH replacement) * " " FI;
+ ELIF ausgabe
+ THEN z CAT ";"
+ ELSE z CAT "; ";
+ FI;
+
+ . put font char pitch :
+ IF pitch = max int
+ THEN char pos := pos (font. extension chars, code (char code));
+ IF char pos <> 0
+ THEN pitch := font table. extensions
+ (font. extension indexes ISUB char pos). std pitch
+ FI;
+ FI;
+ put char pitch;
+
+ . put font replacement :
+ link nr DECR replacements length;
+ replacement := subtext (font. replacements, link nr + 1,
+ link nr + code (font. replacements SUB link nr) );
+ put replacement;
+
+ . put font extensions :
+ IF font. extension chars <> ""
+ THEN FOR index FROM 1 UPTO LENGTH font. extension chars
+ REP put font extension PER;
+ FI;
+
+ . put font extension :
+ check file overflow;
+ put z;
+ z CAT " EXTENSION : """"";
+ z CAT text 3 (code (font. extension chars SUB index));
+ z CAT """"";";
+ put z; put z; z CAT " ";
+ detemine replacements length;
+ extension nr := font. extension indexes ISUB index;
+ ausgabe := FALSE;
+ FOR char code FROM 0 UPTO 255
+ REP char code 1 := char code + 1;
+ pitch := extension. pitch table (char code 1);
+ link nr := extension. replacements table (char code 1);
+ IF pitch <> extension. std pitch OR link nr > replacements length
+ THEN put extension char pitch and replacement;
+ IF ausgabe
+ THEN put z;
+ ausgabe := FALSE;
+ ELSE ausgabe := TRUE;
+ FI;
+ z CAT " ";
+ FI;
+ PER;
+ IF ausgabe THEN put z ELSE z := " " FI;
+
+ . detemine replacements length :
+ char pos := pos (font table. extension chars,
+ font. extension chars SUB index);
+ IF char pos <> 0
+ THEN replacements length := LENGTH font table. extensions
+ (font table. extension indexes ISUB char pos). replacements;
+ ELSE replacements length := 0;
+ FI;
+
+ . put extension char pitch and replacement :
+ put char code;
+ put char pitch;
+ IF link nr > replacements length
+ THEN put extension replacement;
+ IF NOT ausgabe THEN z CAT (6 - LENGTH replacement) * " " FI;
+ ELIF ausgabe
+ THEN z CAT ";"
+ ELSE z CAT "; ";
+ FI;
+
+. put extension replacement :
+ link nr DECR replacements length;
+ replacement := subtext (extension. replacements, link nr + 1,
+ link nr + code (extension. replacements SUB link nr) );
+ put replacement;
+
+. put char code :
+ IF (char code >= 32 AND char code <= 122) OR
+ (char code >= 214 AND char code <= 223) OR
+ char code = 124 OR char code = 126 OR char code = 251
+ THEN z CAT "(* ";
+ z CAT code (char code);
+ z CAT " *) """"";
+ ELSE z CAT " """"";
+ FI;
+ z CAT text 3 (char code);
+ z CAT """""";
+
+. put char pitch :
+ z CAT ",";
+ z CAT text (pitch, 5);
+
+. put replacement :
+ decode (replacement);
+ z CAT ", """;
+ z CAT replacement;
+ z CAT """;"
+
+END PROC create font file;
+
+
+PROC put z :
+
+ putline (font file, z);
+ cout (lines (font file));
+ z := " ";
+
+END PROC put z;
+
+
+PROC decode (TEXT VAR string) :
+
+ INT VAR p;
+ change all (string, """", """""");
+ p := pos (string, ""0"", ""31"", 1);
+ WHILE p <> 0
+ REP change (string, p, p, """" + text (code(string SUB p)) + """");
+ p := pos (string, ""0"", ""31"", p);
+ PER;
+ p := pos (string, ""127"", ""255"", 1);
+ WHILE p <> 0
+ REP change (string, p, p, """" + text (code(string SUB p)) + """");
+ p := pos (string, ""127"", ""255"", p);
+ PER;
+
+END PROC decode;
+
+
+TEXT PROC text 3 (INT CONST value) :
+
+ buffer := text (value, 3);
+ change all (buffer, " ", "0");
+ buffer
+
+END PROC text 3;
+
+END PACKET font convertor;
+
diff --git a/system/std.zusatz/1.8.7/src/free channel b/system/std.zusatz/1.8.7/src/free channel
new file mode 100644
index 0000000..3814f9d
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/free channel
@@ -0,0 +1,430 @@
+PACKET free channel DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 10.06.86 *)
+ FCHANNEL ,
+ := ,
+ free channel ,
+ open ,
+ close ,
+ out ,
+ in ,
+ dialogue ,
+ save ,
+ fetch :
+
+
+
+LET ack = 0 ,
+ nak = 1 ,
+ error nak = 2 ,
+ empty message code = 256 ,
+ long message code = 257 ,
+ file send code = 1024 ,
+ file receive code = 2048 ,
+ open code = 1000 ,
+ close code = 1001 ,
+
+ file type = 1003 ;
+
+INT CONST task not existing := - 1 ;
+
+
+TYPE FCHANNEL = STRUCT (TASK server, TEXT input buffer, server name) ;
+
+INT VAR message code , response code ;
+TASK VAR partner ;
+DATASPACE VAR ds ;
+
+BOUND TEXT VAR msg ;
+TEXT VAR response, char, esc char , record ;
+
+FILE VAR file ;
+
+
+OP := (FCHANNEL VAR dest, FCHANNEL CONST source) :
+
+ dest.server := source.server ;
+ dest.input buffer := "" ;
+ dest.server name := source.server name ;
+ open (dest)
+
+ENDOP := ;
+
+FCHANNEL PROC free channel (TEXT CONST channel name) :
+
+ FCHANNEL:(niltask,"", channel name)
+
+ENDPROC free channel ;
+
+PROC open (FCHANNEL VAR channel) :
+
+ INT VAR receipt ;
+
+ initialize message dataspace ;
+ send open code ;
+ IF receipt <> ack
+ THEN errorstop ("channel not free")
+ FI .
+
+initialize message dataspace :
+ forget (ds) ;
+ ds := nilspace .
+
+send open code :
+ ping pong (channel.server, open code, ds, receipt) ;
+ IF receipt = task not existing
+ THEN channel.server := task (channel.server name) ;
+ ping pong (channel.server, open code, ds, receipt)
+ FI .
+
+ENDPROC open ;
+
+PROC close (FCHANNEL VAR channel) :
+
+ forget (ds) ;
+ ds := nilspace ;
+ call (channel.server, close code, ds, response code)
+
+ENDPROC close ;
+
+PROC close (TEXT CONST channel server) :
+
+ forget (ds) ;
+ ds := nilspace ;
+ call (task (channel server), close code, ds, response code)
+
+ENDPROC close ;
+
+
+PROC out (FCHANNEL VAR channel, TEXT CONST message) :
+
+ send message ;
+ get response .
+
+send message :
+ IF message = ""
+ THEN call (channel.server, empty message code, ds, response code)
+ ELSE msg := ds ;
+ CONCR (msg) := message ;
+ call (channel.server, long message code, ds, response code)
+ FI .
+
+get response :
+ IF response code < 0
+ THEN errorstop ("channel not ready")
+ ELIF response code < 256
+ THEN channel.input buffer CAT code (response code)
+ ELIF response code = long message code
+ THEN msg := ds ;
+ channel.input buffer CAT CONCR (msg)
+ FI .
+
+ENDPROC out ;
+
+PROC in (FCHANNEL VAR channel, TEXT VAR response) :
+
+ out (channel, "") ;
+ response := channel.input buffer ;
+ channel.input buffer := ""
+
+ENDPROC in ;
+
+PROC save (FCHANNEL VAR channel, TEXT CONST file name, control chars) :
+
+ prepare ds ;
+ call (channel.server, file send code, ds, response code) ;
+ IF response code = error nak
+ THEN BOUND TEXT VAR error msg := ds ;
+ errorstop (error msg)
+ FI .
+
+prepare ds :
+ forget (ds) ;
+ ds := old (file name, file type) ;
+ FILE VAR f := sequential file (modify, ds) ;
+ headline (f, control chars) .
+
+ENDPROC save ;
+
+PROC fetch (FCHANNEL VAR channel, TEXT CONST file name, control chars) :
+
+ IF NOT exists (file name) COR yes ("""" + file name + """ loeschen")
+ THEN fetch first part ;
+ WHILE more to fetch REP
+ fetch next part
+ PER
+ FI .
+
+fetch first part :
+ INT VAR part := 0 ;
+ receive file (channel, file name, control chars) .
+
+fetch next part :
+ part INCR 1 ;
+ receive file (channel, file name + "." + text (part), control chars) .
+
+more to fetch : response code = file receive code .
+
+ENDPROC fetch ;
+
+PROC receive file (FCHANNEL VAR channel,TEXT CONST file name, control chars):
+
+ prepare ds ;
+ call (channel.server, file receive code, ds, response code);
+ IF response code = error nak
+ THEN BOUND TEXT VAR error msg := ds ;
+ errorstop (error msg)
+ ELSE forget (file name, quiet) ;
+ copy (ds, file name) ;
+ forget (ds) ;
+ ds := nilspace ;
+ FI .
+
+prepare ds :
+ forget (ds) ;
+ ds := nilspace ;
+ BOUND TEXT VAR ctl := ds ;
+ ctl := control chars .
+
+ENDPROC receive file ;
+
+
+PROC dialogue (FCHANNEL CONST channel, TEXT CONST esc) :
+
+ forget (ds) ;
+ ds := nilspace ;
+ partner := channel.server ;
+ esc char := esc ;
+ enable stop ;
+
+ response code := empty message code ;
+ REP
+ get and send message charety ;
+ out response option
+ PER .
+
+get and send message charety :
+ IF response code = empty message code
+ THEN char := incharety (10)
+ ELSE char := incharety
+ FI ;
+ IF char = ""
+ THEN call (partner, empty message code, ds, response code)
+ ELIF char = esc char
+ THEN LEAVE dialogue
+ ELSE call (partner, code (char), ds, response code)
+ FI .
+
+out response option :
+ IF response code < 256
+ THEN out (code (response code))
+ ELIF response code = long message code
+ THEN msg := ds ;
+ out (CONCR (msg))
+ FI .
+
+ENDPROC dialogue ;
+
+PROC free channel (INT CONST nr) :
+
+ INT CONST my channel := nr ;
+ break ;
+ disable stop ;
+ REP
+ wait (ds, message code, partner) ;
+ IF message code = open code
+ THEN connect to my channel ;
+ use channel ;
+ break (quiet)
+ ELIF message code >= 0
+ THEN send (partner, nak, ds)
+ FI
+ PER .
+
+use channel :
+ ping pong (partner, ack, ds, message code) ;
+ WHILE message code <> close code AND message code >= 0 REP
+ IF message code <= long message code THEN dialogue
+ ELIF message code = file receive code THEN receive file
+ ELIF message code = file send code THEN send file
+ ELIF message code = open code THEN ignore open
+ ELSE errorstop ("falsche Sendung")
+ FI
+ UNTIL is error PER ;
+ IF is error
+ THEN send error message
+ ELSE send handshake ack
+ FI .
+
+dialogue :
+ IF message code < 256
+ THEN out (code (message code))
+ ELIF message code = long message code
+ THEN msg := ds ;
+ out (CONCR (msg))
+ FI ;
+ response := incharety (1) ;
+ IF response = ""
+ THEN ping pong (partner, empty message code, ds, message code)
+ ELSE short or long response
+ FI .
+
+short or long response :
+ char := incharety ;
+ IF char = ""
+ THEN short response
+ ELSE long response
+ FI .
+
+short response :
+ ping pong (partner, code (response), ds, message code) .
+
+long response :
+ msg := ds ;
+ response CAT char ;
+ msg := response ;
+ REP
+ cat input (msg, char) ;
+ msg CAT char
+ UNTIL char = "" OR LENGTH msg > 500 PER ;
+ ping pong (partner, long message code, ds, message code) .
+
+connect to my channel :
+ continue (my channel) ;
+ WHILE is error REP
+ clear error ;
+ pause (100) ;
+ continue (my channel)
+ PER .
+
+send handshake ack :
+ send (partner, ack, ds) .
+
+send error message :
+ forget (ds) ;
+ ds := nilspace ;
+ BOUND TEXT VAR error msg := ds ;
+ error msg := error message ;
+ clear error ;
+ send (partner, error nak, ds) .
+
+ignore open :
+ ping pong (partner, ack, ds, message code) .
+
+ENDPROC free channel ;
+
+PROC send file :
+
+ enable stop ;
+ file := sequential file (input,ds) ;
+ get control chars ;
+ skip chars ;
+ REP
+ getline (file, record) ;
+ out (record) ;
+ end of line
+ UNTIL eof (file) PER ;
+ end of transmission ;
+ send ack reply .
+
+get control chars :
+ TEXT CONST
+ control chars := headline (file) ,
+ end of file char := control chars SUB 1 ,
+ end of line char := control chars SUB 2 ,
+ handshake char := control chars SUB 3 .
+
+end of line :
+ out (end of line char) ;
+ IF handshake char <> ""
+ THEN wait for handshake
+ FI .
+
+wait for handshake :
+ REP
+ char := incharety (300) ;
+ IF char = ""
+ THEN errorstop ("timeout")
+ FI
+ UNTIL char = handshake char PER .
+
+end of transmission :
+ skip chars ;
+ out (end of file char) .
+
+skip chars :
+ WHILE incharety (3) <> "" REP PER .
+
+send ack reply :
+ forget (ds) ;
+ ds := nilspace ;
+ ping pong (partner, ack, ds, message code) .
+
+ENDPROC send file ;
+
+PROC receive file :
+
+ enable stop ;
+ get control chars ;
+ open file ;
+ INT VAR line no := 0 ;
+ REP
+ receive line ;
+ IF eof received
+ THEN ping pong (partner, ack, ds, message code) ;
+ LEAVE receive file
+ FI ;
+ putline (file, record) ;
+ line no INCR 1
+ UNTIL near file overflow PER ;
+ ping pong (partner, file receive code, ds, message code) .
+
+get control chars :
+ BOUND TEXT VAR control chars := ds ;
+ TEXT CONST
+ end of file char := control chars SUB 1 ,
+ end of line char := control chars SUB 2 ,
+ handshake char := control chars SUB 3 ,
+ handshake prompt := control chars SUB 4 .
+
+open file :
+ forget (ds) ;
+ ds := nilspace ;
+ file := sequential file (output, ds) .
+
+receive line :
+ record := "" ;
+ REP
+ cat input (record, char) ;
+ IF char = ""
+ THEN wait for char
+ FI ;
+ IF char = handshake prompt THEN out (handshake char)
+ ELIF char = ""9"" THEN expand tabs
+ ELIF char = ""12"" THEN page
+ FI
+ UNTIL char = end of line char OR char = end of file char PER .
+
+wait for char :
+ char := incharety (300) ;
+ IF char = ""
+ THEN errorstop ("timeout")
+ ELIF char >= ""32""
+ THEN record CAT char
+ FI .
+
+expand tabs:
+ record CAT (8-(LENGTH record MOD 8)) * " " .
+
+page:
+ record := "#page# " .
+
+eof received :
+ char = end of file char OR (record SUB LENGTH record ) = end of file char .
+
+near file overflow :
+ line no > 3999 OR (line no > 3800 AND record = "#page# ") .
+
+ENDPROC receive file ;
+
+ENDPACKET free channel ;
+
diff --git a/system/std.zusatz/1.8.7/src/longint b/system/std.zusatz/1.8.7/src/longint
new file mode 100644
index 0000000..e78bb52
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/longint
@@ -0,0 +1,423 @@
+PACKET longint DEFINES LONGINT, (* Autoren: S.Baumann,A.Bentrup *)
+ :=, (* T.Sillke *)
+ <, (* Stand: 17.03.81 *)
+ >,
+ <=,
+ >=,
+ <>,
+ =,
+ -,
+ +,
+ *,
+ **,
+ ABS,
+ abs,
+ DECR,
+ DIV,
+ get,
+ INCR,
+ int,
+ (*last rest,*)
+ longint,
+ max,
+ max longint,
+ min,
+ MOD,
+ put,
+ random,
+ SIGN,
+ sign,
+ text,
+ zero:
+
+TYPE LONGINT = TEXT;
+
+LONGINT VAR result,aleft,aright;
+TEXT VAR ergebnis,x,y,z,h;
+INT VAR v byte,slr,sll;
+INT CONST snull :: code("0"), mtl :: 300 ;
+TEXT CONST negativ :: code(127),max digit :: code(99),null :: code(0),
+ overflow :: "LONGINT overflow",eins :: code(1);
+BOOL VAR vorl,vorr,vleft,vright;
+
+OP := (LONGINT VAR left, LONGINT CONST right) :
+ CONCR(left) := CONCR(right)
+END OP :=;
+
+BOOL OP < (LONGINT CONST left,right) :
+ slr := sign(right)*length(right);
+ sll := sign(left )*length(left );
+ IF slr <> sll THEN
+ IF slr > sll THEN TRUE ELSE FALSE FI
+ ELSE IF slr>0
+ THEN CONCR(left) < CONCR(right)
+ ELSE CONCR(left) > CONCR(right) FI
+ FI
+END OP < ;
+
+BOOL OP > (LONGINT CONST left,right) :
+ slr := sign(right)*length(right);
+ sll := sign(left )*length(left );
+ IF slr <> sll THEN
+ IF slr < sll THEN TRUE ELSE FALSE FI
+ ELSE IF slr>0
+ THEN CONCR(left) > CONCR(right)
+ ELSE CONCR(left) < CONCR(right) FI
+ FI
+END OP > ;
+
+BOOL OP <= (LONGINT CONST left,right) :
+ NOT (left > right)
+END OP <=;
+
+BOOL OP >= (LONGINT CONST left,right) :
+ NOT (left < right)
+END OP >=;
+
+BOOL OP <> (LONGINT CONST left,right) :
+ CONCR (left) <> CONCR (right)
+END OP <>;
+
+BOOL OP = (LONGINT CONST left,right) :
+ CONCR (left) = CONCR (right)
+END OP = ;
+
+LONGINT OP - (LONGINT CONST arg) :
+ SELECT code(CONCR(arg)SUB1) OF
+ CASE 0 : zero
+ CASE 127: LONGINT : (subtext(CONCR(arg),2))
+ OTHERWISE LONGINT : (negativ + CONCR(arg))
+ END SELECT
+END OP -;
+
+LONGINT OP + (LONGINT CONST arg) : arg END OP +;
+
+LONGINT OP - (LONGINT CONST left,right) :
+ IF CONCR(left ) = null THEN LEAVE - WITH -right
+ ELIF CONCR(right) = null THEN LEAVE - WITH left
+ ELIF sign(left) <> sign(right) THEN LEAVE - WITH left + (-right) FI;
+ betrag(left,right);
+ BOOL CONST betrag max :: aleft > aright;
+ IF betrag max
+ THEN result := LONGINT : (CONCR(aleft ) SUB CONCR(aright))
+ ELSE result := LONGINT : (CONCR(aright) SUB CONCR(aleft )) FI;
+ kuerze fuehrende nullen(CONCR(result),null);
+ IF vleft XOR betrag max THEN -result ELSE result FI
+END OP -;
+
+LONGINT OP + (LONGINT CONST left,right) :
+ IF sign(left) <> sign(right) THEN LEAVE + WITH left - (-right) FI;
+ betrag(left,right);
+ IF aleft > aright
+ THEN result := LONGINT : (CONCR(aleft ) ADD CONCR(aright))
+ ELSE result := LONGINT : (CONCR(aright) ADD CONCR(aleft )) FI;
+ IF vleft THEN result ELSE -result FI
+END OP +;
+
+LONGINT OP * (LONGINT CONST left,right) :
+ IF CONCR(left) = null OR CONCR(right) = null THEN LEAVE * WITH zero
+ ELIF length(left) + length(right) > mtl THEN errorstop (overflow) FI;
+ betrag(left,right);
+ IF aleft < aright
+ THEN result := LONGINT : (CONCR(aright) MUL CONCR(aleft ))
+ ELSE result := LONGINT : (CONCR(aleft ) MUL CONCR(aright)) FI;
+ IF length(CONCR(result)) = mtl THEN errorstop(overflow) FI;
+ IF vleft XOR vright THEN -result ELSE result FI
+END OP *;
+
+LONGINT OP ** (LONGINT CONST arg,exp) :
+ IF exp > longint(max int) THEN errorstop (overflow) FI;
+ arg ** int(exp)
+END OP **;
+
+LONGINT OP ** (LONGINT CONST arg,INT CONST exp) :
+ IF exp < 0 THEN errorstop ("LONGINT OP ** : negativ exp")
+ ELIF CONCR(arg)=null AND exp=0 THEN errorstop(text(0 ** 0)) FI;
+ IF exp = 0 THEN one
+ ELIF exp = 1 THEN arg
+ ELIF sign(arg) = -1 AND exp MOD 2 <> 0
+ THEN -LONGINT:(CONCR(abs(arg))EXPexp)
+ ELSE LONGINT:(CONCR(abs(arg))EXPexp) FI
+END OP **;
+
+LONGINT OP ABS (LONGINT CONST arg) : abs(arg) END OP ABS;
+
+LONGINT PROC abs (LONGINT CONST a) :
+ IF (CONCR(a)SUB1)=negativ THEN LONGINT:(subtext(CONCR(a),2)) ELSE a FI
+END PROC abs;
+
+OP DECR (LONGINT VAR result,LONGINT CONST ab) :
+ result := result - ab;
+END OP DECR;
+
+LONGINT OP DIV (LONGINT CONST left,right) :
+ IF CONCR(right) = null THEN error stop("LONGINT OP DIV by zero") FI;
+ betrag(left,right); h := CONCR(aright);
+ y := null + CONCR(aleft ); vorl := vleft;
+ z := null + CONCR(aright); vorr := vright;
+ IF aleft < aright THEN y:=CONCR(aleft); LEAVE DIV WITH zero FI;
+ INT VAR try,i,cr1 :: code(z SUB 2),cr2,cr3,zw;
+ BOOL VAR sh :: length(z) <> 2;
+ IF sh THEN cr3:=code(zSUB3); cr2:=10*cr1+cr3DIV10; cr3:=100*cr1+cr3 FI;
+ CONCR(result) := "";
+ FOR i FROM 0 UPTO length(y)-length(z) REP
+ laufe eine abschaetzung durch;
+ CONCR (result) CAT code(try)
+ PER; kuerze fuehrende nullen(y,null);
+ IF(CONCR(result)SUB1)=nullTHEN CONCR(result):=subtext(CONCR(result),2)FI;
+ IF vleft XOR vright THEN -result ELSE result FI.
+
+ laufe eine abschaetzung durch :
+ zw := 100*code(y SUB i+1) + code(y SUB i+2);
+ IF zw < 3276 AND sh THEN IF zw < 327
+ THEN try := min((100*zw + code(ySUBi+3)) DIV cr3, 99)
+ ELSE try := min(( 10*zw + code(ySUBi+3)DIV10)DIV cr2, 99) FI
+ ELSE try := min( zw DIV cr1, 99) FI;
+ x := z MUL code(try);
+ WHILE x > subtext(y,i+1,i+length(x)) REP
+ try DECR 1; x := x SUB z PER;
+ replace(y,i + 1,subtext(y,i + 1,i + length(x)) SUB x)
+END OP DIV;
+
+PROC get (LONGINT VAR result) :
+ get (ergebnis);
+ result := longint(ergebnis);
+END PROC get;
+
+PROC get (FILE VAR file,LONGINT VAR result) :
+ get(file,ergebnis);
+ result := longint(ergebnis);
+END PROC get;
+
+OP INCR (LONGINT VAR result,LONGINT CONST dazu) :
+ result := result + dazu;
+END OP INCR;
+
+INT PROC int (LONGINT CONST longint) :
+ IF length(longint) > 3
+ THEN max int + 1
+ ELSE ergebnis := (3-length(longint))*null + CONCR(abs(longint));
+ (code(ergebnis SUB 1) * 10000 +
+ code(ergebnis SUB 2) * 100 +
+ code(ergebnis SUB 3)) * sign(longint)
+ FI
+END PROC int;
+
+LONGINT PROC longint (INT CONST int) :
+ CONCR(result) := code( abs(int) DIV 10000) +
+ code((abs(int) MOD 10000) DIV 100) +
+ code( abs(int) MOD 100);
+ kuerze fuehrende nullen (CONCR(result),null);
+ IF int < 1 THEN -result ELSE result FI
+END PROC longint;
+
+LONGINT PROC longint (TEXT CONST text) :
+ INT VAR i;
+ ergebnis := compress(text);
+ BOOL VAR minus :: (ergebnisSUB1) = "-";
+ IF (ergebnisSUB1)="+" OR minus THEN ergebnis:=subtext(ergebnis,2) FI;
+ kuerze fuehrende nullen(ergebnis,"0");
+ kuerze die unzulaessigen zeichen aus ergebnis;
+ schreibe ergebnis im hundertersystem in result;
+ result mit vorzeichen.
+
+ kuerze die unzulaessigen zeichen aus ergebnis :
+ ergebnis := subtext(ergebnis,1,letztes zulaessiges zeichen).
+ letztes zulaessiges zeichen :
+ FOR i FROM 1 UPTO length(ergebnis) REP
+ UNTIL pos("0123456789", ergebnis SUB i) = 0 PER;
+ i - 1.
+ schreibe ergebnis im hundertersystem in result :
+ sll := length(ergebnis);
+ IF sll MOD 2 <> 0 THEN ergebnis := "0"+ergebnis; sll INCR 1 FI;
+ i := 1; CONCR(result) := "";
+ REP schreibe ein zeichen im hundertersystem in result;
+ i INCR 2
+ UNTIL i >= sll PER.
+ schreibe ein zeichen im hundertersystem in result :
+ CONCR(result) CAT code((code(ergebnis SUB i ) - snull) * 10 +
+ code(ergebnis SUB i + 1) - snull).
+ result mit vorzeichen :
+ IF ergebnis="" THEN zero ELIF minus THEN -result ELSE result FI
+END PROC longint;
+
+LONGINT PROC max (LONGINT CONST left,right) :
+ IF left > right THEN left ELSE right FI
+END PROC max;
+
+LONGINT PROC max longint :
+ LONGINT : ((mtl - 1) * max digit)
+END PROC max longint;
+
+LONGINT PROC min (LONGINT CONST left,right) :
+ IF left < right THEN left ELSE right FI
+END PROC min;
+
+LONGINT OP MOD (LONGINT CONST left,right) :
+ IF CONCR(right) = null THEN errorstop("LONGINT OP MOD by zero") FI;
+ result := left DIV right; last rest
+END OP MOD;
+
+PROC put (LONGINT CONST longint) :
+ INT VAR i :: 1,zwei ziffern;
+ IF sign(longint) = -1 THEN out("-"); i:=2 FI;
+ out(text(code(CONCR(longint) SUB i)));
+ FOR i FROM i + 1 UPTO length(CONCR(longint)) REP
+ zwei ziffern := code(CONCR(longint) SUB i);
+ out(code(zwei ziffern DIV 10 + snull));
+ out(code(zwei ziffern MOD 10 + snull));
+ PER;out(" ")
+END PROC put;
+
+PROC put (FILE VAR file,LONGINT CONST longint) :
+ put(file,text(longint));
+END PROC put;
+
+LONGINT PROC random (LONGINT CONST lower bound,upper bound) :
+ INT VAR i; x := CONCR(upper bound - lower bound - one); y := "";
+ FOR i FROM 1 UPTO length(x) REP y CAT code(random(0,99)) PER;
+ upper bound - (LONGINT : (y) MOD LONGINT : (x))
+END PROC random;
+
+INT OP SIGN (LONGINT CONST arg) : sign(arg) END OP SIGN;
+
+INT PROC sign (LONGINT CONST arg) :
+ SELECT code(CONCR(arg) SUB 1) OF
+ CASE 0 : 0
+ CASE 127 : -1
+ OTHERWISE 1
+ END SELECT
+END PROC sign;
+
+TEXT PROC text (LONGINT CONST longint) :
+ INT VAR i::1,zwei ziffern; ergebnis := "";
+ IF sign(longint) = -1 THEN ergebnis := "-"; i:=2 FI;
+ ergebnis CAT text (code (CONCR (longint) SUB i ) ) ;
+ FOR i FROM i+1 UPTO length(CONCR(longint)) REP
+ zwei ziffern := code(CONCR(longint) SUB i);
+ ergebnis CAT code(zwei ziffern DIV 10 + snull);
+ ergebnis CAT code(zwei ziffern MOD 10 + snull)
+ PER; ergebnis
+END PROC text;
+
+TEXT PROC text (LONGINT CONST longint,INT CONST length) :
+ x := text(longint); sll := LENGTH x;
+ IF sll > length THEN length * "*" ELSE (length - sll)*" " + x FI
+END PROC text;
+
+LONGINT PROC last rest :
+ IF y=null THEN LEAVE last rest WITH zero FI;
+ IF vorl XOR vorr THEN y := h SUB y; kuerze fuehrende nullen(y,null);
+ vorl := TRUE FI;
+ IF NOTvorr THEN y:=negativ+y; vorr := TRUE FI; LONGINT:(y)
+END PROC last rest;
+
+LONGINT PROC zero : LONGINT : (null) END PROC zero;
+LONGINT PROC one : LONGINT : (""1"") END PROC one;
+
+
+(* ----------------------- INTERNE HILFSPROZEDUREN ----------------------- *)
+
+TEXT OP ADD (TEXT CONST left,right) :
+ INT VAR carrybit :: 0,i,dif :: length(left) - length(right);
+ ergebnis := left;
+ FOR i FROM length(left) DOWNTO dif + 1 REP
+ replace(ergebnis,i,das result der addition)
+ PER;
+ IF carrybit = 1 THEN addiere den uebertrag FI;
+ ergebnis.
+
+ das result der addition :
+ v byte := (code(left SUB i) + code(right SUB i - dif) + carrybit);
+ IF v byte > 99
+ THEN carrybit := 1; code(v byte - 100)
+ ELSE carrybit := 0; code(v byte)
+ FI.
+ addiere den uebertrag :
+ FOR i FROM i DOWNTO 1
+ WHILE (ergebnis SUB i) >= max digit REP
+ replace(ergebnis,i,null)
+ PER;
+ IF (ergebnis SUB 1) = null OR dif = 0
+ THEN pruefe auf longint overflow
+ ELSE replace(ergebnis,i,code(code(ergebnis SUB i) + 1))
+ FI.
+ pruefe auf longint overflow :
+ IF length(ergebnis) = mtl - 1 THEN errorstop(overflow) FI;
+ ergebnis := eins + ergebnis
+END OP ADD;
+
+PROC betrag (LONGINT CONST a, b) :
+ vleft := (CONCR(a)SUB1)<>negativ; vright := (CONCR(b)SUB1)<>negativ;
+ IF vleft THEN aleft :=a ELSE CONCR(aleft ):=subtext(CONCR(a),2) FI;
+ IF vright THEN aright:=b ELSE CONCR(aright):=subtext(CONCR(b),2) FI
+END PROC betrag;
+
+TEXT OP EXP (TEXT CONST arg,INT CONST exp) :
+ INT VAR zaehler :: exp;
+ x := arg; z := eins;
+ REP IF zaehler MOD 2 = 1 THEN z := z MUL x FI;
+ zaehler := zaehler DIV 2; x := x MUL x
+ UNTIL zaehler = 1 PER;
+ x MUL z
+END OP EXP;
+
+PROC kuerze fuehrende nullen ( TEXT VAR text,TEXT CONST snull) :
+ INT VAR i;
+ text := subtext(text,erste nicht snull).
+
+ erste nicht snull :
+ FOR i FROM 1 UPTO length (text) - 1 REP
+ UNTIL (text SUB i) <> snull PER;
+ i
+END PROC kuerze fuehrende nullen;
+
+INT PROC length (LONGINT CONST a) :
+ IF (CONCR(a)SUB1)=negativ THEN length(CONCR(a))-1 ELSE length(CONCR(a)) FI
+END PROC length;
+
+TEXT OP MUL (TEXT CONST left,right) :
+ INT VAR i,j,carrybit,v,w;
+ ergebnis := (length(left) + length(right) - 1) * null;
+ FOR i FROM length(ergebnis) DOWNTO length(left) REP
+ v := i - length(left); w := length(right) - length(ergebnis) + i;
+ carrybit := 0;
+ FOR j FROM length(left) DOWNTO 1 REP
+ replace(ergebnis,v + j,result der addition)
+ PER;
+ replace(ergebnis,v,code(code(ergebnis SUB v) + carrybit));
+ PER;
+ IF carrybit = 0 THEN ergebnis ELSE code(carrybit) + ergebnis FI.
+
+ result der addition :
+ v byte := code(right SUB w) * code(left SUB j) + carrybit +
+ code(ergebnis SUB v + j);
+ carrybit := v byte DIV 100;
+ code(v byte MOD 100)
+END OP MUL;
+
+TEXT OP SUB (TEXT CONST left,right) :
+ INT VAR carrybit :: 0,i,dif :: length(left) - length(right);
+ ergebnis := left;
+ FOR i FROM length(left) DOWNTO dif + 1 REP
+ replace(ergebnis,i,das result der subtraktion);
+ PER;
+ IF carrybit = 1 THEN subtrahiere den uebertrag FI;
+ ergebnis.
+
+ das result der subtraktion :
+ v byte := (code(left SUB i) - code(right SUB i - dif) - carrybit);
+ IF v byte < 0
+ THEN carrybit := 1;code(v byte + 100)
+ ELSE carrybit := 0;code(v byte)
+ FI.
+ subtrahiere den uebertrag :
+ FOR i FROM i DOWNTO 2
+ WHILE (ergebnis SUB i) = null REP
+ replace(ergebnis,i,max digit)
+ PER;
+ replace(ergebnis,i,code(code(ergebnis SUB i) - 1))
+END OP SUB;
+
+END PACKET longint;
+
diff --git a/system/std.zusatz/1.8.7/src/matrix b/system/std.zusatz/1.8.7/src/matrix
new file mode 100644
index 0000000..d9de9fb
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/matrix
@@ -0,0 +1,482 @@
+PACKET matrix DEFINES MATRIX, matrix, idn, (* Stand : 16.06.86 wk *)
+ :=, sub, (* Autor : H.Indenbirken *)
+ row, column,
+ COLUMNS,
+ ROWS,
+ DET,
+ INV,
+ TRANSP,
+ transp,
+ replace row, replace column,
+ replace element,
+ get, put,
+ =, <>,
+ +, -, * :
+
+TYPE MATRIX = STRUCT (INT rows, columns, VECTOR elems);
+TYPE INITMATRIX = STRUCT (INT rows, columns, REAL value, BOOL idn);
+
+MATRIX VAR a :: idn (1);
+INT VAR i;
+
+(****************************************************************************
+PROC dump (MATRIX CONST m) :
+ put line (text (m.rows) + " Reihen, " + text (m.columns) + " Spalten.");
+ dump (m.elems) .
+
+END PROC dump;
+****************************************************************************)
+
+OP := (MATRIX VAR l, MATRIX CONST r) :
+ CONCR (l) := CONCR (r);
+END OP :=;
+
+OP := (MATRIX VAR l, INITMATRIX CONST r) :
+ l.rows := r.rows;
+ l.columns := r.columns;
+ l.elems := vector (r.rows*r.columns, r.value);
+ IF r.idn
+ THEN idn FI .
+
+idn :
+ INT VAR i;
+ FOR i FROM 1 UPTO r.rows
+ REP replace (l.elems, calc pos (l.columns, i, i), 1.0) PER
+
+END OP :=;
+
+INITMATRIX PROC matrix (INT CONST rows, columns, REAL CONST value) :
+ IF rows <= 0
+ THEN errorstop ("PROC matrix : rows <= 0")
+ ELIF columns <= 0
+ THEN errorstop ("PROC matrix : columns <= 0") FI;
+
+ INITMATRIX : (rows, columns, value, FALSE)
+
+END PROC matrix;
+
+INITMATRIX PROC matrix (INT CONST rows, columns) :
+ matrix (rows, columns, 0.0)
+
+END PROC matrix;
+
+INITMATRIX PROC idn (INT CONST size) :
+ IF size <= 0
+ THEN errorstop ("MATRIX PROC idn : size <= 0") FI;
+
+ INITMATRIX : (size, size, 0.0, TRUE)
+
+END PROC idn;
+
+VECTOR PROC row (MATRIX CONST m, INT CONST i) :
+ VECTOR VAR v :: vector (m.columns);
+ INT VAR j, k :: 1, pos :: (i-1) * m.columns;
+ FOR j FROM pos+1 UPTO pos + m.columns
+ REP replace (v, k, m.elems SUB j);
+ k INCR 1
+ PER;
+ v
+
+END PROC row;
+
+VECTOR PROC column (MATRIX CONST m, INT CONST j) :
+ VECTOR VAR v :: vector (m.rows);
+ INT VAR i, k :: j;
+ FOR i FROM 1 UPTO m.rows
+ REP replace (v, i, m.elems SUB k);
+ k INCR m.columns
+ PER;
+ v
+
+END PROC column;
+
+INT OP COLUMNS (MATRIX CONST m) :
+ m.columns
+
+END OP COLUMNS;
+
+INT OP ROWS (MATRIX CONST m) :
+ m.rows
+
+END OP ROWS;
+
+REAL PROC sub (MATRIX CONST a, INT CONST row, column) :
+ a.elems SUB calc pos (a.columns, row, column)
+
+END PROC sub;
+
+PROC replace row (MATRIX VAR m, INT CONST rowindex, VECTOR CONST rowvalue) :
+ test ("PROC replace row : ", "LENGTH rowvalue", "COLUMNS m",
+ LENGTH rowvalue, m.columns);
+ test ("PROC replace row : row ", rowindex, m.rows);
+
+ INT VAR i, pos :: (rowindex-1) * m.columns;
+ FOR i FROM 1 UPTO m.columns
+ REP replace (m.elems, pos+i, rowvalue SUB i) PER
+
+END PROC replace row;
+
+PROC replace column (MATRIX VAR m, INT CONST columnindex,
+ VECTOR CONST columnvalue) :
+ test ("PROC replace column : ", "LENGTH columnvalue", "ROWS m",
+ LENGTH columnvalue, m.rows);
+ test ("PROC replace column : column ", columnindex, m.columns);
+
+ INT VAR i;
+ FOR i FROM 1 UPTO m.rows
+ REP replace (m.elems, calc pos (m.columns, i, columnindex),
+ columnvalue SUB i) PER
+
+END PROC replace column;
+
+PROC replace element (MATRIX VAR a, INT CONST row, column, REAL CONST x) :
+ test ("PROC replace element : row ", row, a.rows);
+ test ("PROC replace element : column ", column, a.columns);
+ replace (a.elems, calc pos (a.columns, row, column), x)
+
+END PROC replace element;
+
+BOOL OP = (MATRIX CONST l, r) :
+ IF l.rows <> r.rows
+ THEN FALSE
+ ELIF l.columns <> r.columns
+ THEN FALSE
+ ELSE l.elems = r.elems FI
+
+END OP =;
+
+BOOL OP <> (MATRIX CONST l, r) :
+ IF l.rows <> r.rows
+ THEN TRUE
+ ELIF l.columns <> r.columns
+ THEN TRUE
+ ELSE l.elems <> r.elems FI
+
+END OP <>;
+
+INT PROC calc pos (INT CONST columns, z, s) :
+ (z-1) * columns + s
+END PROC calc pos;
+
+MATRIX OP + (MATRIX CONST m) :
+ m
+
+END OP +;
+
+MATRIX OP + (MATRIX CONST l, r) :
+ test ("MATRIX OP + : ", "ROWS l", "ROWS r", l.rows, r.rows);
+ test ("MATRIX OP + : ", "COLUMNS l", "COLUMNS r", l.columns, r.columns);
+
+ a := l;
+ INT VAR i;
+ FOR i FROM 1 UPTO l.rows * l.columns
+ REP replace (a.elems, i, (l.elems SUB i) + (r.elems SUB i))
+ PER;
+ a
+
+END OP +;
+
+MATRIX OP - (MATRIX CONST m) :
+ a := m;
+ INT VAR i;
+ FOR i FROM 1 UPTO m.rows * m.columns
+ REP replace (a.elems, i, -a.elems SUB i)
+ PER;
+ a
+
+END OP -;
+
+MATRIX OP - (MATRIX CONST l, r) :
+ test ("MATRIX OP - : ", "ROWS l", "ROWS r", l.rows, r.rows);
+ test ("MATRIX OP - : ", "COLUMNS l", "COLUMNS r", l.columns, r.columns);
+
+ a := l;
+ INT VAR i;
+ FOR i FROM 1 UPTO l.rows * l.columns
+ REP replace (a.elems, i, (l.elems SUB i) - (r.elems SUB i))
+ PER;
+ a
+
+END OP -;
+
+MATRIX OP * (REAL CONST x, MATRIX CONST m) :
+ m*x
+
+END OP *;
+
+MATRIX OP * (MATRIX CONST m, REAL CONST x) :
+ a := m;
+ INT VAR i;
+ FOR i FROM 1 UPTO m.rows * m.columns
+ REP replace (a.elems, i, x*m.elems SUB i) PER;
+ a
+
+END OP *;
+
+VECTOR OP * (VECTOR CONST v, MATRIX CONST m) :
+ test ("VECTOR OP * : ", "LENGTH v", "ROWS m", LENGTH v, m.rows);
+ VECTOR VAR result :: vector (m.columns); (*wk*)
+ INT VAR i;
+ FOR i FROM 1 UPTO m.columns
+ REP replace (result, i, v * column (m, i)) PER;
+ result .
+
+END OP *;
+
+VECTOR OP * (MATRIX CONST m, VECTOR CONST v) :
+ test ("VECTOR OP * : ", "COLUMNS m", "LENGTH v", COLUMNS m, LENGTH v);
+ VECTOR VAR result :: vector (m.rows); (*wk*)
+ INT VAR i;
+ FOR i FROM 1 UPTO m.rows
+ REP replace (result, i, row (m, i) * v) PER;
+ result .
+
+END OP *;
+
+MATRIX OP * (MATRIX CONST l, r) :
+ test ("MATRIX OP * : ","COLUMNS l","ROWS r", l.columns, r.rows);
+
+ a.rows := l.rows;
+ a.columns := r.columns;
+ a.elems := vector (a.rows*a.columns)
+ INT VAR i, j;
+ FOR i FROM 1 UPTO a.rows
+ REP FOR j FROM 1 UPTO a.columns
+ REP VECTOR VAR rl :: row (l, i), cr :: column (r, j);
+ replace (a.elems, calc pos (a.columns, i, j), rl * cr)
+ PER
+ PER;
+ a .
+
+END OP *;
+
+PROC get (MATRIX VAR a, INT CONST rows, columns) :
+
+ a := matrix (rows,columns);
+ INT VAR i, j;
+ VECTOR VAR v;
+ FOR i FROM 1 UPTO rows
+ REP get (v, columns);
+ store row
+ PER .
+
+store row :
+ FOR j FROM 1 UPTO a.columns
+ REP replace (a.elems, calc pos (a.columns, i, j), v SUB j)
+ PER .
+
+END PROC get;
+
+PROC put (MATRIX CONST a, INT CONST length, fracs) :
+ INT VAR i, j;
+ FOR i FROM 1 UPTO a.rows
+ REP FOR j FROM 1 UPTO a.columns
+ REP put (text (sub (a, i, j), length, fracs)) PER;
+ line (2);
+ PER
+
+END PROC put;
+
+PROC put (MATRIX CONST a) :
+ INT VAR i, j;
+ FOR i FROM 1 UPTO a.rows
+ REP FOR j FROM 1 UPTO a.columns
+ REP TEXT CONST number :: " " + text (sub (a, i, j));
+ put (subtext (number, LENGTH number - 15))
+ PER;
+ line (2);
+ PER
+
+END PROC put;
+
+TEXT VAR error :: "";
+PROC test (TEXT CONST proc, l text, r text, INT CONST left, right) :
+ IF left <> right
+ THEN error := proc;
+ error CAT l text;
+ error CAT " (";
+ error CAT text (left);
+ error CAT ") <> ";
+ error CAT r text;
+ error CAT " (";
+ error CAT text (right);
+ error CAT ")";
+ errorstop (error)
+ FI .
+
+END PROC test;
+
+PROC test (TEXT CONST proc, INT CONST i, n) :
+ IF i < 1
+ THEN error := proc;
+ error CAT "subscript underflow (";
+ error CAT text (i);
+ error CAT ")";
+ errorstop (error)
+ ELIF i > n
+ THEN error := proc;
+ error CAT "subscript overflow (i=";
+ error CAT text (i);
+ error CAT ", max=";
+ IF n <= 0
+ THEN error CAT "undefined"
+ ELSE error CAT text (n) FI;
+ error CAT ")";
+ errorstop (error)
+ FI
+
+END PROC test;
+
+
+MATRIX OP TRANSP (MATRIX CONST m) :
+ MATRIX VAR a :: m;
+ transp (a);
+ a
+
+END OP TRANSP;
+
+PROC transp (MATRIX VAR m) :
+ INT VAR k :: 1, n :: m.rows*m.columns;
+ a := m;
+ FOR i FROM 2 UPTO n
+ REP replace (m.elems, i, a.elems SUB position) PER;
+ a := idn (1);
+ i := m.rows;
+ m.rows := m.columns;
+ m.columns := i .
+
+position :
+ k INCR m.columns;
+ IF k > n
+ THEN k DECR (n-1) FI;
+ k .
+END PROC transp;
+
+MATRIX OP INV (MATRIX CONST m) :
+ a := m;
+ ROW 32 INT VAR pivots;
+ INT VAR i, j, k :: ROWS a, n :: COLUMNS a, pos;
+
+ IF n <> k
+ THEN errorstop ("MATRIX OP INV : no square matrix") FI;
+
+ initialisiere die pivotpositionen;
+
+ FOR j FROM 1 UPTO n
+ REP pivotsuche (a, j, pos);
+ IF sub (a, pos, pos) = 0.0
+ THEN errorstop ("MATRIX OP INV : singular matrix") FI;
+ zeilentausch (a, j, pos);
+ merke dir die vertauschung;
+ transformiere die matrix
+ PER;
+
+ spaltentausch;
+ a .
+
+initialisiere die pivotpositionen :
+ FOR i FROM 1 UPTO n
+ REP pivots [i] := i PER .
+
+merke dir die vertauschung :
+ IF pos > j
+ THEN INT VAR hi :: pivots [j];
+ pivots [j] := pivots [pos];
+ pivots [pos] := hi
+ FI .
+
+transformiere die matrix :
+ REAL VAR h := 1.0/sub (a, j, j);
+
+ FOR k FROM 1 UPTO n
+ REP IF k <> j
+ THEN FOR i FROM 1 UPTO n
+ REP IF i <> j
+ THEN replace element (a, i, k, sub (a, i, k) -
+ sub (a, i, j)*sub (a, j, k)*h);
+ FI
+ PER;
+ FI
+ PER;
+
+ FOR k FROM 1 UPTO n
+ REP replace element (a, j, k, -h*sub (a, j, k));
+ replace element (a, k, j, h*sub (a, k, j))
+ PER;
+ replace element (a, j, j, h) .
+
+spaltentausch :
+ VECTOR VAR v :: vector (n);
+ FOR i FROM 1 UPTO n
+ REP FOR k FROM 1 UPTO n
+ REP replace (v, pivots [k], sub(a, i, k)) PER;
+ replace row (a, i, v)
+ PER .
+
+END OP INV;
+
+REAL OP DET (MATRIX CONST m) :
+ IF COLUMNS m <> ROWS m
+ THEN errorstop ("REAL OP DET : no square matrix") FI;
+
+ a := m;
+ INT VAR i, j, k, n :: COLUMNS m, pos;
+ REAL VAR merker := 1.0;
+ FOR j FROM 1 UPTO n
+ REP pivotsuche (a, j, pos);
+ IF j<> pos
+ THEN zeilentausch (a, j, pos);
+ zeilen tausch merken
+ FI;
+ transformiere die matrix
+ PER;
+ produkt der pivotelemente .
+
+transformiere die matrix :
+ REAL VAR hp := sub(a,j,j);
+ IF hp = 0.0
+ THEN LEAVE DET WITH 0.0
+ ELSE REAL VAR h := 1.0/hp;
+ FI;
+ FOR i FROM j+1 UPTO n
+ REP FOR k FROM j+1 UPTO n
+ REP replace element (a, i, k, sub (a, i, k) -
+ sub (a, i, j)*h*sub (a, j, k))
+ PER
+ PER .
+
+produkt der pivotelemente :
+ REAL VAR produkt :: sub (a, 1, 1);
+ FOR j FROM 2 UPTO n
+ REP produkt := produkt * sub (a, j, j) PER;
+ a := idn (1);
+ produkt * merker.
+
+zeilen tausch merken:
+ merker := merker * (-1.0).
+
+END OP DET;
+
+PROC pivotsuche (MATRIX CONST a, INT CONST start pos, INT VAR pos) :
+ REAL VAR max :: abs (sub (a, start pos, start pos));
+ INT VAR i;
+ pos := start pos;
+
+ FOR i FROM start pos+1 UPTO COLUMNS a
+ REP IF abs (sub (a, i, start pos)) > max
+ THEN max := abs (sub (a, i, start pos));
+ pos := i
+ FI
+ PER .
+
+END PROC pivotsuche;
+
+PROC zeilentausch (MATRIX VAR a, INT CONST old pos, pos) :
+ VECTOR VAR v := row (a, pos);
+ replace row (a, pos, row (a, old pos));
+ replace row (a, old pos, v) .
+
+END PROC zeilentausch;
+
+END PACKET matrix;
+
diff --git a/system/std.zusatz/1.8.7/src/port server b/system/std.zusatz/1.8.7/src/port server
new file mode 100644
index 0000000..46c647f
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/port server
@@ -0,0 +1,164 @@
+PACKET port server: (* Autor : R. Ruland *)
+ (* Stand : 21.03.86 *)
+
+INT VAR port station;
+TEXT VAR port := "PRINTER";
+
+put ("gib Name des Zielspools : "); editget (port); line;
+put ("gib Stationsnummer des Zielspools : "); get (port station);
+
+server channel (15);
+spool duty ("Verwalter fuer Task """ + port +
+ """ auf Station " + text (port station));
+
+LET max counter = 10 ,
+ time slice = 300 ,
+
+ ack = 0 ,
+ fetch code = 11 ,
+ param fetch code = 21 ,
+ file save code = 22 ,
+ file type = 1003 ,
+
+ begin char = ""0"",
+ end char = ""1"";
+
+
+INT VAR reply, old heap size;
+TEXT VAR file name, write pass, read pass, sendername, buffer;
+FILE VAR file;
+
+DATASPACE VAR ds, file ds, send ds;
+
+BOUND STRUCT (TEXT file name, write pass, read pass, sendername, INT station) VAR msg;
+BOUND TEXT VAR error msg ;
+
+spool manager (PROC save file);
+
+PROC save file :
+
+ disable stop ;
+ command dialogue (FALSE);
+ ds := nilspace; file ds := nilspace; send ds := nil space;
+ old heap size := heap size;
+
+ REP
+ execute save file;
+
+ IF is error THEN save error (error message) FI;
+
+ IF heap size > old heap size + 4
+ THEN collect heap garbage ;
+ old heap size := heap size
+ FI;
+
+ PER
+
+ENDPROC save file;
+
+
+PROC execute save file :
+
+enable stop;
+forget (file ds) ; file ds := nilspace;
+call (father, fetch code, file ds, reply);
+IF reply <> ack
+ THEN error msg := ds; errorstop (error msg);
+ ELSE save file ds
+FI;
+
+. save file ds :
+ IF type (file ds) = file type
+ THEN get file params;
+ insert file params;
+ call station (port station, port, file save code, file ds);
+ ELSE errorstop ("Datenraum hat falschen Typ")
+ FI;
+
+. get file params :
+ forget (ds); ds := nilspace;
+ call (father, param fetch code, ds, reply);
+ IF reply <> ack
+ THEN error msg := ds; errorstop (error msg);
+ ELSE msg := ds;
+ file name := msg. file name;
+ write pass := msg. write pass;
+ read pass := msg. read pass;
+ sendername := msg. sender name;
+ FI;
+
+. insert file params :
+ buffer := "";
+ in headline (filename);
+ in headline (write pass);
+ in headline (read pass);
+ in headline (sendername);
+ file := sequential file (input, file ds) ;
+ headline (file, buffer);
+
+END PROC execute save file;
+
+
+PROC call station (INT CONST order task station, TEXT CONST order task name,
+ INT CONST order code, DATASPACE VAR order ds) :
+
+ INT VAR counter := 0;
+ TASK VAR order task;
+ disable stop;
+ REP order task := order task station // order task name;
+ IF is error CAND pos (error message, "antwortet nicht") > 0
+ THEN clear error;
+ counter := min (max counter, counter + 1);
+ pause (counter * time slice);
+ ELSE enable stop;
+ forget (send ds); send ds := order ds;
+ call (order task, order code, send ds, reply);
+ disable stop;
+ IF reply = ack
+ THEN forget (order ds); order ds := send ds;
+ forget (send ds);
+ LEAVE call station
+ ELSE error msg := send ds;
+ errorstop (error msg);
+ FI;
+ FI;
+ PER;
+
+END PROC call station;
+
+
+TASK OP // (INT CONST station, TEXT CONST name) :
+
+ enable stop;
+ station / name
+
+END OP //;
+
+
+PROC in headline (TEXT CONST information) :
+ IF pos (information, begin char) <> 0
+ OR pos (information, end char) <> 0
+ THEN errorstop ("Name darf nicht Code 0 oder Code 1 enthalten") FI;
+ buffer CAT begin char;
+ buffer CAT information;
+ buffer CAT end char;
+END PROC in headline;
+
+
+PROC save error (TEXT CONST message) :
+ clear error;
+ file name CAT ".";
+ file name CAT sender name;
+ file name CAT ".ERROR";
+ file := sequential file (output, file name);
+ putline (file, " ");
+ putline (file, "Uebertragung nicht korrekt beendet ");
+ putline (file, " ");
+ put (file, "ERROR :"); put (file, message);
+ save (file name, public);
+ clear error;
+ forget(file name, quiet);
+END PROC save error;
+
+ENDPACKET port server;
+
diff --git a/system/std.zusatz/1.8.7/src/printer server b/system/std.zusatz/1.8.7/src/printer server
new file mode 100644
index 0000000..b1a30bc
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/printer server
@@ -0,0 +1,99 @@
+PACKET multi user printer : (* Autor : Rudolf Ruland *)
+ (* Stand : 24.03.86 *)
+
+INT VAR c;
+put ("gib Druckerkanal : "); get (c);
+
+ server channel (c);
+ station only (FALSE) ;
+ spool duty ("Ausgabe mit dem Drucker");
+ spool control task (myself);
+
+LET ack = 0 ,
+
+ fetch code = 11 ,
+ param fetch code = 21 ,
+ file type = 1003 ;
+
+INT VAR reply, old heap size, sender station;
+TEXT VAR file name, userid, password, sendername;
+FILE VAR file ;
+
+DATASPACE VAR ds, file ds;
+
+BOUND STRUCT (TEXT file name, userid, password, sendername, INT station) VAR msg;
+BOUND TEXT VAR error msg ;
+
+spool manager (PROC printer);
+
+PROC printer :
+
+ disable stop ;
+ command dialogue (FALSE);
+ ds := nilspace; file ds := nilspace;
+ continue (server channel) ;
+ check error ("Kanal belegt");
+
+ old heap size := heap size ;
+ REP
+ execute print ;
+
+ IF is error
+ THEN put error;
+ clear error;
+ FI ;
+
+ IF heap size > old heap size + 4
+ THEN collect heap garbage ;
+ old heap size := heap size
+ FI
+ PER
+
+ENDPROC printer ;
+
+
+PROC execute print :
+
+ enable stop ;
+ forget (file ds) ; file ds := nilspace ;
+ call (father, fetch code, file ds, reply) ;
+ IF reply = ack CAND type (file ds) = file type
+ THEN get file params;
+ print file
+ FI ;
+
+. get file params :
+ forget (ds); ds := nilspace;
+ call (father, param fetch code, ds, reply);
+ IF reply <> ack
+ THEN error msg := ds; errorstop (error msg);
+ ELSE msg := ds;
+ file name := msg. file name;
+ userid := msg. userid;
+ password := msg. password;
+ sendername := msg. sender name;
+ sender station := msg. station;
+ FI;
+
+. print file :
+ file := sequential file (input, file ds);
+ print (file,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ENDPROC execute print ;
+
+
+PROC check error (TEXT CONST message) :
+ IF is error
+ THEN clear error;
+ rename myself (message);
+ IF is error THEN clear error; end (myself) FI;
+ pause (18000);
+ end (myself);
+ FI;
+END PROC check error;
+
+ENDPACKET multi user printer ;
+
diff --git a/system/std.zusatz/1.8.7/src/purge b/system/std.zusatz/1.8.7/src/purge
new file mode 100644
index 0000000..55230ff
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/purge
@@ -0,0 +1,85 @@
+PACKET purge DEFINES purge :
+
+
+TEXT VAR task name, record, file name, dummy ;
+
+FILE VAR permit ;
+
+
+PROC purge :
+
+ IF exists ("permitted tasks")
+ THEN access catalogue ;
+ permit := sequential file (input, "permitted tasks") ;
+ say (""10""13"TASKS :"10""10""13"") ;
+ IF myself < supervisor
+ THEN purge son tasks (brother (supervisor))
+ ELSE purge son tasks (myself)
+ FI
+ FI ;
+ IF exists ("permitted files")
+ THEN permit := sequential file (input, "permitted files") ;
+ say (""10""13"DATEIEN :"10""10""13"") ;
+ purge files
+ FI
+
+ENDPROC purge ;
+
+PROC purge son tasks (TASK CONST father task) :
+
+ TASK VAR actual task := son (father task) ;
+ WHILE NOT is niltask (actual task) REP
+ purge son tasks (actual task) ;
+ IF NOT actual task permitted
+ THEN erase actual task
+ FI ;
+ actual task := brother (actual task)
+ END REP .
+
+erase actual task :
+ say ("""") ; say (task name) ; say ("""") ;
+ IF yes (" loeschen")
+ THEN end (actual task)
+ FI .
+
+actual task permitted :
+ task name := name (actual task) ;
+ reset (permit) ;
+ WHILE NOT eof (permit) REP
+ getline (permit, record) ;
+ IF task name = record
+ THEN LEAVE actual task permitted WITH TRUE
+ FI
+ END REP ;
+ FALSE .
+
+ENDPROC purge son tasks ;
+
+PROC purge files :
+
+ begin list ;
+ get list entry (file name, dummy) ;
+ WHILE file name <> "" REP
+ IF NOT file permitted
+ THEN forget (file name)
+ FI ;
+ get list entry (file name, dummy)
+ END REP .
+
+file permitted :
+ IF file name = "permitted tasks" OR file name = "permitted files"
+ THEN LEAVE file permitted WITH TRUE
+ FI ;
+ reset (permit) ;
+ WHILE NOT eof (permit) REP
+ getline (permit, record) ;
+ IF file name = record
+ THEN LEAVE file permitted WITH TRUE
+ FI
+ END REP ;
+ FALSE .
+
+ENDPROC purge files ;
+
+ENDPACKET purge ;
+
diff --git a/system/std.zusatz/1.8.7/src/referencer b/system/std.zusatz/1.8.7/src/referencer
new file mode 100644
index 0000000..2ee65e4
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/referencer
@@ -0,0 +1,1077 @@
+(* ------------------- VERSION 10 vom 01.08.86 -------------------- *)
+PACKET referencer errors DEFINES report referencer error:
+
+(* Programm zur Fehlerbehandlung des referencers.
+ Autor: Rainer Hahn *)
+
+TEXT VAR fehlerdummy,
+ message;
+
+PROC report referencer error (INT CONST error nr,
+ INT CONST line nr,
+ TEXT CONST addition):
+
+ einfache fehlermeldung aufbauen;
+ diese auf terminal ausgeben;
+ fehlermeldung in fehlerdatei ausgeben.
+
+einfache fehlermeldung aufbauen:
+ message := "WARNUNG in Zeile ";
+ message CAT text (line nr);
+ message CAT " : ";
+ message CAT simple message.
+
+diese auf terminal ausgeben:
+ line ;
+ putline (message).
+
+fehlermeldung in fehlerdatei ausgeben:
+ note (message);
+ note line ;
+ fehlerdummy := " >>> ";
+ fehlerdummy CAT zusatz;
+ note (fehlerdummy);
+ note line.
+
+simple message:
+ SELECT error nr OF
+ CASE 1: "Text Denoter ueber mehr als eine Zeile"
+ CASE 2: "Nicht beendeter Text Denoter bei Programmende"
+ CASE 3: "Kommentar ueber mehr als eine Zeile"
+ CASE 4: "Nicht beendeter Kommentar bei Programmende"
+ CASE 5: "Ueberdeckung"
+ CASE 6, 9: "Refinement mehrmals eingesetzt"
+ CASE 7, 10: "Refinement wird nicht aufgerufen"
+ CASE 8: "Objekt wird nicht angesprochen"
+ OTHERWISE ""
+ ENDSELECT.
+
+zusatz:
+ SELECT error nr OF
+ CASE 1, 2, 3, 4: "Ueber " + addition + " Zeilen"
+ CASE 5: addition
+ CASE 6, 7, 8: addition
+ CASE 9, 10: addition + " in mindestens einer Prozedur"
+ OTHERWISE "interner Fehler: HRZ Bielefeld benachrichtigen!"
+ END SELECT.
+END PROC report referencer error
+END PACKET referencer errors;
+(************************************************************************)
+
+PACKET name table handling
+ DEFINES NAMETABLE,
+ empty name table,
+ put name,
+ get name,
+ dump table:
+
+(* Programm zur Speicherung von Namen.
+ Autor: Rainer Hahn *)
+
+LET hash table length = 1024,
+ hash table length minus one = 1023,
+ start of name table = 255,
+ name table length = 2000;
+
+TYPE NAMETABLE = STRUCT (INT number of entries,
+ ROW hash table length INT hash table,
+ ROW name table length INT next,
+ ROW name table length TEXT name table);
+
+TEXT VAR dummy, f;
+
+PROC put name (NAMETABLE VAR n, TEXT CONST name, INT VAR pointer):
+ INT VAR errechneter index;
+ hash (name, errechneter index);
+ IF noch kein eintrag
+ THEN gaenzlich neuer eintrag
+ ELSE name in vorhandener kette
+ FI.
+
+noch kein eintrag:
+ n . hash table [errechneter index] = 0.
+
+gaenzlich neuer eintrag:
+ n . hash table [errechneter index] := n . number of entries;
+ neuer eintrag (n, name, pointer).
+
+name in vorhandener kette:
+ INT VAR dieser eintrag :: n. hash table [errechneter index];
+ REP
+ IF name ist vorhanden
+ THEN pointer := dieser eintrag;
+ LEAVE put name
+ ELIF kette zu ende
+ THEN neuer eintrag an vorhandene kette anketten;
+ neuer eintrag (n, name, pointer);
+ LEAVE put name
+ ELSE naechster eintrag in der kette
+ FI
+ END REP.
+
+name ist vorhanden:
+ n . name table [dieser eintrag] = name.
+
+kette zu ende:
+ n . next [dieser eintrag] = 0.
+
+neuer eintrag an vorhandene kette anketten:
+ n . next [dieser eintrag] := n . number of entries.
+
+naechster eintrag in der kette:
+ dieser eintrag := n . next [dieser eintrag].
+END PROC put name;
+
+PROC neuer eintrag (NAMETABLE VAR n, TEXT CONST name, INT VAR pointer):
+ n . name table [n . number of entries] := name;
+ n . next [n . number of entries] := 0;
+ pointer := n . number of entries;
+ n . number of entries INCR 1;
+ IF n . number of entries > name table length
+ THEN errorstop ("volle Namenstabelle")
+ FI
+END PROC neuer eintrag;
+
+PROC hash (TEXT CONST name, INT VAR index) :
+ INT VAR i;
+ index := code (name SUB 1);
+ FOR i FROM 2 UPTO length (name) REP
+ addmult cyclic
+ ENDREP.
+
+addmult cyclic :
+ index INCR index ;
+ IF index > hash table length minus one
+ THEN wrap around
+ FI;
+ index := (index + code (name SUB i)) MOD hash table length.
+
+wrap around :
+ index DECR hash table length minus one
+ENDPROC hash ;
+
+PROC get name (NAMETABLE CONST n, INT CONST index, TEXT VAR t):
+ IF index < n . number of entries AND index >= start of name table
+ THEN t := n . name table [index]
+ ELSE errorstop ("Interner Fehler 1")
+ FI
+END PROC get name;
+
+PROC empty name table (NAMETABLE VAR n):
+INT VAR i;
+ n . number of entries := start of name table;
+ FOR i FROM 1 UPTO hash table length REP
+ n . hash table [i] := 0
+ END REP
+END PROC empty name table;
+
+PROC dump table (NAMETABLE CONST n):
+ line ;
+ put ("Bitte Name der Datei, in die die Namenstabelle gehen soll:");
+ getline (f);
+ line ;
+ file assoziieren;
+ dump namens ketten;
+ zusammenfassung.
+
+file assoziieren:
+ FILE VAR file :: sequential file (output, f).
+
+dump namens ketten:
+ INT VAR i,
+ anz hash eintraege :: 0,
+ kette 3 eintraege :: 0;
+ FOR i FROM 1 UPTO hash table length REP
+ IF n . hash table [i] <> 0
+ THEN anz hash eintraege INCR 1;
+ INT VAR naechster eintrag :: n . hash table [i];
+ dump hash eintrag;
+ ketten eintraege
+ FI
+ END REP.
+
+dump hash eintrag:
+ dummy := text (i);
+ WHILE length (dummy) < 4 REP dummy CAT " " END REP;
+ dummy CAT ": ".
+
+ketten eintraege:
+ INT VAR anz eintraege pro kette :: 0;
+ WHILE naechster eintrag > 0 REP
+ anz eintraege pro kette INCR 1;
+ dummy CAT " ";
+ dummy CAT text (naechster eintrag);
+ dummy CAT " -> ";
+ dummy CAT n . name table [naechster eintrag];
+ naechster eintrag := n . next [naechster eintrag];
+ END REP;
+ IF anz eintraege pro kette > 2
+ THEN kette 3 eintraege INCR 1
+ FI;
+ putline (file, dummy).
+
+zusammenfassung:
+ statistik ueberschrift;
+ anzahl hash eintraege;
+ anzahl namens eintraege;
+ verkettungsfaktor;
+ anzahl laengerer ketten.
+
+statistik ueberschrift:
+ line (file, 2);
+ dummy := " ---------- ";
+ dummy CAT "S T A T I S T I K:";
+ dummy CAT " ---------- ";
+ putline (file, dummy);
+ line (file, 2).
+
+anzahl hash eintraege:
+ dummy := "Anzahl Hash-Eintraege (max. ";
+ dummy CAT text (hash table length);
+ dummy CAT "): ";
+ dummy CAT text (anz hash eintraege);
+ putline (file, dummy).
+
+anzahl namens eintraege:
+ dummy := "Anzahl Namen (max. ";
+ dummy CAT text (name table length - start of name table + 1);
+ dummy CAT "): ";
+ dummy CAT text (n . number of entries - start of name table);
+ putline (file, dummy).
+
+verkettungsfaktor:
+ dummy := "Verkettungsfaktor (Anzahl Namen / Anzahl Ketten): ";
+ dummy CAT text (real (n . number of entries - start of name table) /
+ real (anz hash eintraege));
+ putline (file, dummy).
+
+anzahl laengerer ketten:
+ dummy := "Anzahl Ketten > 2 Eintraege: ";
+ dummy CAT text (kette 3 eintraege);
+ putline (file, dummy).
+END PROC dump table;
+END PACKET name table handling;
+(***************************************************************************)
+
+PACKET scanner DEFINES init scanning,
+ init name table with,
+ dump name table,
+ get name,
+ end scanning,
+ line number,
+ symbol:
+
+(* Programm zum scannen von ELAN-Programmen.
+ Autor: Rainer Hahn *)
+
+FILE VAR eingabe;
+
+DATASPACE VAR ds alt := nilspace,
+ ds neu := nilspace;
+
+BOUND NAMETABLE VAR tabelle;
+
+TEXT VAR zeile,
+ zeichen,
+ dummy;
+
+LET end of program = ""30"",
+ eop = 1,
+ identifier = 2,
+ keyword = 3,
+ delimiter = 4,
+ punkt = 46,
+ doppelpunkt = 58,
+ init symbol = 30,
+ assign symbol = 31;
+
+INT VAR zeilen nr,
+ zeichen pos;
+
+PROC init name table with (TEXT CONST worte):
+INT VAR index;
+ forget (ds alt);
+ ds alt := nilspace;
+ tabelle := dsalt;
+ empty name table (CONCR (tabelle));
+ INT VAR anf :: 1,
+ ende :: pos (worte, ",", 1);
+ WHILE ende > 0 REP
+ dummy := subtext (worte, anf, ende - 1);
+ put name (CONCR (tabelle), dummy, index);
+ anf := ende + 1;
+ ende := pos (worte, ",", ende + 1)
+ END REP;
+ dummy := subtext (worte, anf);
+ put name (CONCR (tabelle), dummy, index)
+END PROC init name table with;
+
+PROC init scanning (TEXT CONST f):
+ IF exists (f)
+ THEN namenstabelle holen;
+ erste zeile lesen
+ ELSE errorstop ("Datei existiert nicht")
+ FI.
+
+namenstabelle holen:
+ forget (ds neu);
+ ds neu := ds alt;
+ tabelle := ds neu.
+
+erste zeile lesen:
+ eingabe := sequential file (input, f);
+ IF eof (eingabe)
+ THEN errorstop ("Datei ist leer")
+ ELSE zeile := "";
+ zeilen nr := 0;
+ zeile lesen;
+ naechstes non blank zeichen
+ FI
+END PROC init scanning;
+
+PROC dump name table:
+ dump table (CONCR (tabelle))
+END PROC dump name table;
+
+PROC end scanning (TEXT CONST f):
+ IF anything noted
+ THEN eingabe := sequential file (modify, f);
+ note edit (eingabe)
+ FI
+END PROC end scanning;
+
+PROC get name (INT CONST index, TEXT VAR t):
+ get name (CONCR (tabelle), index, t)
+END PROC get name;
+
+PROC zeile lesen:
+ getline (eingabe, zeile);
+ zeilen nr INCR 1;
+ cout (zeilen nr);
+ zeichen pos := 0
+END PROC zeile lesen;
+
+PROC naechstes non blank zeichen:
+ REP
+ zeichen pos := pos (zeile, ""33"", ""254"", zeichen pos + 1);
+ IF zeichen pos <> 0
+ THEN zeichen := (zeile SUB zeichen pos);
+ LEAVE naechstes non blank zeichen
+ ELIF eof (eingabe)
+ THEN zeichen := end of program;
+ LEAVE naechstes non blank zeichen
+ ELSE zeile lesen
+ FI
+ END REP.
+END PROC naechstes non blank zeichen;
+
+PROC naechstes zeichen:
+ IF zeichen pos > length (zeile)
+ THEN IF eof (eingabe)
+ THEN zeichen := end of program;
+ LEAVE naechstes zeichen
+ ELSE zeile lesen
+ FI
+ FI;
+ zeichenpos INCR 1;
+ zeichen := zeile SUB zeichenpos
+END PROC naechstes zeichen;
+
+INT PROC line number:
+ IF zeichenpos = pos (zeile, ""33"", ""254"", 1)
+ THEN zeilen nr - 1
+ ELSE zeilen nr
+ FI
+END PROC line number;
+
+PROC symbol (INT VAR symb, type):
+ REP
+ suche naechstes checker symbol
+ END REP.
+
+suche naechstes checker symbol:
+ SELECT code (zeichen) OF
+ CASE 30: (* end of programn *)
+ symb := eop;
+ type := eop;
+ LEAVE symbol
+ CASE 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110,
+ 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122:
+ (* small letters *)
+ identifier aufsammeln;
+ put name (CONCR (tabelle), dummy, symb);
+ type := identifier;
+ LEAVE symbol
+ CASE 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81,
+ 82, 83, 84, 85, 86, 87, 88, 89, 90: (* large letters *)
+ schluesselwort aufsammeln;
+ put name (CONCR (tabelle), dummy, symb);
+ type := keyword;
+ LEAVE symbol
+ CASE 34: (* " *)
+ skip text denoter
+ CASE 40: (* ( *)
+ IF (zeile SUB zeichen pos + 1) = "*"
+ THEN skip comment
+ ELSE symb := code (zeichen);
+ type := delimiter;
+ naechstes non blank zeichen;
+ LEAVE symbol;
+ FI
+ CASE 58: (* : *)
+ IF (zeile SUB zeichenpos + 1) = "="
+ THEN symb := assign symbol;
+ zeichenpos INCR 1
+ ELIF (zeile SUB zeichenpos + 1) = ":"
+ THEN symb := init symbol;
+ zeichenpos INCR 1
+ ELSE symb := doppelpunkt
+ FI;
+ type := delimiter;
+ naechstes non blank zeichen;
+ LEAVE symbol
+ CASE 48, 49, 50, 51, 52, 53, 54, 55, 56, 57: (* 0 - 9 *)
+ int denoter skippen;
+ IF zeichen = "."
+ THEN naechstes non blank zeichen;
+ IF digit
+ THEN real denoter skippen
+ ELSE symb := punkt;
+ type := delimiter;
+ LEAVE symbol
+ FI
+ FI
+ CASE 41, 44, 46, 59, 61: (* ) , . ; = *)
+ symb := code (zeichen);
+ type := delimiter;
+ naechstes non blank zeichen;
+ LEAVE symbol
+ OTHERWISE naechstes non blank zeichen
+ END SELECT.
+END PROC symbol;
+
+PROC real denoter skippen:
+ int denoter skippen;
+ IF zeichen = "e"
+ THEN naechstes non blank zeichen;
+ int denoter skippen
+ FI
+END PROC real denoter skippen;
+
+PROC int denoter skippen:
+ naechstes non blank zeichen;
+ WHILE zeichen >= "0" AND zeichen <= "9" REP
+ naechstes non blank zeichen
+ ENDREP;
+ zeichenpos DECR 1;
+ naechstes non blank zeichen
+END PROC int denoter skippen;
+
+PROC identifier aufsammeln:
+ dummy := zeichen;
+ REP
+ naechstes non blank zeichen;
+ IF small letter or digit
+ THEN dummy CAT zeichen
+ ELSE LEAVE identifier aufsammeln
+ FI
+ END REP
+END PROC identifier aufsammeln;
+
+PROC schluesselwort aufsammeln:
+ dummy := "";
+ sammle schluesselwort;
+ IF dummy = "END"
+ THEN noch einmal
+ FI.
+
+sammle schluesselwort:
+ WHILE large letter REP
+ dummy CAT zeichen;
+ naechstes zeichen
+ END REP;
+ IF zeichen = " "
+ THEN naechstes non blank zeichen
+ FI.
+
+noch einmal:
+ sammle schluesselwort
+END PROC schluesselwort aufsammeln;
+
+PROC skip text denoter:
+ INT VAR anz zeilen :: 0;
+ zeichen pos := pos (zeile, """", zeichenpos + 1);
+ WHILE zeichen pos = 0 REP
+ naechste zeile einlesen;
+ zeichen pos := pos (zeile, """");
+ END REP;
+ ende text denoter.
+
+ende text denoter:
+ IF anz zeilen > 1
+ THEN report referencer error (1, zeilen nr, text (anz zeilen))
+ FI;
+ naechstes non blank zeichen.
+
+naechste zeile einlesen:
+ IF eof (eingabe)
+ THEN report referencer error (2, zeilen nr, text (anz zeilen));
+ zeichen := end of program;
+ LEAVE skip text denoter
+ ELSE zeile lesen;
+ anz zeilen INCR 1
+ FI.
+END PROC skip text denoter;
+
+PROC skip comment:
+ INT VAR anz zeilen :: 0;
+ zeichen pos := pos (zeile, "*)", zeichenpos + 2);
+ WHILE zeichen pos = 0 REP
+ naechste zeile einlesen;
+ zeichen pos := pos (zeile, "*)");
+ END REP;
+ ende comment.
+
+ende comment:
+ IF anz zeilen > 1
+ THEN report referencer error (3, zeilen nr, text (anz zeilen))
+ FI;
+ zeichen pos INCR 2;
+ naechstes non blank zeichen.
+
+naechste zeile einlesen:
+ IF eof (eingabe)
+ THEN report referencer error (4, zeilen nr, text (anz zeilen));
+ zeichen := end of program;
+ LEAVE skip comment
+ ELSE zeile lesen;
+ anz zeilen INCR 1
+ FI.
+END PROC skip comment;
+
+BOOL PROC small letter or digit:
+ (zeichen >= "0" AND zeichen <= "9") OR (zeichen >= "a" AND zeichen <= "z")
+END PROC small letter or digit;
+
+BOOL PROC small letter:
+ zeichen >= "a" AND zeichen <= "z"
+END PROC small letter;
+
+BOOL PROC large letter:
+ zeichen >= "A" AND zeichen <= "Z"
+END PROC large letter;
+
+BOOL PROC digit:
+ zeichen >= "0" AND zeichen <= "9"
+END PROC digit;
+END PACKET scanner;
+(*************************************************************************)
+PACKET referencer2 DEFINES referencer:
+
+(* Programm fuer den 'referencer'
+ Autor: Rainer Hahn *)
+
+INT VAR symb,
+ typ,
+ max index;
+
+TEXT VAR dummy,
+ dummy2,
+ name;
+
+DATASPACE VAR ds;
+
+BOUND ROW max TEXT VAR liste;
+
+FILE VAR f;
+
+BOOL VAR initialisiert :: FALSE,
+ symbol bereits geholt,
+ globale deklarationen;
+
+LET max = 1751,
+ global text = "<--G",
+ local text = "<--L",
+ refinement text = "<--R",
+ procedure text = "<--P",
+ eop = 1,
+ identifier = 2,
+ keyword = 3,
+ init symbol = 30,
+ assign symbol = 31,
+ klammer auf = 40,
+ klammer zu = 41,
+ komma = 44,
+ punkt = 46,
+ doppelpunkt = 58,
+ semikolon = 59,
+ proc symbol = 255,
+ end proc symbol = 256,
+ packet symbol = 257,
+ end packet symbol = 258,
+ type symbol = 259,
+ var symbol = 260,
+ const symbol = 261,
+ let symbol = 262,
+ leave symbol = 263,
+ op symbol = 264,
+ endop symbol = 265,
+ endif symbol = 266,
+ fi symbol = 266;
+
+PROC referencer:
+ referencer (last param)
+END PROC referencer;
+
+PROC referencer (TEXT CONST check file):
+ referencer (check file, check file + ".r")
+END PROC referencer;
+
+PROC referencer (TEXT CONST check file, dump file):
+ IF exists (check file)
+ THEN dump file ggf loeschen
+ ELSE errorstop ("Eingabe-Datei nicht vorhanden")
+ FI;
+ disable stop;
+ start referencing (check file, dump file);
+ forget (ds);
+ enable stop.
+
+dump file ggf loeschen:
+ IF exists (dump file)
+ THEN forget (dump file, quiet)
+ FI.
+END PROC referencer;
+
+PROC start referencing (TEXT CONST check file, dump file):
+ enable stop;
+ ueberschrift;
+ initialisierung;
+ verkuerzte syntax analyse;
+ line ;
+ in dump file kopieren (dump file);
+ line ;
+ end scanning (check file).
+
+ueberschrift:
+ page;
+ put ("REFERENCER:");
+ put (check file);
+ put ("->");
+ putline (dump file).
+
+initialisierung:
+ IF NOT initialisiert
+ THEN init name table with
+("PROC,ENDPROC,PACKET,ENDPACKET,TYPE,VAR,CONST,LET,LEAVE,OP,ENDOP,ENDIF,FI");
+ initialisiert := TRUE
+ FI;
+ ds := nilspace;
+ liste := ds;
+ max index := end op symbol;
+ dummy := checkfile.
+
+verkuerzte syntax analyse:
+ globale deklarationen := TRUE;
+ line ;
+ init scanning (dummy);
+ symbol bereits geholt := FALSE;
+ REP
+ IF symbol bereits geholt
+ THEN symbol bereits geholt := FALSE
+ ELSE symbol (symb, typ)
+ FI;
+ IF typ = keyword
+ THEN nach schluesselwort verarbeiten
+ ELIF symb = punkt
+ THEN ggf refinement aufnehmen
+ ELIF typ = identifier
+ THEN identifier aufnehmen und ggf aktuelle parameter liste
+ FI
+ UNTIL typ = eop ENDREP.
+
+identifier aufnehmen und ggf aktuelle parameter liste:
+ in die liste (symb, "");
+ symbol (symb, typ);
+ IF symb = klammer auf
+ THEN aktuelle parameter aufnehmen
+ ELSE symbol bereits geholt := TRUE
+ FI.
+
+nach schluesselwort verarbeiten:
+ SELECT symb OF
+ CASE let symbol:
+ let deklarationen aufsammeln
+ CASE packet symbol:
+ namen des interface aufsammeln
+ CASE end packet symbol:
+ skip naechstes symbol
+ CASE var symbol, const symbol:
+ datenobjekt deklaration aufnehmen
+ CASE proc symbol:
+ globale deklarationen := FALSE;
+ prozedur name und ggf parameter aufsammeln
+ CASE end proc symbol:
+ globale deklarationen := TRUE;
+ skip naechstes symbol
+ CASE op symbol:
+ globale deklarationen := FALSE;
+ operatornamen skippen und ggf parameter aufsammeln
+ CASE end op symbol:
+ globale deklarationen := TRUE;
+ skip until (semikolon)
+ CASE type symbol:
+ namen der typ definition aufsammeln
+ CASE leave symbol:
+ skip naechstes symbol
+ OTHERWISE:
+ ENDSELECT.
+
+skip naechstes symbol:
+ symbol (symb, typ).
+END PROC start referencing;
+
+PROC aktuelle parameter aufnehmen:
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN in die liste (symb, "")
+ FI
+ UNTIL symb = klammer zu END REP.
+END PROC aktuelle parameter aufnehmen;
+
+PROC ggf refinement aufnehmen:
+ symbol (symb, typ);
+ symbol bereits geholt := TRUE;
+ WHILE typ = identifier REP
+ doppelpunkt oder selektor
+ END REP.
+
+doppelpunkt oder selektor:
+ INT CONST letzter id :: symb;
+ symbol (symb, typ);
+ IF symb = doppelpunkt
+ THEN in die liste (letzter id, refinement text);
+ LEAVE ggf refinement aufnehmen
+ ELSE in die liste (letzter id, "");
+ IF symb = punkt
+ THEN symbol (symb, typ)
+ ELSE LEAVE ggf refinement aufnehmen
+ FI
+ FI
+END PROC ggf refinement aufnehmen;
+
+PROC namen des interface aufsammeln:
+ packet name ueberspringen;
+ namen der schnittstelle aufsammeln.
+
+packet name ueberspringen:
+ symbol (symb, typ).
+
+namen der schnittstelle aufsammeln:
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN in die liste (symb, "")
+ FI
+ UNTIL symb = doppelpunkt END REP.
+END PROC namen des interface aufsammeln;
+
+PROC let deklarationen aufsammeln:
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN let name aufnehmen
+ ELIF typ = keyword
+ THEN bis zum komma oder semikolon
+ FI;
+ UNTIL symb = semikolon END REP.
+
+let name aufnehmen:
+ IF globale deklarationen
+ THEN in die liste (symb, global text)
+ ELSE in die liste (symb, "")
+ FI;
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN in die liste (symb, "")
+ FI
+ UNTIL symb = komma OR symb = semikolon END REP.
+END PROC let deklarationen aufsammeln;
+
+PROC namen der typ definition aufsammeln:
+ REP
+ symbol (symb, typ);
+ bis zum komma oder semikolon
+ UNTIL symb = semikolon END REP
+END PROC namen der typ definition aufsammeln;
+
+PROC bis zum komma oder semikolon:
+ INT VAR anz klammern :: 0;
+ REP
+ symbol (symb, typ); (* fields aufnehmen weggelassen *)
+ IF symb = klammer auf
+ THEN anz klammern INCR 1
+ ELIF symb = klammer zu
+ THEN anz klammern DECR 1
+ FI
+ UNTIL (symb = komma AND anz klammern = 0) OR symb = semikolon ENDREP.
+END PROC bis zum komma oder semikolon;
+
+PROC datenobjekt deklaration aufnehmen:
+ symbol (symb, typ);
+ REP
+ IF globale deklarationen
+ THEN in die liste (symb, global text)
+ ELSE in die liste (symb, local text)
+ FI;
+ skip ggf initialisierung;
+ IF symb = komma
+ THEN symbol (symb, typ)
+ FI
+ UNTIL symb = semikolon OR symb = punkt END REP.
+
+skip ggf initialisierung:
+ symbol (symb, typ);
+ IF symb = init symbol OR symb = assign symbol
+ THEN initialisierung skippen
+ FI.
+
+initialisierung skippen:
+ INT VAR anz klammern :: 0;
+ REP
+ INT CONST vorheriges symbol :: symb,
+ vorheriger typ :: typ;
+ symbol (symb, typ);
+ IF symb = klammer auf
+ THEN anz klammern INCR 1;
+ IF vorheriger typ = identifier
+ THEN in die liste (vorheriges symbol, "")
+ FI
+ ELIF symb = klammer zu
+ THEN anz klammern DECR 1;
+ IF vorheriger typ = identifier
+ THEN in die liste (vorheriges symbol, "")
+ FI
+ ELIF vorheriger typ = identifier AND symb = doppelpunkt
+ THEN in die liste (vorheriges symbol, refinement text);
+ LEAVE datenobjekt deklaration aufnehmen
+ ELIF vorheriger typ = identifier
+ THEN in die liste (vorheriges symbol, "")
+ FI
+ UNTIL (symb = komma AND anz klammern = 0)
+ OR symb = semikolon OR symb = end proc symbol OR
+ symb = end op symbol OR symb = endif symbol OR symb = fi symbol
+ END REP.
+END PROC datenobjekt deklaration aufnehmen;
+
+PROC prozedur name und ggf parameter aufsammeln:
+ prozedurname aufsammeln;
+ symbol (symb, typ);
+ IF symb <> doppelpunkt
+ THEN formale parameter aufsammeln
+ FI.
+
+prozedurname aufsammeln:
+ symbol (symb, typ);
+ in die liste (symb, procedure text).
+END PROC prozedurname und ggf parameter aufsammeln;
+
+PROC operatornamen skippen und ggf parameter aufsammeln:
+ symbol (symb, typ);
+ IF symb <> doppelpunkt
+ THEN formale parameter aufsammeln
+ FI
+END PROC operatornamen skippen und ggf parameter aufsammeln;
+
+PROC formale parameter aufsammeln:
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN in die liste (symb, local text);
+ FI
+ UNTIL symb = doppelpunkt END REP
+END PROC formale parameter aufsammeln;
+
+PROC skip until (INT CONST zeichencode):
+ skip until (zeichencode, 0)
+END PROC skip until;
+
+PROC skip until (INT CONST z1, z2):
+ REP
+ symbol (symb, typ)
+ UNTIL symb = z1 OR symb = z2 END REP
+END PROC skip until;
+
+PROC in die liste (INT CONST index, TEXT CONST zusatz):
+ IF index > max index
+ THEN listenelemente initialisieren;
+ FI;
+ IF aktueller eintrag = ""
+ THEN namens eintrag
+ FI;
+ aktueller eintrag CAT " ";
+ aktueller eintrag CAT text (line number);
+ aktueller eintrag CAT zusatz.
+
+aktueller eintrag:
+ liste [index].
+
+listenelemente initialisieren:
+ INT VAR i;
+ FOR i FROM max index + 1 UPTO index REP
+ liste [i] := ""
+ END REP;
+ max index := index.
+
+namens eintrag:
+ get name (index, aktueller eintrag);
+ WHILE length (aktueller eintrag) < 15 REP
+ aktueller eintrag CAT " "
+ END REP;
+ aktueller eintrag CAT ":".
+END PROC in die liste;
+
+TEXT VAR zeile;
+
+PROC in dump file kopieren (TEXT CONST dump file):
+ putline ("Ausgabedatei erstellen");
+ f := sequential file (output, dump file);
+ INT VAR i;
+ kopieren und ggf fehlermeldung;
+ modify (f);
+ ggf sortieren;
+ zeile ggf aufspalten;
+ modify (f);
+ to line (f, 1).
+
+kopieren und ggf fehlermeldung:
+ FOR i FROM fi symbol UPTO max index REP
+ cout (i);
+ zeile := liste [i];
+ IF zeile <> ""
+ THEN ausgabe der referenz und ggf fehlermeldung
+ FI
+ ENDREP.
+
+ausgabe der referenz und ggf fehlermeldung:
+ putline (f, zeile);
+ ggf referencer fehlermeldung.
+
+ggf sortieren:
+ IF yes (dump file + " sortieren")
+ THEN sort (dump file);
+ FI.
+
+zeile ggf aufspalten:
+ i := 0;
+ to line (f, 1);
+ WHILE NOT eof (f) REP
+ i INCR 1;
+ cout (i);
+ read record (f, zeile);
+ ggf aufspalten
+ END REP.
+
+ggf aufspalten:
+INT VAR anf :: 1, ende :: pos (zeile, " ", 72);
+ IF ende > 0
+ THEN dummy := subtext (zeile, 1, ende - 1);
+ write record (f, dummy);
+ spalte bis restzeile auf;
+ dummy CAT subtext (zeile, anf);
+ write record (f, dummy);
+ FI;
+ down (f).
+
+spalte bis restzeile auf:
+ REP
+ dummy := " ";
+ anf := ende + 1;
+ ende := pos (zeile, " ", ende + 55);
+ down (f);
+ insert record (f);
+ IF ende <= 0
+ THEN LEAVE spalte bis restzeile auf
+ FI;
+ dummy CAT subtext (zeile, anf, ende - 1);
+ write record (f, dummy);
+ END REP.
+END PROC in dump file kopieren;
+
+PROC ggf referencer fehlermeldung:
+ name := subtext (zeile, 1, min( pos(zeile, " "), pos(zeile, ":")) - 1);
+ dummy := subtext (zeile, pos (zeile, ": ") + 2);
+ ueberdeckungs ueberpruefung;
+ not used ueberpruefung;
+ IF pos (dummy, "R") > 0
+ THEN refinement mehr als zweimal verwendet
+ FI.
+
+ueberdeckungs ueberpruefung:
+ IF pos (dummy, global text) > 0 AND pos (dummy, local text) > 0
+ THEN dummy2 := "und Zeile ";
+ dummy2 CAT text (nr (pos (dummy, local text)));
+ dummy2 CAT ": ";
+ dummy2 CAT name;
+ report referencer error
+ (5, nr (pos (dummy, global text)), dummy2)
+ FI.
+
+not used ueberpruefung:
+ IF pos (dummy, " ") = 0 AND
+ (pos (dummy, global text) > 0 OR pos (dummy, local text) > 0 OR
+ pos (dummy, refinement text) > 0)
+ THEN not used fehlermeldung
+ FI.
+
+not used fehlermeldung:
+ report referencer error
+ (8, nr (length (dummy) - length (local text) + 1), name).
+
+refinement mehr als zweimal verwendet:
+ INT VAR refinement deklarationen :: 0,
+ refinement aufrufe :: 0,
+ anf :: 1;
+ WHILE pos (dummy,"R", anf) > 0 REP
+ refinement deklarationen INCR 1;
+ anf := pos (dummy, "R", anf) + 1
+ END REP;
+ anf := 1;
+ WHILE pos (dummy, " ", anf) > 0 REP
+ refinement aufrufe INCR 1;
+ anf := pos (dummy, " ", anf) + 1
+ END REP;
+ IF refinement deklarationen = 1
+ THEN IF refinement aufrufe > 1
+ THEN report referencer error
+ (6, nr (pos (dummy, refinement text)), name)
+ ELIF refinement aufrufe = 0
+ THEN report referencer error
+ (7, nr (pos (dummy, refinement text)), name)
+ FI
+ ELIF refinement deklarationen > 1
+ THEN IF 2 * refinement deklarationen - 1 > refinement aufrufe
+ THEN report referencer error (9, 0, name)
+ ELIF 2 * refinement deklarationen - 1 < refinement aufrufe
+ THEN report referencer error (10, 0, name)
+ FI
+ FI.
+END PROC ggf referencer fehlermeldung;
+
+INT PROC nr (INT CONST ende):
+ INT VAR von :: ende - 1;
+ WHILE von > 0 AND ((dummy SUB von) >= "0" AND (dummy SUB von) <= "9") REP
+ von DECR 1
+ END REP;
+ int (subtext (dummy, von + 1, ende - 1))
+END PROC nr;
+END PACKET referencer2;
+
+(*
+REP
+ referencer ("ref fehler");
+ edit ("ref fehler.r");
+UNTIL no ("nochmal") END REP*)
+
diff --git a/system/std.zusatz/1.8.7/src/reporter b/system/std.zusatz/1.8.7/src/reporter
new file mode 100644
index 0000000..4febc32
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/reporter
@@ -0,0 +1,531 @@
+(* ------------------- VERSION 12 vom 06.08.86 -------------------- *)
+PACKET reporter routines DEFINES generate counts,
+ count on,
+ count off,
+ generate reports,
+ eliminate reports,
+ assert,
+ report on,
+ report off,
+ report:
+
+(* Programm zur Ablaufverfolgung von ELAN Programmen. Das Programm
+ verfolgt Prozedur- und Refinementaufrufe ('trace') und erstellt
+ eine Haeufigkeitszaehlung ('count') und beachtet 'assertions'.
+ Autor: Rainer Hahn *)
+
+FILE VAR input file;
+
+INT VAR zeilen nr,
+ type;
+
+TEXT VAR zeile,
+ dummy,
+ dummy1,
+ symbol;
+
+LET quadro fis = "####",
+ triple fis = "###",
+ double fis = "##",
+ tag = 1,
+ bold = 2;
+
+DATASPACE VAR ds := nilspace;
+BOUND ROW max STRUCT (INT anzahl, BOOL proc) VAR zaehlwerk;
+
+LET max = 3000;
+
+(******************* gen report-Routinen ******************************)
+
+PROC generate reports:
+ generate reports (last param)
+END PROC generate reports;
+
+PROC generate reports (TEXT CONST name):
+ disable stop;
+ gen trace statements (name);
+ IF is error AND error message = "ende"
+ THEN clear error;
+ last param (name)
+ FI;
+ to line (input file, 1);
+ enable stop.
+END PROC generate reports;
+
+PROC gen trace statements (TEXT CONST name):
+ enable stop;
+ IF exists (name)
+ THEN input file := sequential file (modify, name)
+ ELSE errorstop ("input file does not exist")
+ FI;
+ input file modifizieren
+END PROC gen trace statements;
+
+(*************************** Test file modifizieren *****************)
+
+PROC input file modifizieren:
+ zeilen nr := 1;
+ to line (input file, 1);
+ col (input file, 1);
+ REP
+ lese zeile;
+ IF triple fis symbol
+ THEN wandele in quadro fis
+ FI;
+ IF proc oder op symbol
+ THEN verarbeite operator oder prozedurkopf
+ ELIF refinement symbol
+ THEN verarbeite ggf refinements
+ FI;
+ vorwaerts
+ END REP.
+
+triple fis symbol:
+ pos (zeile, triple fis) > 0 AND
+ (pos (zeile, triple fis) <> pos (zeile, quadro fis)).
+
+wandele in quadro fis:
+ change all (zeile, triple fis, quadro fis);
+ write record (input file, zeile).
+
+proc oder op symbol:
+ pos (zeile, "PROC") > 0 OR pos (zeile, "OP") > 0.
+
+verarbeite operator oder prozedurkopf:
+ scan (zeile);
+ symbol lesen;
+ IF symbol = "PROC" OR symbol = "OP"
+ THEN
+ ELIF symbol = "END"
+ THEN LEAVE verarbeite operator oder prozedurkopf
+ ELIF type = bold
+ THEN next symbol (symbol, type);
+ IF NOT (symbol = "PROC" OR symbol = "OP")
+ THEN LEAVE verarbeite operator oder prozedurkopf
+ FI
+ ELSE LEAVE verarbeite operator oder prozedurkopf
+ FI;
+ scanne kopf;
+ insertiere trace anweisung.
+
+scanne kopf:
+ dummy := double fis;
+ dummy CAT "report(""";
+ dummy CAT text (line no (input file) + 1);
+ dummy CAT ": ";
+ dummy CAT symbol; (* PROC oder OP *)
+ dummy CAT " ";
+ symbol lesen;
+ dummy CAT symbol;
+ fuege bis namens ende an;
+ dummy CAT " ";
+ ueberlese ggf parameterliste.
+
+fuege bis namens ende an:
+ REP
+ symbol lesen;
+ IF symbol = "(" OR symbol = ":"
+ THEN LEAVE fuege bis namensende an
+ FI;
+ dummy CAT symbol
+ END REP.
+
+ueberlese ggf parameterliste:
+ WHILE symbol <> ":" REP
+ symbol lesen
+ END REP.
+
+insertiere trace anweisung:
+ WHILE pos (zeile, ":") = 0 REP
+ vorwaerts;
+ lese zeile
+ END REP;
+ schreibe zeile mit report statement.
+
+refinement symbol:
+ INT CONST point pos := pos (zeile, ".") ;
+ point pos > 0 AND point pos >= length (zeile) - 1.
+
+verarbeite ggf refinements:
+ ueberlies leere zeilen ;
+ IF ist wirklich refinement
+ THEN insertiere report fuer refinement
+ FI .
+
+ueberlies leere zeilen :
+ REP
+ vorwaerts;
+ lese zeile
+ UNTIL pos (zeile, ""33"", ""254"", 1) > 0 PER .
+
+ist wirklich refinement :
+ scan (zeile) ;
+ next symbol (symbol, type) ;
+ next symbol (symbol) ;
+ symbol = ":" AND type = tag .
+
+insertiere report fuer refinement:
+ dummy := double fis;
+ dummy CAT "report("" ";
+ dummy CAT text (line no (input file) + 1);
+ dummy CAT ": ";
+ dummy1 := subtext (zeile, 1, pos (zeile, ":") - 1);
+ dummy CAT dummy1;
+ schreibe zeile mit report statement
+END PROC input file modifizieren;
+
+PROC schreibe zeile mit report statement:
+ dummy CAT """);";
+ dummy CAT double fis;
+ IF doppelpunkt steht am ende der zeile
+ THEN vorwaerts;
+ insert record (input file);
+ write record (input file, dummy)
+ ELSE insert char (dummy, ":", 1);
+ change (zeile, ":", dummy);
+ write record (input file, zeile)
+ FI.
+
+doppelpunkt steht am ende der zeile:
+ (zeile SUB length (zeile)) = ":" OR (zeile SUB length (zeile) - 1) = ":".
+END PROC schreibe zeile mit report statement;
+
+PROC symbol lesen:
+ next symbol (symbol, type);
+ IF ende der zeile gescannt
+ THEN vorwaerts;
+ lese zeile;
+ continue scan (zeile);
+ next symbol (symbol, type)
+ FI.
+
+ende der zeile gescannt:
+ type >= 7.
+END PROC symbol lesen;
+
+PROC vorwaerts:
+ IF eof (input file)
+ THEN errorstop ("ende")
+ FI;
+ down (input file);
+ IF eof (input file)
+ THEN errorstop ("ende")
+ FI
+END PROC vorwaerts;
+
+PROC lese zeile:
+ read record (input file, zeile);
+ cout (zeilen nr);
+ zeilen nr INCR 1
+END PROC lese zeile;
+
+(************************ eliminate reports-Routinen ******************)
+
+PROC eliminate reports:
+ eliminate reports (last param)
+END PROC eliminate reports;
+
+PROC eliminate reports (TEXT CONST name):
+ disable stop;
+ eliminate statements (name);
+ IF is error AND error message = "ende"
+ THEN clear error;
+ last param (name)
+ FI;
+ to line (input file, 1);
+ enable stop.
+END PROC eliminate reports;
+
+PROC eliminate statements (TEXT CONST name):
+ enable stop;
+ IF exists (name)
+ THEN input file := sequential file (modify, name)
+ ELSE errorstop ("input file does not exist")
+ FI;
+ statements entfernen.
+
+statements entfernen:
+ to line (input file, 1);
+ col (input file, 1);
+ zeilen nr := 1;
+ WHILE NOT eof (input file) REP
+ lese zeile;
+ IF pos (zeile, double fis) > 0
+ THEN eliminiere zeichenketten in dieser zeile
+ ELSE vorwaerts
+ FI
+ END REP.
+
+eliminiere zeichenketten in dieser zeile:
+ INT VAR anfang := pos (zeile, double fis);
+ WHILE es ist noch etwas zu eliminieren REP
+ IF es ist ein quadro fis
+ THEN wandele es in ein triple fis
+ ELIF es ist ein triple fis
+ THEN lass diese sequenz stehen
+ ELSE entferne zeichenkette
+ FI
+ END REP;
+ IF zeile ist jetzt leer
+ THEN delete record (input file)
+ ELSE write record (input file, zeile);
+ vorwaerts
+ FI.
+
+es ist noch etwas zu eliminieren:
+ anfang > 0.
+
+es ist ein quadro fis:
+ pos (zeile, quadro fis, anfang) = anfang.
+
+wandele es in ein triple fis:
+ delete char (zeile, anfang);
+ anfang := pos (zeile, double fis, anfang + 3).
+
+es ist ein triple fis:
+ pos (zeile, triple fis, anfang) = anfang.
+
+lass diese sequenz stehen:
+ anfang := pos (zeile, triple fis, anfang + 1) + 3.
+
+entferne zeichenkette:
+ INT VAR end := pos (zeile, double fis, anfang+2) ;
+ IF end > 0
+ THEN change (zeile, anfang, end + 1, "");
+ anfang := pos (zeile, double fis, anfang)
+ ELSE anfang := pos (zeile, double fis, anfang+2)
+ FI .
+
+zeile ist jetzt leer:
+ pos (zeile, ""33"", ""254"", 1) = 0.
+END PROC eliminate statements;
+
+(********************** Trace-Routinen *******************************)
+
+FILE VAR trace file;
+
+BOOL VAR zaehlwerk initialisiert :: FALSE,
+ trace on,
+ haeufigkeit on;
+
+PROC report (TEXT CONST message):
+ IF exists ("TRACE")
+ THEN
+ ELSE trace on := TRUE;
+ haeufigkeit on := FALSE;
+ FI;
+ BOOL CONST ist prozedur ::
+ pos (message, "PROC") > 0 OR pos (message, "OP") > 0;
+ trace file := sequential file (modify, "TRACE");
+ IF lines (trace file) <= 0
+ THEN insert record (trace file);
+ write record (trace file, "")
+ ELSE to line (trace file, lines (trace file));
+ read record (trace file, dummy);
+ IF dummy <> ""
+ THEN down (trace file);
+ insert record (trace file);
+ write record (trace file, "")
+ FI
+ FI;
+ IF trace on
+ THEN write record (trace file, message);
+ down (trace file);
+ insert record (trace file);
+ write record (trace file, "")
+ FI;
+ IF haeufigkeit on
+ THEN haeufigkeits zaehlung
+ FI.
+
+haeufigkeits zaehlung:
+ hole zeilen nr;
+ zaehle mit.
+
+hole zeilen nr:
+ INT CONST von pos :: pos (message, ""33"", ""254"", 1);
+ zeilen nr :=
+ int (subtext (message, von pos, pos (message, ":", von pos + 1) - 1)).
+
+zaehle mit:
+ IF last conversion ok AND zeilen nr > 0 AND zeilen nr <= max
+ THEN zaehlwerk [zeilen nr] . anzahl INCR 1;
+ zaehlwerk [zeilen nr] . proc := ist prozedur
+ FI
+END PROC report;
+
+PROC report (TEXT CONST message, INT CONST value):
+ report (message, text (value))
+END PROC report;
+
+PROC report (TEXT CONST message, REAL CONST value):
+ report (message, text (value))
+END PROC report;
+
+PROC report (TEXT CONST message, TEXT CONST value):
+ dummy1 := message;
+ dummy1 CAT ": ";
+ dummy1 CAT value;
+ report (dummy1)
+END PROC report;
+
+PROC report (TEXT CONST message, BOOL CONST value):
+ dummy1 := message;
+ dummy1 CAT ": ";
+ IF value
+ THEN dummy1 CAT "TRUE"
+ ELSE dummy1 CAT "FALSE"
+ FI;
+ report (dummy1)
+END PROC report;
+
+PROC report on:
+ trace on := TRUE;
+ dummy1 := "REPORT ---> ON";
+ report (dummy1)
+END PROC report on;
+
+PROC report off:
+ dummy1 := "REPORT ---> OFF";
+ report (dummy1);
+ trace on := FALSE;
+END PROC report off;
+
+PROC assert (BOOL CONST value):
+ assert ("", value)
+END PROC assert;
+
+PROC assert (TEXT CONST message, BOOL CONST value):
+ dummy1 := "ASSERTION:";
+ dummy1 CAT message;
+ dummy1 CAT " ---> ";
+ IF value
+ THEN dummy1 CAT "TRUE"
+ ELSE line;
+ put ("ASSERTION:");
+ put (message);
+ put ("---> FALSE");
+ line;
+ IF yes ("weiter")
+ THEN dummy1 CAT "FALSE"
+ ELSE errorstop ("assertion failed")
+ FI
+ FI;
+ report (dummy1)
+END PROC assert;
+
+(************************** haeufigkeits-zaehlung ****************)
+
+PROC count on:
+ report ("COUNT ---> ON");
+ haeufigkeit on := TRUE;
+ initialisiere haeufigkeit.
+
+initialisiere haeufigkeit:
+ INT VAR i;
+ forget (ds);
+ ds := nilspace;
+ zaehlwerk initialisiert := TRUE;
+ zaehlwerk := ds;
+ FOR i FROM 1 UPTO max REP
+ zaehlwerk [i] . anzahl := 0
+ END REP
+END PROC count on;
+
+PROC count off:
+ report ("COUNT ---> OFF");
+ haeufigkeit on := FALSE
+END PROC count off;
+
+PROC generate counts:
+ generate counts (last param)
+END PROC generate counts;
+
+PROC generate counts (TEXT CONST name):
+ disable stop;
+ insert counts (name);
+ last param (name);
+ to line (input file, 1);
+ enable stop.
+END PROC generate counts;
+
+PROC insert counts (TEXT CONST name):
+ enable stop;
+ IF exists (name)
+ THEN input file := sequential file (modify, name);
+ col (input file, 1)
+ ELSE errorstop ("input file does not exist")
+ FI;
+ IF NOT zaehlwerk initialisiert
+ THEN errorstop ("count nicht eingeschaltet")
+ FI;
+ counts insertieren;
+ dataspace loeschen;
+ statistik ausgeben.
+
+counts insertieren:
+ REAL VAR gesamt aufrufe :: 0.0,
+ proc aufrufe :: 0.0,
+ andere aufrufe :: 0.0;
+ zeilen nr := 1;
+ WHILE zeilen nr <= lines (input file) REP
+ cout (zeilen nr);
+ IF zaehlwerk [zeilen nr] . anzahl > 0
+ THEN anzahl aufrufe in die eingabe zeile einfuegen;
+ aufrufe mitzaehlen
+ FI;
+ zeilen nr INCR 1
+ END REP.
+
+anzahl aufrufe in die eingabe zeile einfuegen:
+ to line (input file, zeilen nr);
+ read record (input file, zeile);
+ dummy := double fis;
+ dummy CAT text (zaehlwerk [zeilen nr] . anzahl);
+ dummy CAT double fis;
+ change (zeile, 1, 0, dummy);
+ write record (input file, zeile).
+
+aufrufe mitzaehlen:
+ gesamt aufrufe INCR real (zaehlwerk [zeilen nr] . anzahl);
+ IF zaehlwerk [zeilen nr] . proc
+ THEN proc aufrufe INCR real (zaehlwerk [zeilen nr] . anzahl)
+ ELSE andere aufrufe INCR real (zaehlwerk [zeilen nr] . anzahl)
+ FI.
+
+dataspace loeschen:
+ zaehlwerk initialisiert := FALSE;
+ forget (ds).
+
+statistik ausgeben:
+ line (2);
+ put ("Anzahl der Gesamtaufrufe:");
+ ggf int put (gesamt aufrufe);
+ line;
+ put ("davon:");
+ line;
+ ggf int put (proc aufrufe); put ("Prozeduren oder Operatoren");
+ line;
+ ggf int put (andere aufrufe); put ("Refinements und andere");
+ line.
+END PROC insert counts;
+
+PROC ggf int put (REAL CONST wert):
+ IF wert >= real (maxint)
+ THEN put (wert)
+ ELSE put (int (wert))
+ FI
+END PROC ggf int put;
+END PACKET reporter routines;
+(*
+REP
+ IF exists ("rep fehler")
+ THEN copy ("rep fehler", "zzz")
+ ELSE errorstop ("rep fehler exisitiert nicht")
+ FI;
+ generate reports ("zzz");
+ edit("zzz");
+ forget ("zzz")
+UNTIL no ("nochmal") END REP;
+edit("reporter")*)
+
diff --git a/system/std.zusatz/1.8.7/src/scheduler b/system/std.zusatz/1.8.7/src/scheduler
new file mode 100644
index 0000000..cba48e0
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/scheduler
@@ -0,0 +1,420 @@
+
+PACKET std schedule strategy DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 15.10.82 *)
+ strategic decision :
+
+
+PROC strategic decision
+ (INT CONST foreground workers, background workers,
+ REAL CONST fore cpu load, back cpu load, paging load,
+ INT VAR lowest activation prio, max background tasks) :
+
+ IF no background permitted
+ THEN lowest activation prio := 0 ;
+ max background tasks := 0
+ ELSE lowest activation prio := 10 ;
+ select max background tasks
+ FI .
+
+no background permitted :
+ foreground workers > 0 AND fore cpu load > 0.03 .
+
+select max background tasks :
+ IF fore cpu load > 0.01
+ THEN max background tasks := 1
+ ELIF paging load < 0.07
+ THEN max background tasks := 3
+ ELIF paging load < 0.15
+ THEN max background tasks := 2
+ ELSE max background tasks := 1
+ FI .
+
+ENDPROC strategic decision ;
+
+ENDPACKET std schedule strategy ;
+
+
+ (* Autor: J.Liedtke*)
+PACKET eumelmeter DEFINES (* Stand: 11.10.83 *)
+
+ init log ,
+ log :
+
+
+LET snapshot interval = 590.0 ;
+
+REAL VAR next snapshot time ,
+ time , timex ,
+ paging wait , paging wait x ,
+ paging busy , paging busy x ,
+ fore cpu , fore cpu x ,
+ back cpu , back cpu x ,
+ system cpu , system cpu x ,
+ delta t ;
+INT VAR storage max, used ;
+TEXT VAR record ;
+
+PROC init log :
+
+ time := clock (1) ;
+ paging wait := clock (2) ;
+ paging busy := clock (3) ;
+ fore cpu := clock (4) ;
+ back cpu := clock (5) ;
+ system cpu := clock (6) ;
+ next snapshot time := time + snapshot interval
+
+ENDPROC init log ;
+
+PROC log (INT CONST active terminals, active background) :
+
+ new snapshot time if was clock reset ;
+ IF clock (1) >= next snapshot time
+ THEN save values ;
+ get new values ;
+ create stat record ;
+ put log (record) ;
+ define next snapshot time
+ FI .
+
+new snapshot time if was clock reset :
+ IF clock (1) < next snapshot time - snapshot interval
+ THEN next snapshot time := clock (1)
+ FI .
+
+save values :
+ time x := time ;
+ paging wait x := paging wait ;
+ paging busy x := paging busy ;
+ fore cpu x := fore cpu ;
+ back cpu x := back cpu ;
+ system cpu x := system cpu .
+
+get new values :
+ time := clock (1) ;
+ paging wait := clock (2) ;
+ paging busy := clock (3) ;
+ fore cpu := clock (4) ;
+ back cpu := clock (5) ;
+ system cpu := clock (6) ;
+ storage (storage max, used) .
+
+create stat record :
+ record := text (used, 5) ;
+ record CAT text (active terminals,3) ;
+ record CAT text (active background,3) ;
+ delta t := (time - time x) ;
+ percent (paging wait, paging wait x) ;
+ percent (paging busy, paging busy x) ;
+ percent (fore cpu, fore cpu x) ;
+ percent (back cpu, back cpu x) ;
+ percent (system cpu, system cpu x) ;
+ percent (last, 0.0) ;
+ percent (nutz, 0.0) .
+
+last : paging wait + paging busy + fore cpu + back cpu + system cpu
+ - paging waitx - paging busyx - fore cpux - back cpux - system cpux .
+
+nutz : time - paging wait - system cpu
+ - timex + paging waitx + system cpux .
+
+define next snapshot time :
+ next snapshot time := time + snapshot interval .
+
+ENDPROC log ;
+
+PROC percent (REAL CONST neu, alt ) :
+
+ record CAT text ( (neu-alt) / delta t * 100.0, 6,1) + "%"
+
+ENDPROC percent ;
+
+ENDPACKET eumelmeter ;
+
+
+
+PACKET background que manager DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 15.10.82 *)
+ into background que ,
+ delete from background que ,
+ get first from background que ,
+ get next from background que :
+
+LET que size = 100 ,
+ ENTRY = STRUCT (TASK task, INT class) ;
+
+INT VAR end of que := 0 ,
+ actual entry pos ;
+
+ROW que size ENTRY VAR que ;
+
+
+PROC into background que (TASK CONST task) :
+
+ INT VAR class := prio (task) ;
+ IF end of que = que size
+ THEN delete all not existing tasks
+ FI ;
+ check whether already in que ;
+ IF already in que
+ THEN IF in same class
+ THEN LEAVE into background que
+ ELSE delete from background que (task) ;
+ into background que (task)
+ FI
+ ELSE insert new entry
+ FI .
+
+check whether already in que :
+ INT VAR entry pos := 1 ;
+ WHILE entry pos <= end of que REP
+ IF que (entry pos).task = task
+ THEN LEAVE check whether already in que
+ FI ;
+ entry pos INCR 1
+ PER .
+
+already in que : entry pos <= end of que .
+
+in same class : que (entry pos).class = class .
+
+insert new entry :
+ end of que INCR 1 ;
+ que (end of que) := ENTRY:( task, class ) .
+
+delete all not existing tasks :
+ INT VAR j ;
+ FOR j FROM 1 UPTO end of que REP
+ TASK VAR examined := que (j).task ;
+ IF NOT exists (examined)
+ THEN delete from background que (examined)
+ FI
+ PER .
+
+ENDPROC into background que ;
+
+PROC delete from background que (TASK CONST task) :
+
+ search for entry ;
+ IF entry found
+ THEN delete entry ;
+ update actual entry pos
+ FI .
+
+search for entry :
+ INT VAR entry pos := 1 ;
+ WHILE entry pos <= end of que REP
+ IF que (entry pos).task = task
+ THEN LEAVE search for entry
+ FI ;
+ entry pos INCR 1
+ PER .
+
+entry found : entry pos <= end of que .
+
+delete entry :
+ INT VAR i ;
+ FOR i FROM entry pos UPTO end of que - 1 REP
+ que (i) := que (i+1)
+ PER ;
+ end of que DECR 1 .
+
+update actual entry pos :
+ IF actual entry or following one deleted
+ THEN actual entry pos DECR 1
+ FI .
+
+actual entry or following one deleted :
+ entry pos >= actual entry pos .
+
+ENDPROC delete from background que ;
+
+PROC get first from background que (TASK VAR task, INT CONST lowest class) :
+
+ actual entry pos := 0 ;
+ get next from background que (task, lowest class)
+
+ENDPROC get first from background que ;
+
+PROC get next from background que (TASK VAR task, INT CONST lowest class) :
+
+ search next entry of permitted class ;
+ IF actual entry pos <= end of que
+ THEN task := que (actual entry pos).task
+ ELSE task := niltask
+ FI .
+
+search next entry of permitted class :
+ REP
+ actual entry pos INCR 1
+ UNTIL actual entry pos > end of que
+ COR que (actual entry pos).class <= lowest class PER.
+
+ENDPROC get next from background que ;
+
+ENDPACKET background que manager ;
+
+
+
+PACKET scheduler DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 09.12.82 *)
+ scheduler :
+
+
+LET std background prio = 7 ,
+ highest background prio = 5 ,
+ long slice = 6000 ,
+ short slice = 600 ,
+ blocked busy = 4 ;
+
+INT VAR slice ,
+ foreground workers ,
+ background workers ;
+
+BOOL VAR is logging ;
+
+REAL VAR fore cpu load , back cpu load , paging load ;
+
+
+access catalogue ;
+TASK CONST ur task := brother (supervisor) ;
+
+TASK VAR actual task ;
+
+
+PROC scheduler :
+ IF yes ("mit eumelmeter")
+ THEN is logging := TRUE
+ ELSE is logging := FALSE
+ FI ;
+ task password ("-") ;
+ break ;
+ set autonom ;
+ command dialogue (FALSE) ;
+ forget ("scheduler", quiet) ;
+ disable stop;
+ REP scheduler operation;
+ clear error
+ PER;
+
+END PROC scheduler;
+
+PROC scheduler operation:
+ enable stop;
+ IF is logging
+ THEN init log
+ FI;
+ slice := short slice ;
+ init system load moniting ;
+ REP
+ pause (slice) ;
+ monit system load ;
+ look at all active user tasks and block background workers ;
+ activate next background workers if possible ;
+ IF is logging
+ THEN log (foreground workers, background workers)
+ FI
+ PER .
+
+init system load moniting :
+ REAL VAR
+ time x := clock (1) ,
+ fore cpu x := clock (4) ,
+ back cpu x := clock (5) ,
+ paging x := clock (2) + clock (3) .
+
+monit system load :
+ REAL VAR interval := clock (1) - time x ;
+ fore cpu load := (clock (4) - fore cpu x) / interval ;
+ back cpu load := (clock (5) - back cpu x) / interval ;
+ paging load := (clock (2) + clock (3) - paging x) / interval ;
+ time x := clock (1) ;
+ fore cpu x := clock (4) ;
+ back cpu x := clock (5) ;
+ paging x := clock (2) + clock (3) .
+
+ENDPROC scheduler operation;
+
+PROC look at all active user tasks and block background workers :
+
+ foreground workers := 0 ;
+ background workers := 0 ;
+ actual task := myself ;
+ next active (actual task) ;
+ WHILE NOT (actual task = myself) REP
+ IF actual task < ur task
+ THEN look at this task
+ FI ;
+ next active (actual task)
+ END REP .
+
+look at this task :
+ IF channel (actual task) >= 0
+ THEN foreground workers INCR 1
+ ELSE background workers INCR 1 ;
+ block actual task if simple worker
+ FI .
+
+block actual task if simple worker :
+ IF son (actual task) = niltask
+ THEN pause (5) ;
+ block (actual task) ;
+ IF status (actual task) = blocked busy
+ THEN set background prio ;
+ into background que (actual task)
+ ELIF prio (actual task) < highest background prio
+ THEN unblock (actual task)
+ FI
+ FI .
+
+set background prio :
+ IF prio (actual task) < highest background prio
+ THEN prio (actual task, std background prio)
+ FI .
+
+ENDPROC look at all active user tasks and block background workers ;
+
+PROC activate next background workers if possible :
+
+ INT VAR lowest activation prio ,
+ max background workers ,
+ active background workers := 0 ;
+
+ strategic decision (foreground workers, background workers,
+ fore cpu load, back cpu load, paging load,
+ lowest activation prio, max background workers) ;
+
+ IF background permitted
+ THEN try to activate background workers
+ FI ;
+ IF active background workers > 0
+ THEN slice := short slice
+ ELSE slice := long slice
+ FI .
+
+background permitted : max background workers > 0 .
+
+try to activate background workers :
+ get first from background que (actual task, lowest activation prio) ;
+ IF NOT is niltask (actual task)
+ THEN delete from background que (actual task)
+ FI ;
+
+ WHILE active background workers < max background workers REP
+ IF is niltask (actual task)
+ THEN LEAVE try to activate background workers
+ ELIF status (actual task) <> blocked busy
+ THEN delete from background que (actual task)
+ ELSE
+ unblock (actual task) ;
+ active background workers INCR 1
+ FI ;
+ get next from background que (actual task, lowest activation prio)
+ PER .
+
+ENDPROC activate next background workers if possible ;
+
+ENDPACKET scheduler ;
+
+scheduler;
+
diff --git a/system/std.zusatz/1.8.7/src/spool cmd b/system/std.zusatz/1.8.7/src/spool cmd
new file mode 100644
index 0000000..9b43d36
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/spool cmd
@@ -0,0 +1,178 @@
+PACKET spool cmd (* Autor : R. Ruland *)
+ (* Stand : 13.08.87 *)
+ DEFINES
+ spool control password,
+
+ kill spool,
+ first spool,
+ start spool,
+ stop spool,
+ halt spool,
+ wait for halt :
+
+LET error nak = 2 ,
+
+ entry line code = 23 ,
+ killer code = 24 ,
+ first code = 25 ,
+ start code = 26 ,
+ stop code = 27 ,
+ halt code = 28 ,
+ wait for halt code = 29 ;
+
+DATASPACE VAR ds;
+
+BOUND STRUCT (TEXT entry line, INT index, TEXT actual entries, password) VAR control msg;
+BOUND TEXT VAR error msg;
+INT VAR reply;
+
+INITFLAG VAR in this task := FALSE;
+BOOL VAR dialogue;
+TEXT VAR control password, password;
+
+control password := "";
+
+PROC spool control password (TEXT CONST new password):
+
+ IF on line THEN say (""3""13""5"") FI;
+ disable stop;
+ do ("enter spool control password (""" + new password + """)");
+ clear error;
+ no do again;
+ cover tracks;
+ cover tracks (control password);
+ control password := new password;
+
+END PROC spool control password;
+
+
+PROC call spool (INT CONST op code, TEXT CONST name, TASK CONST spool) :
+
+ dialogue := command dialogue;
+ password := write password;
+ password CAT "/";
+ password CAT read password;
+ disable stop;
+ command dialogue (FALSE);
+ enter password (control password);
+ command dialogue (dialogue);
+ call (op code, name, spool);
+ command dialogue (FALSE);
+ enter password (password);
+ command dialogue (dialogue);
+
+END PROC call spool;
+
+
+PROC start spool (TASK CONST spool) :
+
+ enable stop;
+ call spool (halt code, "", spool);
+ call spool (start code, "", spool);
+
+END PROC start spool;
+
+
+PROC start spool (TASK CONST spool, INT CONST new channel) :
+
+ enable stop;
+ call spool (halt code, "", spool);
+ call spool (start code, text (new channel), spool);
+
+END PROC start spool;
+
+
+PROC stop spool (TASK CONST spool) :
+
+ call spool (stop code, "", spool);
+
+END PROC stop spool;
+
+PROC stop spool (TASK CONST spool, TEXT CONST deactive msg) :
+
+ call spool (stop code, deactive msg, spool);
+
+END PROC stop spool;
+
+
+PROC halt spool (TASK CONST spool) :
+
+ call spool (halt code, "", spool);
+
+END PROC halt spool;
+
+PROC halt spool (TASK CONST spool, TEXT CONST deactive msg) :
+
+ call spool (halt code, deactive msg, spool);
+
+END PROC halt spool;
+
+
+PROC wait for halt (TASK CONST spool) :
+
+ call spool (wait for halt code, "", spool);
+
+END PROC wait for halt;
+
+PROC wait for halt (TASK CONST spool, TEXT CONST deactive msg) :
+
+ call spool (wait for halt code, deactive msg, spool);
+
+END PROC wait for halt;
+
+
+PROC control spool (TASK CONST spool, INT CONST control code,
+ TEXT CONST question, BOOL CONST leave) :
+
+ enable stop;
+ initialize control msg;
+ WHILE valid spool entry
+ REP IF control question THEN control spool entry FI PER;
+
+ . initialize control msg :
+ IF NOT initialized (in this task) THEN ds := nilspace FI;
+ forget (ds); ds := nilspace; control msg := ds;
+ control msg. entry line := "";
+ control msg. password := control password;
+ control msg. index := 0;
+ say (""13""10"");
+
+ . valid spool entry :
+ call (spool, entry line code, ds, reply);
+ IF reply = error nak
+ THEN error msg := ds;
+ errorstop (error msg);
+ FI;
+ control msg. index <> 0
+
+ . control question :
+ say (control msg. entry line);
+ yes (question)
+
+ . control spool entry :
+ call (spool, control code, ds, reply);
+ IF reply = error nak
+ THEN error msg := ds;
+ errorstop (error msg);
+ FI;
+ IF leave THEN LEAVE control spool FI;
+
+END PROC control spool;
+
+
+PROC kill spool (TASK CONST spool) :
+
+ control spool (spool, killer code, " loeschen", FALSE)
+
+END PROC kill spool;
+
+
+PROC first spool (TASK CONST spool) :
+
+ control spool (spool, first code, " als erstes", TRUE)
+
+END PROC first spool;
+
+
+END PACKET spool cmd;
+
diff --git a/system/std.zusatz/1.8.7/src/spool manager b/system/std.zusatz/1.8.7/src/spool manager
new file mode 100644
index 0000000..6b4fe55
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/spool manager
@@ -0,0 +1,1058 @@
+PACKET spool manager DEFINES (* Autor : R. Ruland *)
+ (* Stand : 23.02.88 *)
+
+ spool manager ,
+
+ server channel ,
+ spool duty,
+ station only,
+ auto stop,
+ enter spool control password,
+ spool control password,
+
+ start spool,
+ stop spool,
+ halt spool,
+ kill spool,
+ first spool,
+ spool entry line,
+ number spool entries,
+ spool status,
+ server task,
+ clear spool,
+ list spool,
+ :
+
+LET que size = 200 ,
+
+ ack = 0 ,
+ nak = 1 ,
+ error nak = 2 ,
+ second phase ack = 5 ,
+ false code = 6 ,
+
+ fetch code = 11 ,
+ save code = 12 ,
+ exists code = 13 ,
+ erase code = 14 ,
+ list code = 15 ,
+ all code = 17 ,
+ param fetch code = 21 ,
+ file save code = 22 ,
+ entry line code = 23 ,
+ killer code = 24 ,
+ first code = 25 ,
+ start code = 26 ,
+ stop code = 27 ,
+ halt code = 28 ,
+ wait for halt code = 29 ,
+ help code = 49 ,
+ continue code = 100 ,
+
+ control codes = ""23""24""25""26""27""28""29"" ,
+
+ file type = 1003 ,
+ help file name = "help";
+
+LET begin char = ""0"",
+ end char = ""1"";
+
+LET PARAMS = STRUCT (TEXT name, userid, password, sendername, INT station);
+
+BOUND ROW que size STRUCT (PARAMS ds params, TEXT entry line) VAR que;
+
+ ROW que size DATASPACE VAR que space;
+
+PARAMS VAR save params;
+
+DATASPACE VAR que ds, global ds;
+
+FILE VAR file;
+
+INT VAR last order, reply, old heap size, que index, fetch index,
+ station by start, begin pos, end pos, order task station, sp channel;
+
+TEXT VAR que entries, free entries, order task name, buffer, deactive message,
+ error message buffer, sp duty, start time, control password;
+
+BOOL VAR server is waiting, stop cmd pending, start cmd pending,
+ auto stop pending, stat only;
+
+TASK VAR last order task, server, calling parent, task in control;
+
+INITFLAG VAR in this task := FALSE, init que space := FALSE;
+
+BOUND STRUCT (TEXT name, userid, password) VAR msg;
+BOUND STRUCT (TEXT entry line, INT index, TEXT actual entries, password) VAR control msg;
+BOUND PARAMS VAR fetch msg;
+BOUND THESAURUS VAR all msg;
+BOUND TEXT VAR error msg;
+
+
+. que is empty : que entries = ""
+. que is full : free entries = ""
+. number entries : LENGTH que entries
+
+. first index : code (que entries SUB 1)
+. list index : code (que entries SUB que index)
+. last index : code (que entries SUB number entries)
+
+. fetch entry : que (fetch index)
+. list entry : que (list index)
+. last entry : que (last index)
+
+. was define station : station by start <> station (myself)
+. is valid fetch entry : fetch index > 0
+.;
+
+INT VAR command index , params ;
+TEXT VAR param 1, param 2 ;
+LET spool command list = "start:1.01stop:3.0halt:4.0first:5.0killer:6.0";
+
+sp channel := 0;
+sp duty := "";
+deactive message := "";
+stat only := FALSE;
+auto stop pending := FALSE;
+task in control := supervisor;
+control password := "-";
+
+
+PROC server channel (INT CONST channel nr) :
+ IF channel nr <= 0 OR channel nr >= 33
+ THEN errorstop ("falsche Kanalangabe") FI;
+ sp channel := channel nr;
+END PROC server channel;
+
+INT PROC server channel : sp channel END PROC server channel;
+
+
+PROC station only (BOOL CONST flag) :
+ stat only := flag
+END PROC station only;
+
+BOOL PROC station only : stat only END PROC station only;
+
+
+PROC auto stop (BOOL CONST flag) :
+ auto stop pending := flag
+END PROC auto stop;
+
+BOOL PROC auto stop : auto stop pending END PROC auto stop;
+
+
+PROC spool duty (TEXT CONST duty) :
+ sp duty := duty;
+END PROC spool duty;
+
+TEXT PROC spool duty : sp duty END PROC spool duty;
+
+
+PROC enter spool control password (TEXT CONST new password):
+ disable stop;
+ cover tracks;
+ cover tracks (control password);
+ control password := new password;
+END PROC enter spool control password;
+
+PROC spool control password (TEXT CONST new password):
+ IF on line THEN say (""3""13""5"") FI;
+ enter spool control password (new password);
+END PROC spool control password;
+
+
+PROC spool manager (PROC server start) :
+ spool manager (PROC (DATASPACE VAR, INT CONST,
+ INT CONST, TASK CONST) spool manager,
+ PROC server start, TRUE)
+END PROC spool manager;
+
+
+PROC spool manager (PROC server start, BOOL CONST initial start) :
+ spool manager (PROC (DATASPACE VAR, INT CONST,
+ INT CONST, TASK CONST) spool manager,
+ PROC server start, initial start)
+END PROC spool manager;
+
+
+PROC spool manager (PROC (DATASPACE VAR, INT CONST,
+ INT CONST, TASK CONST) spool,
+ PROC server start,
+ BOOL CONST initial start) :
+
+ set autonom;
+ break;
+ disable stop;
+ command dialogue (FALSE);
+ initialize spool manager;
+ REP start spool if necessary;
+ wait for next order;
+ IF order not allowed THEN reject order
+ ELIF is first phase THEN first phase
+ ELIF is second phase THEN second phase
+ ELSE send nak
+ FI;
+ send error if necessary;
+ collect heap garbage if necessary;
+ PER
+
+ . initialize spool manager :
+ initialize if necessary;
+ stop server;
+ erase fetch entry;
+ start cmd pending := initial start;
+ stop cmd pending := FALSE;
+ last order task := niltask;
+
+ . initialize if necessary :
+ IF NOT initialized (in this task)
+ THEN clear spool;
+ global ds := nilspace;
+ que ds := nilspace;
+ que := que ds;
+ server := niltask;
+ calling parent := niltask;
+ server is waiting := FALSE;
+ station by start := station (myself);
+ old heap size := 0;
+ error message buffer := "";
+ FI;
+
+ . start spool if necessary :
+ IF start cmd pending AND NOT stop cmd pending
+ THEN start server (PROC server start) FI;
+
+ . wait for next order :
+ INT VAR order, phase;
+ TASK VAR order task;
+ forget (global ds);
+ wait (global ds, order, order task);
+
+ . order not allowed :
+ station only CAND station (ordertask) <> station (myself) CAND
+ ( order > 255 COR pos (control codes, code (order)) = 0 )
+
+ . reject order :
+ errorstop ("kein Zugriffsrecht auf Task " + text (station(myself))
+ + "/""" + name(myself) + """")
+
+ . is first phase :
+ order <> second phase ack
+
+ . first phase :
+ phase := 1;
+ last order := order;
+ last order task := order task;
+ spool (global ds, order, phase, order task);
+
+ . is second phase :
+ order task = last order task
+
+ . second phase :
+ phase INCR 1 ;
+ order := last order;
+ spool (global ds, order, phase, order task);
+
+ . send nak :
+ forget (global ds);
+ global ds := nilspace;
+ send (order task, nak, global ds);
+
+ . send error if necessary :
+ IF is error
+ THEN forget (global ds);
+ global ds := nilspace;
+ error msg := global ds;
+ CONCR (error msg) := error message;
+ clear error;
+ send (order task, error nak, global ds);
+ FI;
+
+ . collect heap garbage if necessary :
+ IF heap size > old heap size + 2
+ THEN collect heap garbage;
+ old heap size := heap size;
+ FI;
+
+END PROC spool manager;
+
+
+PROC spool manager (DATASPACE VAR order ds,
+ INT CONST order, phase,
+ TASK CONST order task ):
+
+ enable stop;
+ SELECT order OF
+ CASE fetch code, help code : out of que or help
+ CASE param fetch code : send fetch params
+ CASE save code : new que entry
+ CASE file save code : new file que entry
+ CASE exists code : exists que entry
+ CASE erase code : erase que entry
+ CASE list code : send spool list
+ CASE all code : send owners ds names
+
+ CASE entry line code : send next entry line
+ CASE killer code : kill entry
+ CASE first code : make to first
+ CASE start code : start server task
+ CASE stop code : stop server task
+ CASE halt code, wait for halt code
+ : halt server task
+
+ OTHERWISE :
+
+ IF order >= continue code AND order task = supervisor
+ THEN spool monitor
+ ELSE wrong operation
+ FI;
+
+ END SELECT;
+
+. wrong operation :
+ IF order > error nak
+ THEN errorstop ("falscher Auftrag fuer Task " + text (station(myself))
+ + "/""" + name(myself) + """")
+ FI;
+
+.
+ out of que or help :
+ IF order task = server
+ THEN out of que
+ ELSE send help file
+ FI;
+
+ . out of que :
+ erase fetch entry;
+ IF stop cmd pending
+ THEN stop server
+ ELIF que is empty
+ THEN IF auto stop pending
+ THEN stop server
+ ELSE server is waiting := TRUE
+ FI;
+ ELSE send first entry;
+ FI;
+
+ . send help file :
+ check server (TRUE);
+ IF order = fetch code
+ THEN msg := order ds;
+ IF msg. name <> help file name
+ THEN errorstop ("keine Servertask") FI;
+ FI;
+ forget (order ds);
+ order ds := old (help file name);
+ send (order task, ack, order ds);
+
+.
+ send fetch params :
+ IF order task = server
+ THEN send params
+ ELSE errorstop ("keine Servertask")
+ FI;
+
+ . send params :
+ forget(order ds); order ds := nilspace;
+ fetch msg := order ds;
+ fetch msg := fetch entry. ds params;
+ send (order task, ack, order ds);
+
+.
+ new que entry :
+ IF phase = 1
+ THEN prepare into que
+ ELSE into que (order ds, order task)
+ FI;
+
+.
+ prepare into que :
+ msg := order ds ;
+ save params. name := msg.name;
+ save params. userid := msg.userid;
+ save params. password := msg.password;
+ save params. sendername := name (order task);
+ save params. station := station (order task);
+ forget (order ds); order ds := nilspace;
+ send (order task, second phase ack, order ds);
+
+.
+ new file que entry :
+ IF type (order ds) <> file type
+ THEN errorstop ("Datenraum hat falschen Typ");
+ ELSE get file params;
+ into que (order ds, order task);
+ FI;
+
+ . get file params :
+ file := sequential file (input, order ds);
+ end pos := 0;
+ next headline information (save params. name);
+ next headline information (save params. userid);
+ next headline information (save params. password);
+ next headline information (save params. sendername);
+ next headline information (buffer);
+ save params. station := int (buffer);
+ IF NOT last conversion ok
+ THEN save params. station := station (order task) FI;
+ IF save params. sendername = ""
+ THEN save params. sendername := name (order task) FI;
+ IF save params. name = ""
+ THEN IF headline (file) <> ""
+ THEN save params. name := headline (file);
+ ELSE errorstop ("Name unzulaessig")
+ FI;
+ ELSE headline (file, save params. name);
+ FI;
+
+.
+ exists que entry :
+ msg := order ds ;
+ order task name := name (order task);
+ order task station := station (order task);
+ FOR que index FROM 1 UPTO number entries
+ REP IF is entry from order task (msg. name)
+ THEN send ack;
+ LEAVE exists que entry
+ FI;
+ PER ;
+ forget (order ds); order ds := nilspace;
+ send (order task, false code, order ds)
+
+.
+ erase que entry :
+ msg := order ds ;
+ order task name := name (order task);
+ order task station := station (order task);
+ IF phase = 1
+ THEN ask for erase
+ ELSE erase entry from order task
+ FI;
+
+ . ask for erase :
+ FOR que index FROM 1 UPTO number entries
+ REP IF is entry from order task (msg. name)
+ THEN manager question ("""" + msg.name + """ loeschen", order task);
+ LEAVE erase que entry
+ FI;
+ PER ;
+ manager message ("""" + msg.name + """ existiert nicht", order task);
+
+ . erase entry from order task :
+ IF is valid que index (que index) CAND is entry from order task (msg. name)
+ THEN delete que entry;
+ LEAVE erase que entry
+ ELSE FOR que index FROM 1 UPTO number entries
+ REP IF is entry from order task (msg. name)
+ THEN delete que entry;
+ LEAVE erase que entry
+ FI;
+ PER;
+ manager message ("""" + msg.name + """ existiert nicht", order task);
+ FI;
+
+ . delete que entry :
+ kill spool (que index);
+ send ack;
+
+.
+ send owners ds names:
+ order task name := name (order task);
+ order task station := station (order task);
+ forget (order ds); order ds := nilspace; all msg := order ds;
+ all msg := empty thesaurus;
+ FOR que index FROM 1 UPTO number entries
+ REP IF is entry from order task ("")
+ THEN insert (all msg, list entry. ds params. name)
+ FI;
+ PER;
+ send (order task, ack, order ds)
+
+.
+ send spool list :
+ forget (global ds); global ds := nilspace;
+ file := sequential file (output, global ds);
+ list spool (file);
+ send (order task, ack, global ds);
+
+.
+ send next entry line :
+ control msg := order ds; check control password (control msg. password);
+ IF control msg. index = 0 THEN control msg. actual entries := que entries FI;
+ get next entry line;
+ send (order task, ack, order ds);
+
+ . get next entry line :
+ REP control msg. index INCR 1;
+ IF control msg. index > LENGTH control msg. actual entries
+ THEN control msg. index := 0;
+ control msg. entry line := "";
+ LEAVE get next entry line;
+ FI;
+ que index := control que index;
+ UNTIL is valid que index (que index) PER;
+ control msg. entry line := list entry. entry line;
+
+ . control que index :
+ pos (que entries, control msg. actual entries SUB control msg. index)
+
+.
+ kill entry :
+ control msg := order ds; check control password (control msg. password);
+ kill spool (control que index);
+ send (order task, ack, order ds);
+
+.
+ make to first :
+ control msg := order ds; check control password (control msg. password);
+ first spool (control que index);
+ send (order task, ack, order ds);
+
+.
+ start server task :
+ msg := order ds; check control password (msg. password);
+ IF exists (server) AND NOT stop cmd pending
+ THEN errorstop ("Spool muß zuerst gestoppt werden") FI;
+ new server channel is necessary;
+ start cmd pending := TRUE;
+ IF server channel <= 0 OR server channel >= 33
+ THEN manager message ("WARNUNG : Serverkanal nicht eingestellt", order task);
+ ELSE send ack
+ FI;
+
+ . new server channel is necessary :
+ INT CONST new channel := int (msg. name);
+ IF last conversion ok THEN server channel (new channel) FI;
+
+.
+ stop server task :
+ msg := order ds; check control password (msg. password);
+ IF phase = 1
+ THEN start cmd pending := FALSE;
+ deactive message := msg. name;
+ stop server;
+ check fetch entry;
+ ELSE reinsert fetch entry;
+ send ack;
+ FI;
+
+.
+ halt server task :
+ msg := order ds; check control password (msg. password);
+ IF phase = 1
+ THEN stop cmd pending := TRUE;
+ start cmd pending := FALSE;
+ deactive message := msg. name;
+ IF NOT exists (server) OR server is waiting
+ THEN stop server;
+ check fetch entry;
+ ELIF order = wait for halt code
+ THEN calling parent := order task;
+ ELSE send ack;
+ FI;
+ ELSE reinsert fetch entry;
+ send ack;
+ FI;
+
+ . check fetch entry :
+ IF is valid fetch entry
+ THEN manager question (""13""10"" +
+ fetch entry. entry line + " neu eintragen", order task);
+ fetch index := -fetch index;
+ ELSE send ack;
+ FI;
+
+.
+ send ack :
+ forget (order ds); order ds := nilspace;
+ send (order task, ack, order ds)
+
+.
+ spool monitor :
+ continue (order - continue code);
+ disable stop;
+ put error message if there is one;
+ WHILE online
+ REP command dialogue (TRUE);
+ sysout ("");
+ sysin ("");
+ get command ("gib Spool-Kommando:");
+ analyze command (spool command list, 3, command index, params, param1, param2);
+ reset editor;
+ SELECT command index OF
+ CASE 1 : start spool
+ CASE 2 : start spool (int (param1))
+ CASE 3 : stop spool
+ CASE 4 : halt spool
+ CASE 5 : first spool
+ CASE 6 : kill spool
+ OTHERWISE : do command
+ END SELECT;
+ PER;
+ save error message if there is one;
+ command dialogue (FALSE);
+ break (quiet);
+ set autonom;
+
+ . put error message if there is one :
+ IF error message buffer <> ""
+ THEN errorstop (error message buffer); FI;
+
+ . save error message if there is one :
+ IF is error
+ THEN error message buffer := error message;
+ clear error;
+ ELSE error message buffer := "";
+ FI;
+
+ . reset editor :
+ WHILE aktueller editor > 0 REP quit PER;
+ clear error;
+
+END PROC spool manager;
+
+
+PROC send first entry :
+
+ forget (global ds);
+ global ds := que space (first index);
+ send (server, ack, global ds, reply) ;
+ IF reply = ack
+ THEN fetch index := first index;
+ que entries := subtext (que entries, 2);
+ server is waiting := FALSE;
+ start time := time of day;
+ start time CAT " am ";
+ start time CAT date;
+ FI;
+
+END PROC send first entry;
+
+
+PROC into que (DATASPACE VAR order ds, TASK CONST order task) :
+
+ IF que is full
+ THEN errorstop ("Spool ist voll")
+ ELSE make new entry;
+ send ack;
+ awake server if necessary
+ FI;
+
+ . make new entry :
+ que entries CAT (free entries SUB 1);
+ free entries := subtext (free entries, 2);
+ que space (last index) := order ds;
+ last entry. ds params := save params;
+ build entry line;
+
+ . build entry line :
+ IF LENGTH last entry. ds params. sender name > 16
+ THEN buffer := subtext (last entry. ds params. sender name, 1, 13);
+ buffer CAT "...""";
+ ELSE buffer := last entry. ds params. sender name;
+ buffer CAT """";
+ buffer := text (buffer, 17);
+ FI;
+ last entry. entry line := entry station text;
+ last entry. entry line CAT "/""";
+ last entry. entry line CAT buffer;
+ last entry. entry line CAT " : """ ;
+ last entry. entry line CAT last entry. ds params. name;
+ last entry. entry line CAT """ (" ;
+ last entry. entry line CAT text (storage (order ds));
+ last entry. entry line CAT " K)";
+
+ . entry station text :
+ IF last entry. ds params. station = 0
+ THEN " "
+ ELSE text (last entry. ds params. station, 3)
+ FI
+
+ . send ack :
+ forget (order ds); order ds := nilspace;
+ send (order task, ack, order ds)
+
+ . awake server if necessary :
+ IF server is waiting THEN send first entry FI;
+
+END PROC into que;
+
+
+(*********************************************************************)
+(* Hilfsprozeduren zum Spoolmanager *)
+(*********************************************************************)
+
+
+PROC reinsert fetch entry :
+
+ IF fetch index <> 0
+ THEN insert char (que entries, code (abs (fetch index)), 1);
+ fetch index := 0;
+ FI;
+
+END PROC reinsert fetch entry;
+
+
+PROC erase fetch entry :
+
+ IF fetch index <> 0
+ THEN free entries CAT code (abs (fetch index));
+ forget (que space (abs (fetch index)));
+ fetch index := 0;
+ FI;
+
+END PROC erase fetch entry;
+
+
+PROC start server (PROC server start):
+
+ stop server;
+ begin (PROC server start, server);
+ station by start := station (myself);
+ start cmd pending := FALSE;
+ deactive message := "";
+
+END PROC start server;
+
+
+PROC stop server :
+
+ IF exists (server) THEN end (server) ELSE check server (FALSE) FI;
+ server := niltask;
+ server is waiting := FALSE;
+ stop cmd pending := FALSE;
+ send calling parent reply if necessary;
+
+ . send calling parent reply if necessary :
+ IF exists (calling parent)
+ THEN forget (global ds); global ds := nilspace;
+ send (calling parent, ack, global ds);
+ calling parent := niltask;
+ FI;
+
+END PROC stop server;
+
+
+PROC check server (BOOL CONST with stop) :
+
+ IF was define station CAND NOT is niltask (server)
+ THEN stop old server if necessary FI;
+
+ . stop old server if necessary :
+ access catalogue;
+ TASK VAR old server := son (myself);
+ WHILE NOT is niltask (old server)
+ REP IF index (old server) = index (server) THEN old server found FI;
+ old server := brother (old server);
+ PER;
+
+ . old server found :
+ IF name (old server) = "-" THEN end (old server) FI;
+ IF with stop THEN stop server FI;
+ LEAVE stop old server if necessary;
+
+END PROC check server;
+
+
+BOOL PROC is valid que index (INT CONST index) :
+
+ 1 <= index AND index <= number entries
+
+END PROC is valid que index;
+
+
+BOOL PROC is entry from order task (TEXT CONST file name) :
+
+ correct order task CAND correct filename
+
+ . correct order task :
+ order task name = list entry. ds params. sendername
+ AND order task station = list entry. ds params. station
+
+ . correct file name :
+ file name = "" OR file name = list entry. ds params. name
+
+END PROC is entry from order task;
+
+
+PROC check control password (TEXT CONST password) :
+
+ IF control password = "-"
+ THEN errorstop ("Kontrolle des Spools nicht erlaubt")
+ ELIF control password <> "" CAND control password <> password
+ THEN errorstop ("Passwort falsch")
+ FI;
+
+END PROC check control password;
+
+
+PROC next headline information (TEXT VAR t):
+
+ begin pos := pos (headline (file), begin char, end pos + 1);
+ IF begin pos = 0
+ THEN begin pos := LENGTH headline (file) + 1;
+ t := "";
+ ELSE end pos := pos (headline (file), end char, begin pos + 1);
+ IF end pos = 0
+ THEN end pos := LENGTH headline (file) + 1;
+ t := "";
+ ELSE t := subtext (headline (file), begin pos+1, end pos-1)
+ FI
+ FI
+
+END PROC next headline information;
+
+(*********************************************************************)
+(* Prozeduren zur Verwaltung der Warteschlange *)
+(*********************************************************************)
+
+PROC start spool :
+
+ enable stop;
+ IF server channel <= 0 OR server channel >= 33
+ THEN display (""13""10"WARNUNG : Serverkanal nicht eingestellt"13""10"")
+ FI;
+ halt spool;
+ start cmd pending := TRUE;
+
+END PROC start spool;
+
+PROC start spool (INT CONST new channel) :
+
+ enable stop;
+ server channel (new channel);
+ start spool;
+
+END PROC start spool;
+
+PROC stop spool (TEXT CONST deactive msg) :
+
+ disable stop;
+ deactive message := deactive msg;
+ start cmd pending := FALSE;
+ stop server;
+ IF is valid fetch entry CAND on line CAND
+ yes (""13""10"" + fetch entry. entry line + " neu eintragen")
+ THEN reinsert fetch entry
+ ELSE erase fetch entry;
+ FI;
+
+END PROC stop spool;
+
+PROC stop spool : stop spool ("") END PROC stop spool;
+
+PROC halt spool (TEXT CONST deactive msg) :
+
+ enable stop;
+ deactive message := deactive msg;
+ stop cmd pending := TRUE;
+ start cmd pending := FALSE;
+ IF NOT exists (server) OR server is waiting THEN stop spool FI;
+
+END PROC halt spool;
+
+PROC halt spool : halt spool ("") END PROC halt spool;
+
+
+PROC kill spool :
+
+ enable stop;
+ say (""13""10"");
+ que index := 1;
+ WHILE que index <= number entries
+ REP IF yes (list entry. entry line + " loeschen")
+ THEN kill spool (que index)
+ ELSE que index INCR 1
+ FI;
+ PER;
+
+END PROC kill spool;
+
+PROC kill spool (INT CONST index) :
+
+ IF is valid que index (index)
+ THEN forget (que space (code (que entries SUB index)));
+ free entries CAT (que entries SUB index);
+ delete char (que entries, index);
+ FI;
+
+END PROC kill spool;
+
+
+PROC first spool :
+
+ enable stop;
+ say (""13""10"");
+ FOR que index FROM 1 UPTO number entries
+ REP IF yes (list entry. entry line + " als erstes")
+ THEN first spool (que index);
+ LEAVE first spool
+ FI;
+ PER;
+
+END PROC first spool;
+
+PROC first spool (INT CONST index) :
+
+ IF is valid que index (index)
+ THEN insert char (que entries, que entries SUB index, 1);
+ delete char (que entries, index + 1);
+ FI;
+
+END PROC first spool;
+
+
+TEXT PROC spool entry line (INT CONST index) :
+
+ IF index = 0 CAND is valid fetch entry
+ THEN fetch entry. entry line
+ ELIF is valid que index (index)
+ THEN entry. entry line
+ ELSE ""
+ FI
+
+ . entry : que (code (que entries SUB index))
+
+END PROC spool entry line;
+
+
+INT PROC number spool entries : number entries END PROC number spool entries;
+
+INT PROC spool status :
+
+ IF exists (server)
+ THEN IF stop cmd pending
+ THEN IF start cmd pending
+ THEN 3 (* aktiviert (neu start) *)
+ ELSE 2 (* aktiviert (warten auf halt) *)
+ FI
+ ELSE IF server is waiting
+ THEN 0 (* kein Auftrag in Bearbeitung *)
+ ELSE 1 (* aktiviert *)
+ FI
+ FI
+ ELIF start cmd pending
+ THEN 0 (* wird aktiviert *)
+ ELIF is valid fetch entry
+ THEN IF was define station
+ THEN -3 (* deaktiviert (define station) *)
+ ELSE -2 (* deaktiviert (server gelöcht) *)
+ FI
+ ELSE -1 (* deaktiviert *)
+ FI
+
+END PROC spool status;
+
+TASK PROC server task : server END PROC server task;
+
+
+PROC clear spool :
+
+ disable stop;
+ IF NOT initialized (init que space)
+ THEN FOR que index FROM 1 UPTO que size
+ REP que space (que index) := nilspace PER;
+ FI;
+ que entries := "";
+ free entries := "";
+ fetch index := 0;
+ stop server;
+ FOR que index FROM 1 UPTO que size
+ REP forget (que space (que index));
+ free entries CAT code (que index);
+ PER;
+
+END PROC clear spool;
+
+
+PROC list spool :
+
+ disable stop;
+ DATASPACE VAR list ds := nilspace;
+ FILE VAR list file := sequential file (output, list ds);
+ list spool (list file);
+ show (list file);
+ forget (list ds);
+
+END PROC list spool;
+
+
+PROC list spool (FILE VAR f) :
+
+ enable stop;
+ output (f);
+ max line length (f, 1000);
+ headline (f, station text + name (myself) + """");
+ put spool duty;
+ put current job;
+ put spool que;
+
+ . station text :
+ IF station(myself) = 0
+ THEN "/"""
+ ELSE text (station(myself)) + "/"""
+ FI
+
+ . put spool duty :
+ IF spool duty <> ""
+ THEN write (f, "Aufgabe: ");
+ write (f, spool duty );
+ line (f, 2);
+ FI;
+
+ . put current job :
+ IF is valid fetch entry
+ THEN write (f, "In Bearbeitung seit ");
+ write (f, start time);
+ write (f, ":");
+ line (f, 2);
+ putline (f, fetch entry. entry line);
+ IF NOT exists (server)
+ THEN IF was define station
+ THEN putline (f, "Spool ist deaktiviert, da Stationsnummer geaendert wurde")
+ ELSE putline (f, "Spool ist deaktiviert, da der Server gelöscht wurde")
+ FI;
+ ELIF stop cmd pending
+ THEN IF start cmd pending
+ THEN putline (f, "Spool wird nach diesem Auftrag neu aktiviert");
+ ELSE putline (f, "Spool wird nach diesem Auftrag deaktiviert");
+ FI;
+ FI;
+ line (f);
+ ELSE write (f, "kein Auftrag in Bearbeitung");
+ IF NOT exists (server)
+ THEN write (f, ", da Spool deaktiviert");
+ IF start cmd pending
+ THEN line (f);
+ write (f, "Spool wird nach Verlassen der Task aktiviert");
+ FI;
+ IF deactive message <> ""
+ THEN line (f);
+ write (f, deactive message);
+ FI;
+ ELIF que is empty
+ THEN write (f, ", da Warteschlange leer");
+ LEAVE list spool;
+ FI;
+ line (f, 2);
+ FI;
+
+ . put spool que :
+ IF que is empty
+ THEN putline (f, "Warteschlange ist leer");
+ ELSE write (f, "Warteschlange (");
+ write (f, text (number entries));
+ IF number entries = 1
+ THEN write (f, " Auftrag):");
+ ELSE write (f, " Auftraege):");
+ FI;
+ line (f, 2);
+ FOR que index FROM 1 UPTO number entries
+ REP putline (f, list entry. entry line) PER;
+ FI;
+
+END PROC list spool;
+
+
+ENDPACKET spool manager;
+
diff --git a/system/std.zusatz/1.8.7/src/std analysator b/system/std.zusatz/1.8.7/src/std analysator
new file mode 100644
index 0000000..7e14722
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/std analysator
@@ -0,0 +1,68 @@
+PACKET std analysator (* Autor : Rudolf Ruland *)
+ (* Stand : 06.11.86 *)
+ DEFINES std analysator :
+
+
+LET text code = 1,
+ error code = 2,
+ token code = 3;
+
+INT VAR instruction begin;
+TEXT VAR unknown instruction := "";
+
+PROC std analysator (INT CONST op code, TEXT VAR string,
+ INT VAR par1, par2, par3, par4, par5, par6, par7) :
+
+ SELECT op code OF
+
+ CASE text code : analyse text
+ CASE error code : report errors
+ CASE token code : report tokens
+
+ END SELECT ;
+
+ . record : string
+ . record pos : par1
+ . width : par4
+ . height : par5
+ . depth : par6
+
+ . analyse text :
+ instruction begin := record pos + 1;
+ record pos := pos (record, "#", instruction begin) + 1;
+ width := 0;
+ height := 0;
+ depth := 0;
+ unknown instruction := subtext (record, instruction begin, instruction end);
+
+ . instruction end : record pos - 2
+
+
+. error msg : string
+. error nr : par1
+.
+ report errors :
+ IF error nr = 0
+ THEN error msg := "unbekannte Anweisung (ignoriert): ";
+ error msg CAT unknown instruction;
+ error nr := 1;
+ ELSE error msg := "";
+ error nr := 0;
+ FI;
+
+
+. token text : string
+. token nr : par1
+. token font nr : par2
+. token modifications : par3
+. token width : par4
+. token x pos : par5
+. token y pos : par6
+. token type : par7
+.
+ report tokens :
+
+END PROC std analysator;
+
+END PACKET std analysator;
+
diff --git a/system/std.zusatz/1.8.7/src/vector b/system/std.zusatz/1.8.7/src/vector
new file mode 100644
index 0000000..5c9e896
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/vector
@@ -0,0 +1,213 @@
+PACKET vector DEFINES VECTOR, :=, vector, (* Autor : H.Indenbirken *)
+ SUB, LENGTH, length, norm, (* Stand : 21.10.83 *)
+ nilvector, replace, =, <>,
+ +, -, *, /,
+ get, put :
+
+
+TYPE VECTOR = STRUCT (INT lng, TEXT elem);
+TYPE INITVECTOR = STRUCT (INT lng, REAL value);
+
+INT VAR i;
+TEXT VAR t :: "12345678";
+VECTOR VAR v :: nilvector;
+
+(****************************************************************************
+PROC dump (VECTOR CONST v) :
+ put line (text (v.lng) + " Elemente :");
+ FOR i FROM 1 UPTO v.lng
+ REP put line (text (i) + ": " + text (element i)) PER .
+
+element i :
+ v.elem RSUB i .
+
+END PROC dump;
+****************************************************************************)
+
+OP := (VECTOR VAR l, VECTOR CONST r) :
+ l.lng := r.lng;
+ l.elem := r.elem
+
+END OP :=;
+
+OP := (VECTOR VAR l, INITVECTOR CONST r) :
+ l.lng := r.lng;
+ replace (t, 1, r.value);
+ l.elem := r.lng * t
+
+END OP :=;
+
+INITVECTOR PROC nilvector :
+ vector (1, 0.0)
+
+END PROC nilvector;
+
+INITVECTOR PROC vector (INT CONST lng, REAL CONST value) :
+ IF lng <= 0
+ THEN errorstop ("PROC vector : lng <= 0") FI;
+ INITVECTOR : (lng, value)
+
+END PROC vector;
+
+INITVECTOR PROC vector (INT CONST lng) :
+ vector (lng, 0.0)
+
+END PROC vector;
+
+REAL OP SUB (VECTOR CONST v, INT CONST i) :
+ test ("REAL OP SUB : ", v, i);
+ v.elem RSUB i
+
+END OP SUB;
+
+INT OP LENGTH (VECTOR CONST v) :
+ v.lng
+
+END OP LENGTH;
+
+INT PROC length (VECTOR CONST v) :
+ v.lng
+
+END PROC length;
+
+REAL PROC norm (VECTOR CONST v) :
+ REAL VAR result :: 0.0;
+ FOR i FROM 1 UPTO v.lng
+ REP result INCR ((v.elem RSUB i)**2) PER;
+ sqrt (result) .
+
+END PROC norm;
+
+PROC replace (VECTOR VAR v, INT CONST i, REAL CONST r) :
+ test ("PROC replace : ", v, i);
+ replace (v.elem, i, r)
+
+END PROC replace;
+
+BOOL OP = (VECTOR CONST l, r) :
+ l.elem = r.elem
+END OP =;
+
+BOOL OP <> (VECTOR CONST l, r) :
+ l.elem <> r.elem
+END OP <>;
+
+VECTOR OP + (VECTOR CONST v) :
+ v
+END OP +;
+
+VECTOR OP + (VECTOR CONST l, r) :
+ test ("VECTOR OP + : ", l, r);
+ v := l;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, (l.elem RSUB i) + (r.elem RSUB i)) PER;
+ v
+
+END OP +;
+
+VECTOR OP - (VECTOR CONST a) :
+ v := a;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, - (a.elem RSUB i)) PER;
+ v
+
+END OP -;
+
+VECTOR OP - (VECTOR CONST l, r) :
+ test ("VECTOR OP - : ", l, r);
+ v := l;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, (l.elem RSUB i) - (r.elem RSUB i)) PER;
+ v
+END OP -;
+
+REAL OP * (VECTOR CONST l, r) :
+ test ("REAL OP * : ", l, r);
+ REAL VAR x :: 0.0;
+ FOR i FROM 1 UPTO l.lng
+ REP x INCR ((l.elem RSUB i) * (r.elem RSUB i)) PER;
+ x
+
+END OP *;
+
+VECTOR OP * (VECTOR CONST v, REAL CONST r) :
+ r*v
+
+END OP *;
+
+VECTOR OP * (REAL CONST r, VECTOR CONST a) :
+ v := a;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, r*(a.elem RSUB i)) PER;
+ v
+
+END OP *;
+
+VECTOR OP / (VECTOR CONST a, REAL CONST r) :
+ v := a;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, (a.elem RSUB i)/r) PER;
+ v
+
+END OP /;
+
+TEXT VAR error :: "";
+PROC test (TEXT CONST proc, VECTOR CONST v, INT CONST i) :
+ IF i > v.lng
+ THEN error := proc;
+ error CAT "subscript overflow (LENGTH v=";
+ error CAT text (v.lng);
+ error CAT ", i=";
+ error CAT text (i);
+ error CAT ")";
+ errorstop (error)
+ ELIF i < 1
+ THEN error := proc;
+ error CAT "subscript underflow (i = ";
+ error CAT text (i);
+ error CAT ")";
+ errorstop (error)
+ FI .
+
+END PROC test;
+
+PROC test (TEXT CONST proc, VECTOR CONST a, b) :
+ IF a.lng <> b.lng
+ THEN error := proc;
+ error CAT "LENGTH a (";
+ IF a.lng <= 0
+ THEN error CAT "undefined"
+ ELSE error CAT text (a.lng) FI;
+ error CAT ") <> LENGTH b (";
+ error CAT text (b.lng);
+ error CAT ")";
+ errorstop (error)
+ FI
+
+END PROC test;
+
+PROC get (VECTOR VAR v, INT CONST lng) :
+ v.lng := lng;
+ v.elem := lng * "12345678";
+ REAL VAR x;
+ FOR i FROM 1 UPTO lng
+ REP get (x);
+ replace (v.elem, i, x)
+ PER .
+
+END PROC get;
+
+PROC put (VECTOR CONST v, INT CONST length, fracs) :
+ FOR i FROM 1 UPTO v.lng
+ REP put (text (v.elem RSUB i, length, fracs)) PER
+
+END PROC put;
+
+PROC put (VECTOR CONST v) :
+ FOR i FROM 1 UPTO v.lng
+ REP put (text (v.elem RSUB i)) PER
+
+END PROC put;
+
+END PACKET vector;
+