From 04e68443040c7abad84d66477e98f93bed701760 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 4 Feb 2019 13:09:03 +0100 Subject: Initial import --- system/std.zusatz/1.8.7/source-disk | 1 + system/std.zusatz/1.8.7/src/AT Generator | 135 + system/std.zusatz/1.8.7/src/AT Utilities | 1057 ++++++++ system/std.zusatz/1.8.7/src/AT install | 93 + system/std.zusatz/1.8.7/src/complex | 115 + system/std.zusatz/1.8.7/src/crypt | 138 + system/std.zusatz/1.8.7/src/eumel printer.5 | 3473 ++++++++++++++++++++++++++ system/std.zusatz/1.8.7/src/eumelmeter | 131 + system/std.zusatz/1.8.7/src/font convertor 9 | 1095 ++++++++ system/std.zusatz/1.8.7/src/free channel | 430 ++++ system/std.zusatz/1.8.7/src/longint | 423 ++++ system/std.zusatz/1.8.7/src/matrix | 482 ++++ system/std.zusatz/1.8.7/src/port server | 164 ++ system/std.zusatz/1.8.7/src/printer server | 99 + system/std.zusatz/1.8.7/src/purge | 85 + system/std.zusatz/1.8.7/src/referencer | 1077 ++++++++ system/std.zusatz/1.8.7/src/reporter | 531 ++++ system/std.zusatz/1.8.7/src/scheduler | 420 ++++ system/std.zusatz/1.8.7/src/spool cmd | 178 ++ system/std.zusatz/1.8.7/src/spool manager | 1058 ++++++++ system/std.zusatz/1.8.7/src/std analysator | 68 + system/std.zusatz/1.8.7/src/vector | 213 ++ 22 files changed, 11466 insertions(+) create mode 100644 system/std.zusatz/1.8.7/source-disk create mode 100644 system/std.zusatz/1.8.7/src/AT Generator create mode 100644 system/std.zusatz/1.8.7/src/AT Utilities create mode 100644 system/std.zusatz/1.8.7/src/AT install create mode 100644 system/std.zusatz/1.8.7/src/complex create mode 100644 system/std.zusatz/1.8.7/src/crypt create mode 100644 system/std.zusatz/1.8.7/src/eumel printer.5 create mode 100644 system/std.zusatz/1.8.7/src/eumelmeter create mode 100644 system/std.zusatz/1.8.7/src/font convertor 9 create mode 100644 system/std.zusatz/1.8.7/src/free channel create mode 100644 system/std.zusatz/1.8.7/src/longint create mode 100644 system/std.zusatz/1.8.7/src/matrix create mode 100644 system/std.zusatz/1.8.7/src/port server create mode 100644 system/std.zusatz/1.8.7/src/printer server create mode 100644 system/std.zusatz/1.8.7/src/purge create mode 100644 system/std.zusatz/1.8.7/src/referencer create mode 100644 system/std.zusatz/1.8.7/src/reporter create mode 100644 system/std.zusatz/1.8.7/src/scheduler create mode 100644 system/std.zusatz/1.8.7/src/spool cmd create mode 100644 system/std.zusatz/1.8.7/src/spool manager create mode 100644 system/std.zusatz/1.8.7/src/std analysator create mode 100644 system/std.zusatz/1.8.7/src/vector (limited to 'system/std.zusatz') 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 "); + 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; + -- cgit v1.2.3