From 98cab31fc3659e33aef260efca55bf9f1753164c Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 11 Feb 2019 11:49:19 +0100 Subject: Add source files from Michael --- system/std.zusatz/1.7.3/src/17CHARS.ELA | 44 + system/std.zusatz/1.7.3/src/EMU16.ELA | 109 ++ system/std.zusatz/1.7.3/src/EMU16M.ELA | 162 +++ system/std.zusatz/1.7.3/src/FONTR16.ELA | 360 +++++++ system/std.zusatz/1.7.3/src/MINPRINT.ELA | 94 ++ system/std.zusatz/1.7.3/src/TO16.ELA | 102 ++ system/std.zusatz/1.7.3/src/complex | 133 +++ system/std.zusatz/1.7.3/src/crypt | 139 +++ system/std.zusatz/1.7.3/src/elan lister | 263 +++++ system/std.zusatz/1.7.3/src/eumel printer | 369 +++++++ system/std.zusatz/1.7.3/src/eumelmeter | 130 +++ system/std.zusatz/1.7.3/src/free channel | 292 ++++++ system/std.zusatz/1.7.3/src/longint | 422 ++++++++ system/std.zusatz/1.7.3/src/matrix | 470 +++++++++ system/std.zusatz/1.7.3/src/minimal fonts routines | 9 + system/std.zusatz/1.7.3/src/printer-M | 69 ++ system/std.zusatz/1.7.3/src/printer-S | 36 + system/std.zusatz/1.7.3/src/purge | 85 ++ system/std.zusatz/1.7.3/src/referencer | 1077 ++++++++++++++++++++ system/std.zusatz/1.7.3/src/reporter | 479 +++++++++ system/std.zusatz/1.7.3/src/scheduler | 419 ++++++++ system/std.zusatz/1.7.3/src/spool manager | 377 +++++++ system/std.zusatz/1.7.3/src/std printer | 434 ++++++++ .../std.zusatz/1.7.3/src/std printer generator-M | 22 + .../std.zusatz/1.7.3/src/std printer generator-S | 15 + system/std.zusatz/1.7.3/src/vector | 213 ++++ 26 files changed, 6324 insertions(+) create mode 100644 system/std.zusatz/1.7.3/src/17CHARS.ELA create mode 100644 system/std.zusatz/1.7.3/src/EMU16.ELA create mode 100644 system/std.zusatz/1.7.3/src/EMU16M.ELA create mode 100644 system/std.zusatz/1.7.3/src/FONTR16.ELA create mode 100644 system/std.zusatz/1.7.3/src/MINPRINT.ELA create mode 100644 system/std.zusatz/1.7.3/src/TO16.ELA create mode 100644 system/std.zusatz/1.7.3/src/complex create mode 100644 system/std.zusatz/1.7.3/src/crypt create mode 100644 system/std.zusatz/1.7.3/src/elan lister create mode 100644 system/std.zusatz/1.7.3/src/eumel printer create mode 100644 system/std.zusatz/1.7.3/src/eumelmeter create mode 100644 system/std.zusatz/1.7.3/src/free channel create mode 100644 system/std.zusatz/1.7.3/src/longint create mode 100644 system/std.zusatz/1.7.3/src/matrix create mode 100644 system/std.zusatz/1.7.3/src/minimal fonts routines create mode 100644 system/std.zusatz/1.7.3/src/printer-M create mode 100644 system/std.zusatz/1.7.3/src/printer-S create mode 100644 system/std.zusatz/1.7.3/src/purge create mode 100644 system/std.zusatz/1.7.3/src/referencer create mode 100644 system/std.zusatz/1.7.3/src/reporter create mode 100644 system/std.zusatz/1.7.3/src/scheduler create mode 100644 system/std.zusatz/1.7.3/src/spool manager create mode 100644 system/std.zusatz/1.7.3/src/std printer create mode 100644 system/std.zusatz/1.7.3/src/std printer generator-M create mode 100644 system/std.zusatz/1.7.3/src/std printer generator-S create mode 100644 system/std.zusatz/1.7.3/src/vector (limited to 'system/std.zusatz/1.7.3') diff --git a/system/std.zusatz/1.7.3/src/17CHARS.ELA b/system/std.zusatz/1.7.3/src/17CHARS.ELA new file mode 100644 index 0000000..160997a --- /dev/null +++ b/system/std.zusatz/1.7.3/src/17CHARS.ELA @@ -0,0 +1,44 @@ +PACKET special 17 chars DEFINES chars 17 : + +TEXT VAR rec , schar ; +FILE VAR f ; + +PROC chars 17 : + + REP + down ("""") ; + get schar ; + UNTIL perhaps schar ("225", "217") + COR perhaps schar ("239", "218") + COR perhaps schar ("245", "219") + COR perhaps schar ("193", "214") + COR perhaps schar ("207", "215") + COR perhaps schar ("213", "216") + COR perhaps schar ("235", "220") + COR perhaps schar ("173", "221") + COR perhaps schar ("163", "222") + COR perhaps schar ("160", "223") + COR perhaps schar ("194", "251") + COR eof + PER ; + zeile neu . + +get schar : + f := editfile ; + read record (f, rec) ; + schar := subtext (rec, col + 1, col + 3) . + +ENDPROC chars 17 ; + +BOOL PROC perhaps schar (TEXT CONST old, new) : + + IF schar = old + THEN change (rec, col + 4, col + 3, new) ; + write record (f, rec) ; + TRUE + ELSE FALSE + FI . + +ENDPROC perhaps schar ; + +ENDPACKET special 17 chars ; diff --git a/system/std.zusatz/1.7.3/src/EMU16.ELA b/system/std.zusatz/1.7.3/src/EMU16.ELA new file mode 100644 index 0000000..a8e1292 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/EMU16.ELA @@ -0,0 +1,109 @@ +PACKET emulator 16 DEFINES (* Autor: J.Liedtke *) + (* Stand: 11.10.83 *) + killer , (* F. Klapper, 26.03.84 *) + command handler , + set command , + to archive, + from archive, + load archive, + save archive, + list archive, + release archive: + +PROC list archive: + list (archive) + +END PROC list archive; + +PROC release archive: + release (archive) + +END PROC release archive; + +PROC to archive: + save (last param, archive) + +END PROC to archive; + +PROC to archive (TEXT CONST t): + save (t, archive) + +END PROC to archive; + +PROC from archive (TEXT CONST t): + fetch (t, archive) + +END PROC from archive; + +PROC load archive: + fetch all (archive) + +END PROC load archive; + +PROC save to archive (THESAURUS CONST thes): + disable stop; + all to archive (thes); + IF is error + THEN put error; + line; + clear error; + IF yes ("naechste Archivfloppy eingelegt") + THEN save to archive (remainder) + FI + FI; + enable stop + +END PROC save to archive; + +PROC all to archive (THESAURUS CONST thes): + enable stop; + save (thes, archive) + +END PROC all to archive; + +PROC save archive: + save to archive (ALL myself) + +END PROC save archive; + +PROC save archive (TEXT CONST liste): + save to archive (ALL liste) + +END PROC save archive; + +PROC killer : + forget (ALL myself) + +ENDPROC killer ; + +TEXT VAR command line; +INT VAR permitted type := 0 ; + +PROC set command (TEXT CONST command text, INT CONST type) : + + command line := command text; + permitted type := type + +ENDPROC set command ; + +PROC command handler (TEXT CONST command list, + INT VAR command index , number of params , + TEXT VAR param 1, param 2) : + + analyze command (command list, command line, permitted type, command index, + number of params, param 1, param 2) + +ENDPROC command handler ; + +PROC command handler (TEXT CONST command list, + INT VAR command index , number of params , + TEXT VAR param 1, param 2, + TEXT CONST command text) : + + get command (command text, command line) ; + analyze command (command list, command line, 0, + command index, number of params, param 1, param 2) + +ENDPROC command handler ; + +ENDPACKET emulator 16 ; diff --git a/system/std.zusatz/1.7.3/src/EMU16M.ELA b/system/std.zusatz/1.7.3/src/EMU16M.ELA new file mode 100644 index 0000000..ed8cff4 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/EMU16M.ELA @@ -0,0 +1,162 @@ +PACKET emulator 16 multi DEFINES (* Autor: J.Liedtke *) + (* Stand: 11.10.83 *) + killer , (* F. Klapper, 16.05.84 *) + file names , + out , + command handler , + set command , + call , + read , + to archive, + from archive, + load archive, + save archive, + list archive, + release archive, + forward, + backward, + to eof, + to first record, + is first record: + +PROC list archive: + list (archive) +END PROC list archive; + +PROC release archive: + release (archive) +END PROC release archive; + +PROC to archive: + save (last param, archive) +END PROC to archive; + +PROC to archive (TEXT CONST t): + save (t, archive) +END PROC to archive; + +PROC from archive (TEXT CONST t): + fetch (t, archive) +END PROC from archive; + +PROC load archive: + fetch all (archive) +END PROC load archive; + +PROC save to archive (THESAURUS CONST thes): + disable stop; + all to archive (thes); + IF is error + THEN put error; + line; + clear error; + IF yes ("naechste Archivfloppy eingelegt") + THEN save to archive (remainder) + FI + FI; + enable stop +END PROC save to archive; + +PROC all to archive (THESAURUS CONST thes): + enable stop; + save (thes, archive) +END PROC all to archive; + +PROC save archive: + save to archive (ALL myself) +END PROC save archive; + +PROC save archive (TEXT CONST liste): + save to archive (ALL liste) +END PROC save archive; + +PROC killer : + forget (ALL myself) +ENDPROC killer ; + +THESAURUS VAR cat ; +TEXT VAR file name ; + +PROC file names (FILE VAR f) : + file names (f, name (myself)) +ENDPROC file names ; + +PROC file names (FILE VAR f, TEXT CONST manager name) : + INT VAR index := 0 ; + cat := ALL task (manager name) ; + REP + get (cat, file name, index) ; + IF file name = "" + THEN LEAVE file names + FI ; + putline (f, file name) + PER +ENDPROC file names ; + +PROC out (FILE VAR f, TEXT CONST t) : + write (f,t) +ENDPROC out ; + +TEXT VAR command line; +INT VAR permitted type := 0 ; + +PROC set command (TEXT CONST command text, INT CONST type) : + command line := command text; + permitted type := type +ENDPROC set command ; + +PROC command handler (TEXT CONST command list, + INT VAR command index , number of params , + TEXT VAR param 1, param 2) : + + analyze command (command list, command line, permitted type, command index, + number of params, param 1, param 2) + +ENDPROC command handler ; + +PROC command handler (TEXT CONST command list, + INT VAR command index , number of params , + TEXT VAR param 1, param 2, + TEXT CONST command text) : + + get command (command text, command line) ; + analyze command (command list, command line, 0, + command index, number of params, param 1, param 2) + +ENDPROC command handler ; + +PROC call (TEXT CONST dest name, INT CONST order code, + DATASPACE VAR ds, INT VAR reply code) : + + call (task (dest name), order code, ds, reply code) + +ENDPROC call ; + +PROC read (TEXT CONST file name) : + fetch (file name) +ENDPROC read ; + +PROC read (TEXT CONST file name, manager name) : + fetch (file name, task(manager name)) +ENDPROC read ; + +PROC forward (FILE VAR f): + down (f) +END PROC forward; + +PROC backward (FILE VAR f): + up (f) +END PROC backward; + +PROC to first record (FILE VAR f): + to line (f, 1) +END PROC to first record; + +BOOL PROC is first record (FILE VAR f): + line no (f) = 1 +END PROC is first record; + +PROC to eof (FILE VAR f): + to line (f, lines (f)) +END PROC to eof; +ENDPACKET emulator 16 multi ; diff --git a/system/std.zusatz/1.7.3/src/FONTR16.ELA b/system/std.zusatz/1.7.3/src/FONTR16.ELA new file mode 100644 index 0000000..91acfe0 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/FONTR16.ELA @@ -0,0 +1,360 @@ +PACKET fonts routines +(************************************************************************** +***** Verwaltung der Schriftfontstabelle ** Author : R. Nolting ***** +***** Benoetigt von allen Druckertreibern ** Version: 0.1 / 3.5.82 ***** +***** ** Version: 1.0 / 8.6.82 ***** +***** ** Version: 2.0 / 1. 8. 82 ***** +***** Schrittweite in x und y in Tabelle ** Version: 3.0 / 1. 9. 83 ***** +***** Zeilenhoehe in cm ** Version: 3.1 / 2. 4. 84 ***** +**************************************************************************) + + DEFINES + load font table, + get font, + list fonts, + inch, + current font number, + lf height of current font, + x factor per inch, + y factor per inch: + +LET max fonts = 8; +LET max nr points = 4; +LET PRINTTYPE = STRUCT (INT x steps per inch, y steps per inch, + ROW max nr points INT point size, + TEXT name, pitch table, codetable); +ROW max fonts PRINTTYPE VAR font; +FILE VAR font file; +INT VAR font number := 1, point number := 1; +TEXT VAR record := " ", + symb; +INT VAR i; +REAL CONST inch := 2.54; + +INT PROC x factor per inch: + x step +END PROC x factor per inch; + +INT PROC y factor per inch: + lf +END PROC y factor per inch; + +REAL PROC lf height of current font: + real(point (point number)) * inch / real (lf) (* 9.1.84 Nolting *) +END PROC lf height of current font; + +INT PROC current font number: + font number +END PROC current font number; +(******************************************************************* +********* Setzen und Liefern von Schriftsaetzen ****** +*******************************************************************) +PROC init font: +FOR font number FROM 1 UPTO max fonts REP; + lf := 1; + x step := 1; + FOR point number FROM 1 UPTO max nr points REP + point(point number) := 1; + PER; + kode := ""; + name := ""; + pitch:= ""; + PER; +END PROC init font; +(******************************************************************) + +PROC list fonts: + line; + FOR font number FROM 1 UPTO max fonts REP + IF name <> "" AND name <> " " + THEN put typ name + FI; + line; + PER; + font number := 1; point number := 1; +. +put typ name: + put (font number); put ("."); + put ("'"); put (name); put ("'"); + IF length (pitch) > 1 + THEN put ("proportional mit Blankbreite"); put (code (pitch SUB 32)) + ELSE put ("fest mit Blankbreite"); put (code (pitch)); + FI; + put ("und Zeilenhoehe"); put (point (1)); +END PROC list fonts; + +BOOL PROC font is in table (TEXT CONST name of font): + record := name of font; + changeall (record, " ",""); + IF record = "" + THEN font number := 1; TRUE + ELSE search through the table + FI +. +search through the table: +(* der Name des gewuenschten Types darf noch ein angehaengtes Attribut haben *) + FOR font number FROM 1 UPTO max fonts REPEAT + IF pos (record, name) = 1 + THEN LEAVE search through the table WITH TRUE + FI; + PER; + font number := 1; + FALSE +ENDPROC font is in table; + +PROC get font (TEXT VAR name of font, + TEXT VAR font pitch table, font code table, + BOOL VAR success): +INT VAR lf size := 0; + get font (name of font, lf size, + font pitch table, font code table, success); + replace (font pitch table, 10, code(lfsize)); +END PROC get font; + +PROC get font (TEXT VAR name of font, INT VAR size, + TEXT VAR font pitch table, font code table, + BOOL VAR success): + success := font is in table (name of font); + name of font := name; + (* hiermit wird eine Ueberpruefung 'alter Typ = neuer Typ' + im aufrufenden Programm ermoeglicht *) + font code table := kode; + font pitch table := pitch; + point number := max nr points; + WHILE point (point number) <> size REP + point number DECR 1; + UNTIL point number = 1 PER; + size := point (point number); + IF size = point (1) + THEN font pitch table := pitch; + LEAVE get font + ELSE font pitch table := "" + FI; + INT VAR j := point (1); + FOR i FROM 1 UPTO length (pitch) REP + font pitch table CAT code(code (pitch SUB i) * size DIV j) + PER; + +END PROC get font; + +LET tag = 1 , + bold = 2 , + number = 3 , + string = 4 , (* = text; aber PROC text wird benoetigt *) + operator = 5 , + delimiter = 6 , + end of file = 7 , + within comment = 8 , + within text = 9 ; + +PROC load font table (TEXT CONST font file name): +BOOL VAR prop font; +INT VAR type of symbol := 0; +REAL VAR blank in cm , + lf in cm; +REAL VAR width, inch factor; +INT VAR factor width; + +enable stop; +IF NOT exists (font file name) + THEN errorstop ("Fontdatei nicht vorhanden") + FI; +font file := sequential file (input, font file name); + init font; + font number := 0; + getline (font file, record); + protline (record); + WHILE NOT eof (font file) REP + font number INCR 1; + get font name and parameters; + get char width and output function; + UNTIL eof (font file) COR font number >= max fonts PER; + font number := 1; point number := 1; +. +get font name and parameters: + get font name; + get fixed or prop; + get blank width; + get linefeed height; + get pointsizes; + get optional x steps per inch; + fill pitch and code table with default; +. +get font name: + next entry; prot (symb); + IF (symb SUB 1) = "#" + THEN symb := subtext (symb, 2); + WHILE (symb SUB length(symb)) <> "#" REP + name CAT symb; + next entry; prot (symb); + IF symb = "" + THEN errorstop ("# fehlt beim Fontnamen"); + FI; + PER; + name CAT subtext (symb, 1, length (symb)-1) + ELSE error stop ("1. Symbol kein Fontname") + FI; +. +get fixed or prop: + next entry; + prop font := (symb SUB 1) = "p" OR (symb SUB 1) = "P"; + prot (symb); +. +get blank width: + next entry; + blank in cm := real (symb); + IF NOT last conversion ok COR blank in cm < 0.01 + THEN errorstop ("Blankbreite falsch") + FI; + prot ("Blank=");prot (symb); +. +get linefeed height: + next entry; + lf in cm := real (symb); + IF NOT last conversion ok COR lf in cm < 0.01 + THEN errorstop ("Linefeedhoehe falsch") + FI; + prot ("lf="); prot(symb); +. +get pointsizes: + next entry; + IF symb <> "(" + THEN protline ("alle Pointgroessen = 1 per Voreinstellung") ; + LEAVE get pointsizes + FI; + protline(" "); prot ("lf in punkten="); + get one lf size; + lf := int (inch * real (point (1))/ lf in cm + 0.5); +. +get one lf size: + FOR i FROM 1 UPTO max nr points REP + next entry; + IF symb = ")" + THEN LEAVE get one lf size + ELIF symb = "" + THEN errorstop ("Pointangaben unvollstaendig") + FI; + point(i) := int (symb); + IF NOT last conversion ok COR point (i) < 1 + THEN errorstop ("Pointgroesse falsch") + FI; + prot (symb); prot (","); + PER; +. +get optional x steps per inch: + IF symb = ")" + THEN next entry FI; + IF symb = "" + THEN width := 1.0 + ELSE width := real (symb) + FI; + x step := int (inch * width / blank in cm + 0.5); + factor width := int (width + 0.5); + IF NOT last conversion ok COR x step < 1 + THEN errorstop ("minimale Schritte falsch") + FI; + protline(" "); prot ("Schritte pro Inch="); prot (text(x step)); prot(","); prot (text(lf)); protline(" "); +. +fill pitch and code table with default: + IF prop font + THEN pitch := 255 * code (factor width) + ELSE pitch := code (factor width) + FI; + kode := 31 * ""0""; + kode CAT 224 * ""1""; (* print all *) + inch factor := real (x step) +. +get char width and output function: + WHILE NOT eof (font file) REP + getline (font file, record); + protline (record); + IF (record SUB 1) = "#" AND pos (record, "#", 2, length (record)) > 2 + THEN LEAVE get char width and output function + FI; + get internal code for char; + IF char code > 0 AND char code <= 255 + THEN IF prop font + THEN get char width; + prot (text(factor width)); + replace (pitch, char code, code (factor width)) + FI; + get output function + FI; + PER; +. +get internal code for char: +INT VAR char code; + next entry; prot (symb); + IF length(symb) = 1 + THEN char code := code (symb SUB 1) + ELIF symb >= "000" AND symb <= "255" + THEN char code := int (symb); + IF NOT last conversion ok + THEN errorstop ("Zeichen falsch") + FI + ELSE errorstop ("Zeichen falsch") + FI; + +. +get char width: + next entry; + IF pos (symb, ".") > 0 + THEN width := real (symb); + factor width := int (round(((width * inch factor) / inch), 0)) + ELSE factor width := int (symb) + FI; + IF NOT last conversion ok + THEN errorstop ("Breitenangabe falsch") + FI +. +get output function: + next entry; prot (symb); protline(" "); + IF symb = "" + THEN symb := "1" + FI; + replace (kode, char code, code (int (symb))); + IF NOT last conversion ok + THEN errorstop ("Ausgabefunktion falsch") + FI; +END PROC load font table; + +PROC next entry: +INT VAR next blank pos; +WHILE (record SUB 1) = " " REP + record := subtext (record, 2, length (record)) PER; +next blank pos := pos (record, " "); +IF next blank pos >= 1 + THEN symb := subtext (record, 1, next blank pos - 1); + record := subtext (record, next blank pos + 1) + ELSE symb := record; + record := "" + FI; +END PROC next entry; + +PROC prot (TEXT CONST t): + IF online + THEN put (t) + FI; +END PROC prot; + +PROC protline (TEXT CONST t): + IF online + THEN putline (t) + FI; +END PROC protline; + +init font; (* PACKET Initialisierung ******************************) +. +name: font[font number].name +. +pitch: font[font number].pitch table +. +kode: font [font number].code table +. +lf: font [fontnumber].y steps per inch +. +x step: font [font number].x steps per inch +. +point: font [font number].point size +. +END PACKET fonts routines; diff --git a/system/std.zusatz/1.7.3/src/MINPRINT.ELA b/system/std.zusatz/1.7.3/src/MINPRINT.ELA new file mode 100644 index 0000000..a0bd44a --- /dev/null +++ b/system/std.zusatz/1.7.3/src/MINPRINT.ELA @@ -0,0 +1,94 @@ +PACKET minimal font routines DEFINES lf height of current font, + x factor per inch, + y factor per inch: + +REAL CONST lf height of current font :: 2.54 / 6.0; +INT CONST x factor per inch :: 10, + y factor per inch :: 6; + +END PACKET minimal font routines; + +PACKET minimal printer (* 25.04.84 *) + DEFINES material, + start, + new page, + reset printer, + line, + print text , + printer cmd, + on, + off, + x pos, + y pos, + papersize, + limit, + change type: + + +PROC change type (TEXT CONST name of type): ENDPROC change type; + +PROC material (TEXT CONST value): END PROC material; + +PROC start (REAL CONST x,y): END PROC start; + +PROC papersize (REAL CONST x,y): END PROC papersize; + +PROC limit (REAL CONST l): END PROC limit; + +PROC on (TEXT CONST cmd): END PROC on; + +PROC off (TEXT CONST cmd): END PROC off; + +PROC xpos (REAL CONST cm): END PROC xpos; + +PROC ypos (REAL CONST cm): END PROC ypos; + +PROC printer cmd (TEXT CONST cmd): + out (buffer); buffer := ""; + out(cmd) +END PROC printer cmd; + +INT VAR actual line ; + +TEXT VAR buffer; + +PROC reset printer: + buffer := ""; + actual line := 0 +ENDPROC reset printer; + +PROC print text (TEXT CONST content, INT CONST mode): + buffer CAT content +ENDPROC print text; + +PROC new page: + IF buffer <> "" + THEN line (1.0) + FI; + actual line := actual line MOD 72 ; + IF actual line > 0 + THEN page feed + FI . + +page feed : + INT VAR i ; + FOR i FROM actual line UPTO 71 REP + out(" "13""10"") + PER ; + actual line := 0 + +ENDPROC new page; + +PROC line (REAL CONST lf): + out (buffer); buffer := ""; + IF lf > 0.0 + THEN REAL VAR ist := 0.0 ; + REP + out (""13""10"") ; + actual line INCR 1 ; + ist INCR 1.0 + UNTIL ist >= floor (lf) PER + FI +ENDPROC line; + +ENDPACKET minimal printer; diff --git a/system/std.zusatz/1.7.3/src/TO16.ELA b/system/std.zusatz/1.7.3/src/TO16.ELA new file mode 100644 index 0000000..94cfc73 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/TO16.ELA @@ -0,0 +1,102 @@ +PACKET to 16 DEFINES to 16 : + + +LET OLDRECORD = STRUCT (INT succ, pred, x, y, TEXT line) , + OLDFILE = BOUND ROW 4075 OLDRECORD ; + +LET free root = 1 , + used root = 2 ; + +LET file type 16 = 1002 ; + + +FILE VAR file 17 ; +OLDFILE VAR file 16 ; +DATASPACE VAR file space ; + + +PROC to 16 : + to 16 (last param) +ENDPROC to 16 ; + +PROC to 16 (TEXT CONST file name) : + + last param (file name) ; + file 17 := sequential file (input, file name) ; + disable stop ; + file space := nilspace ; + file 16 := file space ; + type (file space, file type 16) ; + copy 17 to 16 ; + IF NOT is error + THEN replace 17 by 16 file + FI ; + forget (file space) . + +replace 17 by 16 file : + forget (file name, quiet) ; + copy (file space, file name) . + +ENDPROC to 16 ; + +PROC copy 17 to 16 : + + enable stop ; + build used record chain ; + build free record chain . + +build used record chain : + copy all records ; + construct used chains head and circular links . + +copy all records : + INT VAR line ; + FOR line FROM 1 UPTO lines (file 17) REP + copy one record ; + cout (line) + PER . + +copy one record : + INT VAR index := line + 2 ; + TEXT VAR line 17; + record.pred := index - 1 ; + record.succ := index + 1 ; + getline (file 17, line 17) ; + change special 17 chars; + record.line := line 17. + +change special 17 chars: + change all (line 17, ""217"", ""225""); + change all (line 17, ""218"", ""239""); + change all (line 17, ""219"", ""245""); + change all (line 17, ""214"", ""193""); + change all (line 17, ""215"", ""207""); + change all (line 17, ""216"", ""213""); + change all (line 17, ""220"", ""235""); + change all (line 17, ""221"", ""173""); + change all (line 17, ""222"", ""163""); + change all (line 17, ""223"", ""160""); + change all (line 17, ""251"", ""194""). + +construct used chains head and circular links : + record.succ := used root ; + used root record.pred := index ; + used root record.succ := used root + 1 ; + used root record.line := headline (file 17) . + +build free record chain : + free root record.pred := free root ; + free root record.succ := free root ; + free root record.y := index + 1 ; + free root record.line := " 0 1 1" ; + free root record.line CAT text (maxlinelength (file 17), 5) . + +record : CONCR (file 16) (index) . + +used root record : CONCR (file 16) (used root) . + +free root record : CONCR (file 16) (free root) . + +ENDPROC copy 17 to 16 ; + +ENDPACKET to 16 ; diff --git a/system/std.zusatz/1.7.3/src/complex b/system/std.zusatz/1.7.3/src/complex new file mode 100644 index 0000000..d62085b --- /dev/null +++ b/system/std.zusatz/1.7.3/src/complex @@ -0,0 +1,133 @@ + +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; + +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.7.3/src/crypt b/system/std.zusatz/1.7.3/src/crypt new file mode 100644 index 0000000..f6711fa --- /dev/null +++ b/system/std.zusatz/1.7.3/src/crypt @@ -0,0 +1,139 @@ +PACKET cryptograf DEFINES (* Autor: J.Liedtke *) + (* Stand: 01.10.80 *) + crypt , + decrypt : + +TEXT VAR char , in buffer, out buffer ; +INT VAR in pos , key index ; +DATASPACE VAR scratch space := nilspace ; +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 ; + 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.7.3/src/elan lister b/system/std.zusatz/1.7.3/src/elan lister new file mode 100644 index 0000000..dc34176 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/elan lister @@ -0,0 +1,263 @@ +PACKET elan lister DEFINES (* Autor: J.Liedtke *) + (* Stand: 22.03.84 *) + is elan source , + elan list : + + +LET source lines per page = 64 , + x start = 1 , + y start = 2 , + + tag = 1 , + bold = 2 , + + linelength = 120 , + struct comment length = 32 , + max name length = 25 , + struct comment blanks = " " , + refinement layout line = " |" , + headline pre = + " Zeile ***** E L A N EUMEL 1.7 ***** " ; + +INT VAR symbol type , + line nr , + page nr , + line at page ; + +BOOL VAR within defines list ; + +TEXT VAR record, + list pre , + source name , + source prefix , + symbol, + ahead symbol , + bottom blanks := (linelength) * " " ; + + +PROC elan list (FILE VAR source) : + + initialize listing ; + within defines list := FALSE ; + WHILE NOT eof (source) REP + list one source line ; + line nr INCR 1 + PER ; + page bottom ; + start (0.0,0.0) ; + new page . + +initialize listing : + reset printer ; + construct source name and prefix ; + print first page head ; + line nr := 1 . + +construct source name and prefix : + source name := headline (source) ; + INT CONST slash pos := pos (source name, "/") ; + IF slash pos = 0 + THEN source prefix := "" + ELSE source prefix := subtext (source name, slash pos+1) + "/" ; + source name := subtext (source name, 1, slash pos-1) + FI . + +list one source line : + getline (source, record) ; + print list pre ; + printline (record) ; + page if necessary . + +print list pre : + list pre := text (line nr, 5) ; + IF pos (record, "P") = 0 AND pos (record, ":") = 0 + THEN empty layout + ELSE analyze source line + FI ; + list pre CAT ("|") ; + print text (list pre, 0) . + +empty layout : + list pre CAT struct comment blanks . + +analyze source line : + scan (record) ; + next symbol (symbol, symbol type) ; + next symbol (ahead symbol) ; + IF begin of packet THEN packet layout + ELIF within defines list THEN check end of defines part + ELIF begin of proc op THEN proc op layout + ELIF begin of refinement THEN refinement layout + ELSE empty layout + FI . + +begin of packet : + symbol = "PACKET" . + +begin of proc op : + IF is proc or op (symbol) + THEN TRUE + ELIF (symbol <> "END") AND is proc or op (ahead symbol) + THEN symbol := ahead symbol ; + next symbol (ahead symbol) ; TRUE + ELSE FALSE + FI . + +begin of refinement : + symbol type = tag AND ahead symbol = ":" AND NOT within defines list . + +packet layout : + IF not at page head + THEN page bottom ; + page head + FI ; + layout (" ", ahead symbol, "*") ; + within defines list := TRUE . + +check end of defines part : + empty layout ; + scan (record) ; + REP + nextsymbol (symbol) ; + IF symbol = ":" + THEN within defines list := FALSE + FI + UNTIL symbol = "" PER . + +proc op layout : +(*printline ("") ;*) + printline ("") ; + printline ("") ; + IF not two free lines + THEN page bottom ; + page head + FI ; + layout (" ", ahead symbol, ".") . + +refinement layout : +(*print line (refinement layout line) ;*) + print line (refinement layout line) ; + IF not two free lines THEN page bottom; page head FI; + layout (" ", symbol, " ") . + + +print first page head : + page nr := 1 ; + page head . + +page if necessary : + IF line at page > source lines per page + THEN page bottom ; + page head + FI . + +not two free lines : + line at page >= source lines per page - 2 . + +not at page head : + line at page > 5 . + +ENDPROC elan list ; + +BOOL PROC is proc or op (TEXT CONST symbol) : + + symbol = "PROC" OR symbol = "PROCEDURE" + OR symbol = "OP" OR symbol = "OPERATOR" + +ENDPROC is proc or op ; + +PROC layout (TEXT CONST pre, TEXT VAR name, TEXT CONST post) : + + list pre CAT pre ; + name := subtext (name, 1, max name length) ; + list pre CAT name ; + list pre CAT " " ; + generate remaining struct comment . + +generate remaining struct comment : + INT VAR i ; + FOR i FROM 1 UPTO remaining struct comment length REP + list pre CAT post + PER . + +remaining struct comment length : + struct comment length - LENGTH pre - min(LENGTH name,max name length) - 1. + +ENDPROC layout ; + +PROC print line (TEXT CONST line text) : + + print text (line text, 0) ; + line (1.0) ; + line at page INCR 1 + +ENDPROC print line ; + +PROC printtext (TEXT CONST t, BOOL CONST b) : + out (t) +ENDPROC printtext ; (*** sonst im Hardwaretreiber *********) + +PROC page head : + + new page ; + print text (headline pre, 0) ; + print text (date, 0); (* R. Nolting 27.10.83 *) + print text (" ***** ",0); + print text (source name, 0) ; + line (4.0) ; + line at page := 1 + +ENDPROC page head ; + +PROC page bottom : + + WHILE line at page < source lines per page REP + line (1.0) ; + line at page INCR 1 + PER ; + line (1.0) ; + printtext (text (source prefix + text (page nr), 8), FALSE) ; + printtext (bottom blanks, FALSE) ; + printtext (source prefix + text (page nr), FALSE) ; + line (1.0) ; + page nr INCR 1 . + +ENDPROC page bottom ; + +BOOL PROC is elan source (FILE VAR source) : + + input (source) ; + get first symbol ; + symbol type = tag COR is bold begin of program COR is comment . + +is bold begin of program : + symbol type = bold CAND is elan bold . + +is elan bold : + symbol = "PACKET" COR is proc or op (symbol) COR is data declaration . + +is data declaration : + next symbol (symbol) ; + symbol = "VAR" OR symbol = "CONST" . + +is comment : + pos (record, "(*") > 0 OR pos (record, "{") > 0 . + + +get first symbol : + get first non blank record ; + scan (record) ; + next symbol (symbol, symbol type) ; + reset (source) . + +get first non blank record : + REP + getline (source, record) + UNTIL record contains non blank OR eof (source) PER . + +record contains non blank : + pos (record, ""33"",""254"", 1) > 0 . + +ENDPROC is elan source ; + +ENDPACKET elan lister ; diff --git a/system/std.zusatz/1.7.3/src/eumel printer b/system/std.zusatz/1.7.3/src/eumel printer new file mode 100644 index 0000000..79a4b2c --- /dev/null +++ b/system/std.zusatz/1.7.3/src/eumel printer @@ -0,0 +1,369 @@ +PACKET eumel printer DEFINES +(*************************************************************************** +***** EUMEL - DRUCKER ** Author: A. Reichpietch ** +***** ** R. Nolting ** +***** ** Date: 30.09.81 Vers. 0 ** +***** ** 15.03.82 Vers. 1.0 ** +***** ** 22.07.82 Vers. 1.1 ** +***** ** 01.10.82 Vers. 1.2 ** +***** reelle Werte fuer limit etc. ** 15.01.83 Vers. 2.0 ** +***** direkte Druckerkommandos (Hardware) ** 15.08.83 Vers. 2.1 ** +***** ** 15.12.83 Vers. 2.2 ** +***** alle Zeilen-/Spaltenprocs entfernt ** 9.1.84 Vers. 2.3 ** +***** neue 'print text' prozedur ** 04.03.84 Vers. 2.4 ** +***************************************************************************) + + print, + reset print, + print line, + pages printed, + + is elan source , (* dummy Prozeduren , koennen von *) + elan list : (* 'elan lister' ueberdeckt werden *) + + +LET blank = " " , + backspace = ""8"" , + begin mark underline = ""15"" , + end mark underline = ""14"" ; +LET paragraph end = " "; +TEXT VAR inline := blank, + outline := blank, + type := blank, + command char, + help := blank; +TEXT VAR command, + par 1, par 2, + skip end text; +REAL VAR y position, y step, y max, y factor; +INT VAR pagenr, from, to; +INT VAR printed pages; +BOOL VAR not skipped, lines to be skipped, + first text line, end of paragraph, + linefeed needed; +LET std pagelength = 25.4; + +INT VAR print mode set := left adj, collumn print possible; +LET left adj= 0; +LET right adj= 1; +LET centre adj= 2; +LET block line= 3; +LET left col= 4; +LET right col= 5; +LET centre col= 6; +LET block col= 7; +LET collumn print = 4; + + +PROC print (FILE VAR f): + enable stop; + reset printer; + reset print; + print (f, from, to); +END PROC print; + +PROC print (FILE VAR f, INT CONST first page, last page): + enable stop; + from := first page; + to := last page; + IF from > 1 THEN not skipped := FALSE FI; + WHILE (NOT eof(f)) AND (pagenr <= to) REP + getline (f, inline); + print input line; + ENDREP; + start(0.0, 0.0); make page; +ENDPROC print; + +PROC reset print: + first text line := TRUE; + not skipped := TRUE; + lines to be skipped := FALSE; + command char := "#"; + print mode set := left adj; + end of paragraph := TRUE; + inline := ""; + y max := stdpagelength ; + y position := 10000.0; + y step := lf height of current font; + y factor := 1.0; + pagenr := 0; + from := 1; to := maxint; + printed pages := -1; (* move to top of first page will set to 0 *) +ENDPROC reset print; + +INT PROC pages printed: + printed pages +END PROC pages printed; + +PROC print line (TEXT CONST in): + inline := in; + print input line; +END PROC print line; + +PROC print input line: +(* debug out ("print line:"); out (in); out (""10""13""); debug *) +INT VAR compos; +INT VAR endpos := 0, tpos := 1; +IF lines to be skipped + THEN IF pos (inline, skip end text) > 1 AND (inline SUB 1) = command char + THEN lines to be skipped := FALSE + FI; + LEAVE print input line + FI; + linefeed needed := FALSE; +IF end of paragraph + THEN collumn print possible := collumn print + ELSE collumn print possible := 0 + FI; +compos := LENGTH inline; +IF (inline SUB compos) = paragraph end + THEN end of paragraph := TRUE; + inline := subtext (inline, 1, compos -1) + ELSE end of paragraph := FALSE; + FI; + compos := pos (inline, command char); + IF compos <= 0 + THEN print the line (inline); + new line; + LEAVE print input line + FI; + outline := ""; + extract commands from input; + IF outline <> "" + THEN print the line (outline); new line + ELIF linefeed needed + THEN new line FI; +. +extract commands from input: +WHILE compos > 0 REP + outline CAT subtext (inline, tpos, compos-1); + endpos := pos ( inline, command char, compos +1); + IF endpos <= compos + THEN endpos := compos - 1; + compos := 0 + ELSE command := subtext ( inline, compos +1, endpos -1); + analyze command ( command); + tpos := endpos +1; + compos := pos(inline, command char, tpos); + FI; + PER; +outline CAT subtext (inline, endpos + 1); + +ENDPROC print input line; + + +TEXT VAR comlist:="ub:1.0ue:2.0type:4.1linefeed:5.1limit:6.1free:7.1page:8.01 +pagenr:9.2pagelength:10.1start:11.2foot:12.0end:13.0head:15.0headeven:16.0 +headodd:17.0bottom:19.0bottomeven:20.0bottomodd:21.0" +LET com list 2 = +"on:22.1off:23.1block:24.0left:25.0right:26.0centre:27.0center:28.0material:31.1papersize:32.2print:33.2"; +comlist CAT comlist 2; + +PROC analyze command (TEXT CONST command): +(* debug out ("analyze command:"); out (command); out (""10""13""); debug *) +IF pos (command, "-") = 1 + THEN LEAVE analyze command + ELIF pos (command, "/") = 1 + THEN help := subtext (command, 2); + print line so far; + printer cmd (help); + LEAVE analyze command + FI; +INT VAR comindex := -1, number := 0; + par 1 := ""; par 2 := ""; + disable stop; + analyze command ( com list, command, 3, comindex, number, par 1, par 2); + IF is error + THEN clear error + ELSE select command + FI; + enable stop; +. +select command : + SELECT comindex OF + CASE 1 : print line so far; on ("u"); + CASE 2 : print line so far; off ("u"); + CASE 4 : print line so far; set type (par 1) + CASE 5 : set linefeed ( par 1) + CASE 6 : set limit (par 1) + CASE 7 : print line so far; free (par 1) + CASE 8 : print line so far; make page + CASE 9 : + CASE 10 : set pagelength (par 1) + CASE 11 : set start (par 1, par 2) + CASE 12 : (* skip text ("end") *) + CASE 15,16,17 : (* skip text ("end") *) + CASE 19,20,21 : (* skip text ("end") *) + CASE 22 : print line so far; on (par1) + CASE 23 : print line so far; off (par1) + CASE 24 : print line so far; print mode set := block line; + CASE 25 : print line so far; print mode set := left adj; + CASE 26 : print line so far; print mode set := right adj + CASE 27 : print line so far; print mode set := centre adj + CASE 28 : comindex := print mode set MOD 4; + IF comindex = block line + THEN inline CAT "#block#" + ELIF comindex = left adj + THEN inline CAT "#left#" + ELIF comindex = right adj + THEN inline CAT "#right#" + FI; + print mode set := centre adj; +(* the following commands must appear before any text *) + CASE 31 : IF first text line THEN material (par1) FI + CASE 32 : IF first text line THEN do papersize (par1, par2) FI + CASE 33 : IF first text line THEN print from page till page (par1, par2) FI + OTHERWISE + END SELECT ; +. +print line so far: + IF outline <> "" + THEN print the line (outline); + outline := ""; + linefeed needed := TRUE + FI; + +ENDPROC analyze command; + +PROC do papersize (TEXT CONST s, t): +REAL VAR w, l; + IF ok (par1, w) AND ok (par2, l) + THEN papersize (w, l) + FI; +END PROC do papersize; + +PROC print from page till page(TEXT VAR s, t): +INT VAR i, j; + IF ok (par1, i) AND ok (par2, j) + THEN from := i; + to := j; + FI; +END PROC print from page till page; + +PROC set type (TEXT CONST new type): + change type (new type); + y step := lf height of current font; +ENDPROC set type; + +PROC make page : + IF y position > 0.0 CAND NOT first text line + THEN y position := y max + 1.0; new line + FI; + end of paragraph := TRUE; + inline := ""; (* this stops further processing of the input line *) +ENDPROC make page; + +PROC skip text (TEXT CONST endword): + lines to be skipped := TRUE; + skip end text := endword; + inline := ""; (* possible rest of the line is not examined *) +END PROC skip text; + +PROC set linefeed ( TEXT CONST lf): +REAL VAR l:= real (lf); + IF last conversion ok THEN y factor := l FI; +ENDPROC set linefeed; + +PROC set limit ( TEXT CONST l): + REAL VAR len; + IF ok (l, len) + THEN limit (len) + FI; +ENDPROC set limit; + +BOOL PROC ok ( TEXT CONST param, INT VAR number): + number := int (param) ; + last conversion ok +ENDPROC ok; + +BOOL PROC ok ( TEXT CONST param, REAL VAR number): + number := real (param) ; + last conversion ok +ENDPROC ok; + +PROC set pagelength (TEXT CONST y): +REAL VAR iy ; + IF ok (y, iy ) + THEN y max := iy; +FI; +ENDPROC set pagelength; + +PROC set start (TEXT CONST x, y): +REAL VAR rx, ry; + IF ok (x, rx) AND ok (y, ry) + THEN start (rx, ry) + FI; +ENDPROC set start; + +PROC free (TEXT CONST p): +REAL VAR x, y := y factor; + IF ok (p, x) + THEN advance + FI; +y factor := y; +end of paragraph := TRUE; + inline := ""; (* this stops further processing of the input line *) +. +advance: + y factor := x / y step; + IF outline <> "" + THEN print the line (outline); + outline := "" + FI; + IF first text line + THEN new line FI; +new line; +END PROC free; + +PROC print the line ( TEXT CONST in): +(* debug out ("print the line:"); out (in); out (print mode set); +out (""10""13""); debug *) +IF first text line + THEN first text line := FALSE; new line FI; +IF not skipped + THEN IF print mode set = blockline + THEN IF end of paragraph + THEN print text (in, left adj + collumn print possible) + ELSE print text (in, blockline + collumn print possible) + FI + ELSE print text (in, print mode set + collumn print possible) + FI + FI; +ENDPROC print the line; + +PROC new line: +(* debug out ("new line: lf="); out (text(yfactor)); out (""10""13""); debug *) +IF page is full + THEN pagenr INCR 1; + IF not skipped + THEN printed pages INCR 1; + new page + FI; + check printmodes; + y position := 0.0 + ELSE IF not skipped + THEN line (y factor) + FI; + y position INCR yfactor * y step + FI; +ENDPROC new line; + +PROC check printmodes: + not skipped := ( pagenr >= from) AND ( pagenr <= to); +ENDPROC check printmodes; + +BOOL PROC page is full: + y position + yfactor * y step > y max +ENDPROC page is full; + +(********** dummys ************) + +BOOL PROC is elan source (FILE VAR source) : + FALSE +ENDPROC is elan source ; + +PROC elan list (FILE VAR source) : + print (source) +ENDPROC elan list ; + +ENDPACKET eumel printer; diff --git a/system/std.zusatz/1.7.3/src/eumelmeter b/system/std.zusatz/1.7.3/src/eumelmeter new file mode 100644 index 0000000..24f5833 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/eumelmeter @@ -0,0 +1,130 @@ + (* 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.7.3/src/free channel b/system/std.zusatz/1.7.3/src/free channel new file mode 100644 index 0000000..89f7ce0 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/free channel @@ -0,0 +1,292 @@ +PACKET free channel DEFINES (* Autor: J.Liedtke *) + (* Stand: 05.10.82 *) + FCHANNEL , + := , + free channel , + open , + close , + out , + in , + dialogue : + + + +LET ack = 0 , + nak = 1 , + break code = 6 , + empty message code = 256 , + long message code = 257 , + file message code = 1024 , + open code = 1000 , + close code = 1001 , + + cr = ""13"" ; + +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 , used by ; +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) : + + TASK VAR task id ; + 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) : + + call (channel.server, close code, ds, response code) + +ENDPROC close ; + +PROC close (TEXT CONST channel server) : + + 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 out (FCHANNEL VAR channel, DATASPACE CONST file space) : + + out (channel, file space, ""0"") + +ENDPROC out ; + +PROC out (FCHANNEL VAR channel, DATASPACE CONST file space, + TEXT CONST handshake char) : + + forget (ds) ; + ds := file space ; + call (channel.server, file message code + code (handshake char) , + ds, response code) ; + forget (ds) ; + ds := nilspace + +ENDPROC out ; + + +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 without advertise ; + send handshake ack + ELSE send (partner, nak, ds) + FI + PER . + +use channel : + ping pong (partner, ack, ds, message code) ; + REP + execute message ; + response option + PER . + +execute message : + IF message code < 0 + THEN LEAVE use channel + ELIF message code < 256 + THEN out (code (message code)) + ELIF message code = long message code + THEN msg := ds ; + out (CONCR (msg)) + ELIF message code >= file message code + THEN send file ; + clear error + ELIF message code = close code + THEN LEAVE use channel + FI . + +response option : + 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 ; + REP + char := incharety ; + response CAT char + UNTIL char = "" PER ; + CONCR (msg) := response ; + 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 . + +break without advertise : + INT VAR receipt ; + call (supervisor, break code, ds, receipt) . + +send handshake ack : + send (partner, ack, ds) . + +ENDPROC free channel ; + +PROC send file : + + enable stop ; + get handshake ; + file := sequential file (input,ds) ; + REP + getline (file, record) ; + out (record) ; + out (cr) ; + handshake option + UNTIL eof (file) PER . + +get handshake : + TEXT CONST handshake char := code (message code - file message code) . + +handshake option : + IF handshake char <> ""0"" + THEN wait for handshake or time out + FI . + +wait for handshake or time out : + REP + char := incharety (300) + UNTIL char = handshake char OR char = "" PER ; + IF char = "" + THEN LEAVE send file + FI . + +ENDPROC send file ; + +ENDPACKET free channel ; diff --git a/system/std.zusatz/1.7.3/src/longint b/system/std.zusatz/1.7.3/src/longint new file mode 100644 index 0000000..ac3dad5 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/longint @@ -0,0 +1,422 @@ +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.7.3/src/matrix b/system/std.zusatz/1.7.3/src/matrix new file mode 100644 index 0000000..fbc5ffc --- /dev/null +++ b/system/std.zusatz/1.7.3/src/matrix @@ -0,0 +1,470 @@ +PACKET matrix DEFINES MATRIX, matrix, idn, (* Stand : 21.10.83 *) + :=, 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.rows); + INT VAR i; + FOR i FROM 1 UPTO m.rows + 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.columns); + INT VAR i; + FOR i FROM 1 UPTO m.columns + 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; + FOR j FROM 1 UPTO n + REP pivotsuche (a, j, pos); + zeilentausch (a, j, pos); + transformiere die matrix + PER; + produkt der pivotelemente . + +transformiere die matrix : + REAL VAR h := 1.0/sub (a, j, j); + 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 . + +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.7.3/src/minimal fonts routines b/system/std.zusatz/1.7.3/src/minimal fonts routines new file mode 100644 index 0000000..adcfc66 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/minimal fonts routines @@ -0,0 +1,9 @@ +PACKET minimal fonts routines DEFINES lf height of current font, + x factor per inch, + y factor per inch: + +REAL CONST lf height of current font :: 2.54 / 6.0; +INT CONST x factor per inch :: 10, + y factor per inch :: 6; + +END PACKET minimal fonts routines; diff --git a/system/std.zusatz/1.7.3/src/printer-M b/system/std.zusatz/1.7.3/src/printer-M new file mode 100644 index 0000000..45b1381 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/printer-M @@ -0,0 +1,69 @@ +PACKET multi user printer : + +INT VAR printer channel ; + + put ("Druckerkanal:") ; + get (printer channel) ; + server channel (printer channel); + + command dialogue (FALSE) ; + spool manager (PROC printer) ; + + +LET ack = 0 , + fetch code = 11 , + file type = 1003 ; + +INT VAR reply , old heap size ; + +DATASPACE VAR ds ; + +FILE VAR file ; + +PROC printer : + + disable stop ; + continue (server channel) ; + IF is error + THEN clear error ; + end + FI ; + + old heap size := heap size ; + REP + forget (ds) ; + execute print ; + IF is error AND online + THEN put error + FI ; + clear error ; + 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 ; + REP + ds := nilspace ; + call (father, fetch code, ds, reply) ; + IF reply = ack CAND type (ds) = file type + THEN print file + FI ; + forget (ds) + PER . + +print file : + file := sequential file (input, ds) ; + IF is elan source (file) + THEN elan list (file) + ELSE print (file) + FI . + +ENDPROC execute print ; + +ENDPACKET multi user printer ; diff --git a/system/std.zusatz/1.7.3/src/printer-S b/system/std.zusatz/1.7.3/src/printer-S new file mode 100644 index 0000000..5124cc4 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/printer-S @@ -0,0 +1,36 @@ +PACKET single user print cmd DEFINES print : + +INT VAR print channel ; +FILE VAR print file ; + +put ("Druckerkanal:") ; +get (print channel) ; + +PROC print : + + print (last param) + +ENDPROC print ; + +PROC print (TEXT CONST file name) : + + last param (file name) ; + print file := sequential file (input, file name) ; + continue (print channel) ; + disable stop ; + execute print ; + continue (0) + +ENDPROC print ; + +PROC execute print : + + enable stop ; + IF is elan source (print file) + THEN elan list (print file) + ELSE print (print file) + FI + +ENDPROC execute print ; + +ENDPACKET single user print cmd ; diff --git a/system/std.zusatz/1.7.3/src/purge b/system/std.zusatz/1.7.3/src/purge new file mode 100644 index 0000000..e325646 --- /dev/null +++ b/system/std.zusatz/1.7.3/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.7.3/src/referencer b/system/std.zusatz/1.7.3/src/referencer new file mode 100644 index 0000000..5606e4c --- /dev/null +++ b/system/std.zusatz/1.7.3/src/referencer @@ -0,0 +1,1077 @@ +PACKET referencer errors DEFINES report referencer error: + +(* Programm zur Fehlerbehandlung des referencers. + Autor: Rainer Hahn + Stand: 04.05.83 +*) +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; + out (message); + line. + +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 + Stand: 04.05.83 +*) +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 + Stand: 04.05.83 +*) +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, + klammer auf = 40, + 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 + Stand: 19.03.84 +*) +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 ueberpruefen + ELSE errorstop ("Eingabe-Datei nicht vorhanden") + FI. + +dump file ueberpruefen: + IF exists (dump file) + THEN errorstop ("Ausgabe-Datei existiert bereits") + ELSE disable stop; + start referencing (check file, dump file); + forget (ds); + enable stop; + 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 ("->"); + put (dump file); + line. + +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; + maxindex := endop 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 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): + put ("Ausgabedatei erstellen"); + line; + f := sequential file (output, dump file); + INT VAR i; + kopieren und ggf fehlermeldung; + modify (f); + ggf sortieren; + zeile ggf aufspalten. + +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; diff --git a/system/std.zusatz/1.7.3/src/reporter b/system/std.zusatz/1.7.3/src/reporter new file mode 100644 index 0000000..13e76b5 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/reporter @@ -0,0 +1,479 @@ +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 ('frequency count') und beachtet 'assertions'. + + Autor: Rainer Hahn + Letzte Aenderung: 11.01.84 + Ausgabe der Gesamtaufrufe (Jan. 84) +*) + +FILE VAR input file; + +INT VAR zeilen nr, + type; + +TEXT VAR zeile, + dummy, + dummy1, + symbol; + +LET quadro fis = "####", + triple fis = "###", + double fis = "##", + + tag = 1 ; + +DATASPACE VAR ds := nilspace; +BOUND ROW max STRUCT (INT anzahl, BOOL proc) VAR zaehlwerk; + +LET max = 2000; + +(******************* 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 + FI; + last param (name); + 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 first record (input file); + WHILE NOT eof (input file) 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; + down (input file) + 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: + IF NOT (pos (zeile, "END") > 0) + THEN scanne kopf; + insertiere trace anweisung + FI. + +scanne kopf: + scan (zeile); + REP + next symbol (symbol, type); + IF ende der zeile gescannt + THEN vorwaerts; + lese zeile; + continue scan (zeile); + next symbol (symbol, type) + FI + UNTIL symbol = "PROC" OR symbol = "OP" END REP; + baue trace statement fuer kopf auf. + +baue trace statement fuer kopf auf: + dummy := double fis; + dummy CAT "report("""; + dummy CAT symbol; + dummy CAT " "; + IF ende der zeile gescannt + THEN vorwaerts; + lese zeile; + continue scan (zeile) + FI; + next symbol (symbol, type); + dummy CAT symbol; + dummy CAT " "; + next symbol (symbol, type); + IF type = tag + THEN dummy CAT symbol + FI. + +ende der zeile gescannt: + type >= 7. + +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("""; + 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 (********** bei neuer Compiler-Version aendern: + fuelle zeile ggf auf 75 spalten auf; + zeile CAT dummy + die naechste drei zeilen dann loeschen **************) + down (input file); + 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: + pos (zeile, ":") >= length (zeile) - 1. + +(* Kommentarklammern beineuer Compiler Version hier weg: +fuelle zeile ggf auf 75 spalten auf: + IF length (zeile) < 75 + THEN dummy1 := (75 - length (zeile)) * " "; + zeile CAT dummy1 + FI.*) +END PROC schreibe zeile mit report statement; + +PROC vorwaerts: + 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 + FI; + last param (name); + 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 first record (input file); + zeilen nr := 1; + WHILE NOT eof (input file) REP + lese zeile; + IF pos (zeile, double fis) > 0 + THEN eliminiere zeichenketten in dieser zeile + ELSE down (input file) + 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); + down (input file) + 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 trace on, haeufigkeit on; + +PROC report (TEXT CONST message): + IF NOT exists ("TRACE") + THEN trace file := sequential file (output, "TRACE"); + trace on := TRUE; + haeufigkeit on := FALSE; + FI; + BOOL CONST ist prozedur :: + (pos (message, "PROC") > 0 OR pos (message, "OP") > 0); + IF trace on + THEN ablauf verfolgung + FI; + IF haeufigkeit on + THEN haeufigkeits zaehlung (ist prozedur) + FI. + +ablauf verfolgung: + dummy := text (pcb (1)); + dummy CAT ": "; + IF NOT ist prozedur + THEN dummy CAT " " + FI; + dummy CAT message; + putline (trace file, dummy). +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 := 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 haeufigkeits zaehlung (BOOL CONST ist prozedur): + IF pcb (1) <= max + THEN zaehlwerk [pcb (1)]. anzahl INCR 1; + zaehlwerk [pcb (1)] . proc := ist prozedur +FI +END PROC haeufigkeits zaehlung; + +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); + enable stop. +END PROC generate counts; + +PROC insert counts (TEXT CONST name): + enable stop; + IF exists (name) + THEN input file := sequential file (modify, name) + ELSE errorstop ("input file does not exist") + 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 zeilennr <= 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; + dummy1 := text (zaehlwerk [zeilen nr] . anzahl); + dummy CAT dummy1; + 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: + forget (ds). + +statistik ausgeben: + line (2); + put ("Anzahl der Gesamtaufrufe:"); + put (gesamt aufrufe); + line; + put ("davon:"); + line; + put (proc aufrufe); put ("Prozeduren oder Operatoren"); + line; + put (andere aufrufe); put ("Refinements und andere"); + line. +END PROC insert counts; + +END PACKET reporter routines; diff --git a/system/std.zusatz/1.7.3/src/scheduler b/system/std.zusatz/1.7.3/src/scheduler new file mode 100644 index 0000000..7a76f10 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/scheduler @@ -0,0 +1,419 @@ + +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.7.3/src/spool manager b/system/std.zusatz/1.7.3/src/spool manager new file mode 100644 index 0000000..8f9ab9f --- /dev/null +++ b/system/std.zusatz/1.7.3/src/spool manager @@ -0,0 +1,377 @@ +PACKET spool manager DEFINES (* Autor: J. Liedtke *) + spool manager, server channel: (* 21.05.84 *) + + +LET que size = 100 , + + ack = 0 , + nak = 1 , + error nak = 2 , + second phase ack = 5 , + + fetch code = 11 , + save code = 12 , + erase code = 14 , + list code = 15 , + all code = 17 , + continue code = 100, + + empty = 0 , + used = 1 ; + +TASK VAR order task , waiting server , from task , server ; +INT VAR order code , reply , first , last , list index ; + +DATASPACE VAR ds ; + +TEXT VAR from title ; + +BOUND STRUCT (TEXT name, write pass, read pass) VAR msg ; +BOUND TEXT VAR error msg ; +BOUND STRUCT (TEXT tname, tpass, TASK task) VAR sv msg ; + +FILE VAR list file ; +TEXT VAR entry name, entry task; + +INT VAR command index , params ; +TEXT VAR command line, param 1, param 2 ; + +LET spool command list = +"break:1.0start:2.01stop:4.0first:5.0killer:6.0 " ; + + +LET ENTRY = STRUCT (TEXT title, TASK origin, DATASPACE space, INT status) ; + +ROW que size ENTRY VAR que ; + + +INT VAR server chan := 0; + +PROC server channel (INT CONST ch): + server chan := ch + +END PROC server channel; + +INT PROC server channel: + server chan + +END PROC server channel; + +PROC spool manager (PROC server start) : + INT VAR old heap size := heap size; + begin (PROC server start, server) ; + set autonom ; + break ; + disable stop ; + first := 1 ; + last := 1 ; + from task := niltask ; + waiting server := niltask ; + spool ; + clear error ; + forget all dataspaces. + +forget all dataspaces : + INT VAR i ; + FOR i FROM 1 UPTO que size REP + forget (que (i).space) + PER . + +spool: + REP + wait (ds, order code, order task) ; + IF order code = fetch code THEN out of que + ELIF order code = save code THEN prepare into que + ELIF order code = second phase ack THEN into que + ELIF order code = erase code THEN delete que entry + ELIF order code = list code THEN list spool + ELIF order code = all code THEN y all + ELIF order code >= continue code + AND order task = supervisor THEN spool command (PROC server start) + FI; + clear error + PER; + collect heap garbage if necessary. + +collect heap garbage if necessary: + IF heap size > old heap size + 2 + THEN collect heap garbage; + old heap size := heap size + FI. + +ENDPROC spool manager ; + +PROC out of que : + + forget (ds) ; + IF NOT (order task < myself) + THEN error ("not parent") + ELIF que empty + THEN waiting server := order task + ELSE send (order task, ack, que (first).space) ; + inc first + FI . + +que empty : first = last . + +ENDPROC out of que ; + +PROC inc first : + + que (first).status := empty ; + REP + first := first MOD que size + 1 ; + UNTIL first = last OR que (first).status <> empty PER + +ENDPROC inc first ; + +PROC dec first : + + first DECR 1 ; + IF first = 0 + THEN first := que size + FI + +ENDPROC dec first ; + +PROC prepare into que : + + msg := ds ; + from task := order task ; + from title := CONCR (msg).name ; + send (order task, second phase ack, ds) . + +ENDPROC prepare into que ; + +PROC into que : + + IF order task = from task + THEN try entry into spool + ELSE send (order task, nak, ds) + FI . + +try entry into spool : + IF que full + THEN error ("spool overflow") + ELSE entry (que (last)) ; + last := next (last) ; + send (order task, ack, ds) ; + awake server if necessary + FI . + +awake server if necessary : + IF NOT is niltask (waiting server) + THEN send (waiting server, ack, que (first).space , reply) ; + IF reply = ack + THEN waiting server := niltask ; + inc first + FI + FI . + +que full : first = next (last) . + +ENDPROC into que ; + +PROC entry (ENTRY VAR que entry) : + + que entry.title := from title ; + que entry.origin := from task ; + que entry.space := ds ; + que entry.status := used ; + +ENDPROC entry ; + +INT PROC next (INT CONST index) : + + index MOD que size + 1 + +ENDPROC next ; + + +PROC delete que entry : + + msg := ds ; + INT VAR index := first ; + WHILE index <> last REP + IF entry found + THEN erase entry (index) ; + send (order task, ack, ds) ; + LEAVE delete que entry + FI ; + index := next (index) + PER ; + error ("your file does not exist") . + +entry found : + entry.status = used CAND entry.origin = order task + CAND entry.title = CONCR (msg).name . + +entry : que (index) . + +ENDPROC delete que entry ; + +PROC erase entry (INT CONST index) : + + entry.status := empty ; + forget (entry.space) ; + IF index = first + THEN inc first + FI . + +entry : que (index) . + +ENDPROC erase entry ; + +PROC list spool : + + forget (ds) ; + ds := nilspace ; + list file := sequential file (output, ds) ; + to first que entry ; + get next que entry (entry name, entry task) ; + WHILE entry name <> "" REP + putline (list file, text (entry task, 15) + " : " + entry name); + get next que entry (entry name, entry task) + PER; + send (order task, ack, ds) . + +ENDPROC list spool ; + +BOUND THESAURUS VAR all thesaurus; + +PROC y all: + forget (ds); + ds := nilspace; + all thesaurus := ds; + all thesaurus := empty thesaurus; + to first que entry; + get next que entry (entry name, entry task); (* hier erster Eintrag *) + WHILE entryname <> "" REP + IF entry task = name (order task) + AND NOT (all thesaurus CONTAINS entry name) + THEN insert (all thesaurus, entry name) + FI; + get next que entry (entry name, entry task) + PER; + send (order task, ack, ds) + +END PROC y all; + +PROC to first que entry : + + list index := first - 1 + +ENDPROC to first que entry ; + +PROC get next que entry (TEXT VAR entry name, origin task name): + + WHILE list index <> last REP + list index := next (list index) + UNTIL que (list index).status <> empty PER ; + IF que (list index).status = used + THEN origin task name := name (que (list index).origin) ; + entry name := que (list index).title + ELSE entry name := ""; + origin task name := "" + FI . + +ENDPROC get next que entry ; + +PROC error (TEXT CONST error text) : + + forget (ds) ; + ds := nilspace ; + error msg := ds ; + CONCR (error msg) := error text ; + send (order task, error nak, ds) + +ENDPROC error ; + +PROC spool command (PROC server start) : + + enable stop ; + continue (order code - continue code) ; + command dialogue (TRUE) ; + disable stop ; + REP + get command ("gib spoolkommando :", command line); + analyze command (spool command list, command line, 3, + command index, params, param1, param2); + execute command + PER . + +execute command : + SELECT command index OF + CASE 1 : break cmd + CASE 2 : start cmd + CASE 3 : start channel cmd + CASE 4 : stop cmd + CASE 5 : first cmd + CASE 6 : killer cmd + OTHERWISE do (command line) END SELECT . + +start channel cmd: + server channel (int (param1)); + start cmd; + break cmd. + +break cmd: + break; set autonom ; LEAVE spool command. + +start cmd : + IF is niltask (server) + THEN begin (PROC server start, server) + FI . + +stop cmd : + IF NOT is niltask (server) + THEN command dialogue (FALSE) ; + end (server) ; + server := niltask + FI . + +first cmd : + line ; + to first que entry ; + get next que entry (entry name, entry task); + IF entry name = "" + THEN LEAVE first cmd + FI ; + REP + get next que entry (entry name, entry task) ; + IF entry name = "" + THEN LEAVE first cmd + FI; + say (text (entry task, 15) + " : " + entry name) ; + IF yes (" als erstes") + THEN make to first entry ; + LEAVE first cmd + FI + PER . + +make to first entry : + IF first = next (last) + THEN errorstop ("spool overflow") + ELSE dec first ; + que (first) := que (list index) ; + erase entry (list index) + FI . + + +killer cmd : + line ; + to first que entry ; + REP + get next que entry (entry name, entry task) ; + IF entry name = "" + THEN LEAVE killer cmd + FI ; + say (text (entry task, 15) + " : " + entry name) ; + IF yes (" loeschen") + THEN erase entry (list index) + FI + PER . + +ENDPROC spool command ; + +ENDPACKET spool manager ; diff --git a/system/std.zusatz/1.7.3/src/std printer b/system/std.zusatz/1.7.3/src/std printer new file mode 100644 index 0000000..f00fa80 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/std printer @@ -0,0 +1,434 @@ +PACKET std printer DEFINES reset printer, (* F. Klapper *) + new page, (* 21.05.84 *) + start, + printer cmd, + on, + off, + material, + papersize, + limit, + change type, + print text, + x pos, + y pos, + line: + +LET begin mark cmd = ""15"", (* Kommandos fr 'output buffer' *) + end mark cmd = ""14"", + bsp cmd = ""8"" , + printercmd cmd = ""16"", + begin mark code = 15, + end mark code = 14, + bsp code = 8, + printercmd code = 16, + + cr = ""13"", (* Steuerzeichen fr die Ausgabe *) + lf = ""10"", + underline char = "_", + + inch = 2.54, (* Konstanten *) + max printer cmds per line = 10; + +INT CONST std length of paper :: 12 * y factor per inch, + std width of paper :: cm to x steps (13.2 * inch), + std limit :: cm to x steps (12.0 * inch), + std first line :: 5, + std first collumn :: cm to x steps (inch), + + no xpos :: - 10; (* beliebige negative ganze Zahl *) + +INT VAR first collumn, + first line, + xlimit, + actual line, + x pos steps, + width of paper, + length of paper, + x pos mode; + +BOOL VAR block mode, + underline on, (* gibt durch on / off gesetzten Zustand an *) + underline out; (* gibt Zustand an der bis jetzt durch output buffer + ausgegebenen Stelle an *) +TEXT VAR buffer, + x pos buffer, + left margin; + +ROW max printer cmds per line TEXT VAR cmd arry; +INT VAR cmd pointer; + + length of paper := std length of paper; + first line := std first line; + actual line := 0; + buffer := ""; + reset printer; + +INT PROC cm to x steps (REAL CONST cm): + int ((abs (cm) * real (x factor per inch) / inch) + 0.5) +END PROC cm to x steps; + +INT PROC cm to y steps (REAL CONST cm): + int ((abs (cm) * real (y factor per inch) / inch) + 0.5) +END PROC cm to y steps; + +PROC start (REAL CONST x, y): + first collumn := cm to x steps (x); + first line := cm to y steps (y); + left margin := first collumn * " " +END PROC start; + +PROC papersize (REAL CONST w, l): + width of paper := cm to x steps (w); + length of paper := cm to y steps (l); +END PROC papersize; + +PROC limit (REAL CONST x): + xlimit := cm to x steps (x); +END PROC limit; + +PROC on (TEXT CONST attribute): + IF (attribute SUB 1) = "u" + THEN underline on := TRUE; + buff CAT begin mark cmd + FI. + +buff: + IF xpos steps >= 0 + THEN x pos buffer + ELSE buffer + FI. +END PROC on; + +PROC off (TEXT CONST attribute): + IF (attribute SUB 1) = "u" + THEN underline on := FALSE; + buff CAT end mark cmd + FI. + +buff: + IF xpos steps >= 0 + THEN x pos buffer + ELSE buffer + FI. +END PROC off; + +PROC printer cmd (TEXT CONST cmd): + IF cmd pointer < max printer cmds per line + THEN cmd pointer INCR 1; + cmd arry (cmd pointer) := cmd; + buff CAT printercmd cmd + FI. + +buff: + IF xpos steps >= 0 + THEN x pos buffer + ELSE buffer + FI. +END PROC printer cmd; + +PROC material (TEXT CONST name of material): +END PROC material; + +PROC change type (TEXT CONST name of type): +ENDPROC change type; + +PROC reset printer : + new page; (* actual line := 0 *) + width of paper := std width of paper; + length of paper := std length of paper; + first line := std first line; + first collumn := std first collumn; + xlimit := std limit; + xpos mode := 0; + cmd pointer := 0; + x pos steps := no x pos; + buffer := ""; + xpos buffer := ""; + left margin := first collumn * " "; + block mode := FALSE; + underline on := FALSE; + underline out := FALSE; +ENDPROC reset printer; + +PROC print text (TEXT CONST content, INT CONST mode): + IF x pos steps >= 0 + THEN x pos buffer CAT content; + x pos mode := mode MOD 4; + block mode := FALSE + ELSE buffer CAT content ; + block mode := (mode MOD 4) = 3 + FI. +END PROC print text; + +PROC tab and print: + SELECT x pos mode OF + CASE 0: fill (buffer, " ", x pos steps); + CASE 1: fill (buffer, " ", x pos steps - outputlength (x pos buffer)); + CASE 2: fill (buffer, " ", + x pos steps - outputlength (xpos buffer) DIV 2); + CASE 3: fill (buffer, " ", x pos steps); + block (x pos buffer, xlimit - x pos steps); + OTHERWISE + END SELECT; + buffer CAT x pos buffer; + x pos buffer := ""; + x pos steps := no x pos. +END PROC tab and print; + +INT PROC outputlength (TEXT CONST buff): + length (buff) - chars (buff, printercmd cmd) - chars (buff, begin mark cmd) + - chars (buff, end mark cmd) - chars (buff, bsp cmd) * 2 +END PROC outputlength; + +PROC x pos (REAL CONST cm): + IF x pos steps >= 0 + THEN tab and print + FI; + IF underline on + THEN buffer CAT end mark cmd; + x pos buffer CAT begin mark cmd + FI; + x pos steps := cm to x steps (cm) +END PROC x pos; + +PROC y pos (REAL CONST cm): + IF actual line = 0 + THEN output linefeed (first line - actual line); + actual line := first line + FI; + output buffer; + INT VAR y lf steps := cm to y steps (cm); + output linefeed (y lf steps + first line - actual line); + actual line := first line + y lf steps. +END PROC y pos; + +PROC line (REAL CONST proposed lf) : + IF actual line = 0 + THEN output linefeed (first line - actual line); + actual line := first line + FI; + output buffer; + INT VAR done lf; + convert into min y steps (proposed lf, done lf); + output line feed (done lf); + actual line INCR done lf; +END PROC line; + +PROC convert into min y steps (REAL CONST in, INT VAR out): + IF in < 0.001 + THEN out := 0 + ELSE out := int (in); + IF out < 1 THEN out := 1 FI + FI; +ENDPROC convert into min y steps; + +PROC new page: + IF buffer <> "" + THEN line (1.0) + FI; + actual line := actual line MOD length of paper; + IF actual line > first line + THEN output pagefeed (length of paper - actual line); + actual line := 0 + FI; +END PROC new page; + +PROC output buffer: + IF x pos steps >= 0 + THEN tab and print + ELIF block mode + THEN block (buffer, xlimit) + FI ; + TEXT VAR bsp buffer := "", + underline buffer := ""; + INT VAR cmd pos := pos (buffer, ""1"", ""31"", 1), + akt cmd pointer := 0, + soon out := 0; + out (left margin); + put leading blanks not underlined; + WHILE cmd pos > 0 + REP analyze cmd; + cmd pos := pos (buffer, ""1"", ""31"", cmd pos) + PER; + IF underline out + THEN fill (underline buffer, underline char, LENGTH buffer) + FI; + out buffer; + out bsp buffer; + out underline buffer; + buffer := ""; + cmd pointer := 0. + +put leading blanks not underlined: + IF underline out + THEN INT VAR first non blank pos := pos (buffer, ""33"", ""254"", 1); + IF cmd pos > 0 CAND first non blank pos > 0 + THEN fill (underline buffer, " ", + min (first non blank pos, cmd pos) - 1) + ELIF cmd pos > 0 + THEN fill (underline buffer, " ", cmd pos - 1) + ELSE fill (underline buffer, " ", first non blank pos -1) + FI; + FI. + +analyze cmd: + SELECT code (buffer SUB cmd pos) OF + CASE bsp code : do bsp cmd + CASE begin mark code : do begin mark cmd + CASE end mark code : do end mark cmd + CASE printercmd code : do printercmd cmd + OTHERWISE + END SELECT. + +do bsp cmd: + fill (bsp buffer, " ", cmd pos - 2); + cmd pos DECR 1; + bsp buffer CAT (buffer SUB cmd pos); + delete char (buffer, cmd pos); + delete char (buffer, cmd pos). + +do begin mark cmd: + IF NOT underline out + THEN underline out := TRUE; + fill (underline buffer, " ", cmd pos -1); + delete char (buffer, cmd pos) + FI. + +do end mark cmd: + IF underline out + THEN underline out := FALSE; + fill (underline buffer, underline char, cmd pos - 1); + delete char (buffer, cmd pos) + FI. + +do printercmd cmd: + IF akt cmd pointer < cmd pointer + THEN akt cmd pointer INCR 1; + out subtext (buffer, soon out + 1, cmd pos - 1); + soon out := cmd pos - 1; + delete char (buffer, cmd pos); + out (cmd arry (akt cmd pointer)) + FI. + +out buffer: + (* out (left margin) steht schon weiter oben *) + outsubtext (buffer, soon out + 1). + +out bsp buffer: + IF bsp buffer <> "" + THEN out (cr); + out (left margin); + out (bsp buffer) + FI. + +out underline buffer: + IF underline buffer <> "" + THEN out (cr); + out (left margin); + out (underline buffer) + FI. +END PROC output buffer; + +PROC fill (TEXT VAR buff, TEXT CONST char, INT CONST len): + buff CAT (len - outputlength (buff)) * char +END PROC fill; + +PROC output linefeed (INT CONST min y steps): + IF min y steps > 0 + THEN out (cr); + out (min y steps * lf) + FI +ENDPROC output linefeed ; + +PROC output pagefeed (INT CONST rest) : + out (cr) ; + rest TIMESOUT lf +ENDPROC output pagefeed ; + +(********************* B L O C K **********************************) +LET blank = " " , + enumeration list = "-).:" ; + +INT VAR to insert, + nr of blanks , + nr of big spaces , + begin ; + +TEXT VAR small space , + big space ; + +BOOL VAR right := TRUE ; + +PROC block (TEXT VAR blockline, INT CONST len): + to insert := len - outputlength (blockline); + nr of blanks := 0; begin:=0; + IF to insert <= 0 THEN LEAVE block FI; + IF to insert > (xlimit DIV 3 ) THEN LEAVE block FI; + mark the variable blanks; + IF nr of blanks <= 0 THEN LEAVE block FI; + right := NOT right; + compute spaces; + insert spaces. + +mark the variable blanks: + skip blanks ; + begin := pos(blockline,blank,begin+1); + IF (pos (enumeration list, (blockline SUB (begin-1))) > 0 ) + THEN skip blanks ; + begin := pos(blockline,blank,begin+1); + FI; + WHILE begin > 0 REP + IF single blank gap + THEN change (blockline,begin,begin,""0""); + nr of blanks INCR 1; + ELSE skip blanks + FI; + begin := pos(blockline,blank,begin+1); + ENDREP. + +single blank gap : + ((blockline SUB (begin+1)) <> blank). + +skip blanks : + begin := pos (blockline, ""33"", ""254"", begin+1) . + +compute spaces: + INT VAR steps := to insert ; + INT VAR small := steps DIV nr of blanks; + nr of big spaces := steps MOD nr of blanks; + small space := (small+1) * blank ; + big space := small space ; + big space CAT blank . + +insert spaces: + IF right THEN insert big spaces on right side + ELSE insert big spaces on left side + FI. + +insert big spaces on right side: + INT VAR nr of small spaces := nr of blanks - nr of big spaces; + INT VAR i; + FOR i FROM 1 UPTO nr of small spaces REP + change (blockline, ""0"",small space) + ENDREP; + changeall (blockline,""0"",big space). + +insert big spaces on left side: + INT VAR j; + FOR j FROM 1 UPTO nr of big spaces REP + change (blockline,""0"",big space) + ENDREP; + changeall (blockline,""0"",small space). +ENDPROC block; + +INT PROC chars (TEXT CONST text, char) : + INT VAR how many := 0 , + cmd pos := pos (text, char) ; + WHILE cmd pos > 0 REP + how many INCR 1 ; + cmd pos := pos (text, char, cmd pos+1) + PER ; + how many +ENDPROC chars ; + +ENDPACKET std printer ; diff --git a/system/std.zusatz/1.7.3/src/std printer generator-M b/system/std.zusatz/1.7.3/src/std printer generator-M new file mode 100644 index 0000000..f07d31c --- /dev/null +++ b/system/std.zusatz/1.7.3/src/std printer generator-M @@ -0,0 +1,22 @@ +forget ("std printer generator/M", quiet) ; +check off ; + +fetch ("minimal fonts routines", archive); +fetch ("std printer", archive); +fetch ("eumel printer", archive); +fetch ("elan lister", archive); +fetch ("spool manager", archive); +fetch ("printer/M", archive); + +ins ("minimal fonts routines"); +ins ("std printer"); +ins ("eumel printer"); +ins ("elan lister"); +ins ("spool manager"); +run ("printer/M"); + +PROC ins (TEXT CONST name): + insert (name); + forget (name, quiet) +END PROC ins; + diff --git a/system/std.zusatz/1.7.3/src/std printer generator-S b/system/std.zusatz/1.7.3/src/std printer generator-S new file mode 100644 index 0000000..067df88 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/std printer generator-S @@ -0,0 +1,15 @@ +forget ("std printer generator/S", quiet) ; +check off ; + +ins ("minimal fonts routines"); +ins ("std printer"); +ins ("eumel printer"); +ins ("elan lister"); +ins ("printer/S"); + +PROC ins (TEXT CONST name): + fetch (name, archive); + insert (name); + forget (name, quiet) +END PROC ins; + diff --git a/system/std.zusatz/1.7.3/src/vector b/system/std.zusatz/1.7.3/src/vector new file mode 100644 index 0000000..fd1b0ef --- /dev/null +++ b/system/std.zusatz/1.7.3/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 : + +LET n = 4000; + +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