diff options
| author | Lars-Dominik Braun <lars@6xq.net> | 2019-02-11 11:49:19 +0100 |
|---|---|---|
| committer | Lars-Dominik Braun <lars@6xq.net> | 2019-02-11 11:49:39 +0100 |
| commit | 98cab31fc3659e33aef260efca55bf9f1753164c (patch) | |
| tree | f1affa84049ef9b268e6c4f521f000478b0f3a8e /system/std.zusatz | |
| parent | 71e2b36ccd05ea678e62e32ee6245df2b8d6ac17 (diff) | |
| download | eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.tar.gz eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.tar.bz2 eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.zip | |
Add source files from Michael
Diffstat (limited to 'system/std.zusatz')
28 files changed, 10456 insertions, 0 deletions
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;
diff --git a/system/std.zusatz/1.7.5/src/eumel printer b/system/std.zusatz/1.7.5/src/eumel printer new file mode 100644 index 0000000..2fd3f38 --- /dev/null +++ b/system/std.zusatz/1.7.5/src/eumel printer @@ -0,0 +1,3067 @@ +PACKET eumel printer (* Autor : Rudolf Ruland *)
+ (* Version : 4 *)
+ (* Stand : 07.08.86 *)
+ DEFINES print,
+ with elan listings,
+ is elan source,
+ bottom label for elan listings,
+ x pos,
+ y pos,
+ y offset index,
+ line type,
+ material,
+ pages printed :
+
+
+LET std x wanted = 2.54,
+ std y wanted = 2.35,
+ std limit = 16.0,
+ std pagelength = 25.0,
+ std linefeed faktor = 1.0,
+ std material = "";
+
+LET blank = " ",
+ blank code 1 = 33,
+ geschuetztes blank = ""223"",
+ keine blankanalyse = 0,
+ einfach blank = 1,
+ doppel blank = 2,
+
+ anweisungszeichen = "#",
+ anweisungszeichen code 1 = 36,
+ geschuetztes anweisungszeichen = ""222"",
+ druckerkommando zeichen = "/",
+ quote = """",
+
+ erweiterungs ausgang = 32767,
+ blank ausgang = 32766,
+ anweisungs ausgang = 32765,
+ d code ausgang = 32764,
+ max breite = 32763,
+
+ punkt = ".",
+
+ leer = 0,
+
+ kommando token = 0,
+ text token = 1,
+
+ underline linetype = 1,
+ underline bit = 0,
+ bold bit = 1,
+ italics bit = 2,
+ modifikations liste = "ubir",
+ anzahl modifikationen = 4,
+
+ document = 1,
+ page = 2,
+
+ write text = 1,
+ write cmd = 2,
+ carriage return = 3,
+ move = 4,
+ draw = 5,
+ on = 6,
+ off = 7,
+ type = 8,
+
+ tag type = 1,
+ bold type = 2,
+ number type = 3,
+ text type = 4,
+ delimiter type = 6,
+ eof type = 7;
+
+
+INT CONST null ausgang := -32767-1;
+
+ROW anzahl modifikationen INT CONST modifikations werte :=
+ ROW anzahl modifikationen INT : (1, 2, 4, 8);
+
+TEXT CONST anweisungsliste :=
+ "type:1.1on:2.1off:3.1center:4.0right:5.0u:6.0d:7.0e:8.0b:9.0" +
+ "fillchar:10.1mark:11.2markend:12.0" +
+ "ub:13.0ue:14.0fb:15.0fe:16.0" +
+ "block:20.0columns:21.2columnsend:22.0free:23.1limit:24.1linefeed:25.1" +
+ "material:26.1page:27.01pagelength:29.1start:30.2" +
+ "table:31.0tableend:32.0clearpos:33.01" +
+ "lpos:35.1rpos:36.1cpos:37.1dpos:38.2bpos:39.2" +
+ "textbegin:40.02textend:42.0" +
+ "indentation:43.1ytab:44.1";
+
+LET a type = 1, a block = 20,
+ a on = 2, a columns = 21,
+ a off = 3, a columnsend = 22,
+ a center = 4, a free = 23,
+ a right = 5, a limit = 24,
+ a up = 6, a linefeed = 25,
+ a down = 7, a material = 26,
+ a end up or down = 8, a page0 = 27,
+ a bsp = 9, a page1 = 28,
+ a fill char = 10, a pagelength = 29,
+ a mark = 11, a start = 30,
+ a markend = 12, a table = 31,
+ a ub = 13, a tableend = 32,
+ a ue = 14, a clearpos0 = 33,
+ a fb = 15, a clearpos1 = 34,
+ a fe = 16, a lpos = 35,
+ a rpos = 36,
+ a cpos = 37,
+ a dpos = 38,
+ a bpos = 39,
+ a textbegin0 = 40,
+ a textbegin2 = 41,
+ a textend = 42,
+ a indentation = 43,
+ a y tab = 44;
+
+INT VAR a xpos, a breite, a font, a modifikationen,
+ a modifikationen fuer x move, a ypos, aktuelle ypos,
+ letzter font, letzte modifikationen,
+ d ypos, d xpos, d font, d modifikationen,
+
+ zeilenpos, alte zeilenpos, zeilen laenge, anzahl zeichen, ausgang,
+ anzahl einrueck blanks, blankbreite,
+ einrueckbreite, aktuelle einrueckbreite, alte einrueckbreite,
+ font durchschuss, fonthoehe, font tiefe,
+ groesste fonthoehe, aktuelle zeilenhoehe, letzte zeilenhoehe,
+ blankmodus, alter blankmodus,
+ token zeiger, erstes token der zeile,
+
+ erstes tab token, tab anfang, anzahl blanks,
+ d code 1, d pitch, fuell zeichen breite, erstes fuell token,
+ letztes fuell token,
+
+ x size, y size, x wanted, y wanted, x start, y start,
+ pagelength, limit, indentation,
+ left margin, top margin, seitenlaenge,
+ papierlaenge, papierbreite,
+ luecke, anzahl spalten, aktuelle spalte,
+
+ verschiebung, rest, neue modifikationen, modifikations modus, pass,
+
+ int param, anweisungs index, anzahl params, index,
+
+ gedruckte seiten;
+
+BOOL VAR zeile ist absatzzeile, letzte zeile war absatzzeile,
+ zeile muss geblockt werden, rechts, a block token, offsets,
+ tabellen modus, block modus, center modus, right modus,
+ seite ist offen, vor erster seite;
+
+REAL VAR linefeed faktor, real param;
+
+TEXT VAR zeile, anweisung, par1, par2, material wert, replacements,
+ fuell zeichen, d string, font offsets;
+
+ROW 256 INT VAR zeichenbreiten, replacement tabelle, zeichen zaehler;
+
+INITFLAG VAR in dieser task := FALSE;
+
+. zeile ist zu ende : zeilenpos > zeilen laenge
+
+. zeilen breite : a xpos - left margin
+
+. neue zeilenhoehe : int (linefeed faktor * real (fonthoehe) + 0.5)
+
+. naechstes zeichen ist blank : pos (zeile, blank, zeilenpos + 1, zeilenpos + 1) <> 0
+
+. naechstes nicht blankes zeichen : pos (zeile, ""33"", ""255"", zeilenpos)
+
+. in letzter spalte : aktuelle spalte >= anzahl spalten
+
+. anfangs blankmodus :
+ INT VAR dummy;
+ IF center modus OR right modus
+ THEN dummy
+ ELIF index zaehler = 0
+ THEN blankmodus
+ ELSE alter blankmodus
+ FI
+
+. initialisiere tab variablen :
+ erstes tab token := token index f + 1;
+ tab anfang := zeilen breite;
+ anzahl blanks := 0;
+.;
+
+(******************************************************************)
+
+LET zeilen nr laenge = 4,
+ teil einrueckung = 5,
+
+ headline pre = "Zeile **** E L A N EUMEL 1.7.5 **** ",
+ headline post = " **** ";
+
+INT VAR zeilen nr, rest auf seite,
+ max zeichen zeile, max zeichen fuss, layout laenge, layout laenge name,
+ symbol type, naechster symbol type;
+
+BOOL VAR vor erstem packet, innerhalb der define liste;
+
+TEXT VAR bottom label, dateiname, layout blanks, refinement layout zeile;
+
+
+. symbol : fuell zeichen
+. naechstes symbol : d string
+. elan text : d token. text
+.;
+
+(******************************************************************)
+(*** tokenspeicher ***)
+
+LET max token = 3000,
+ max ypos = 1000,
+
+ TOKEN = STRUCT (TEXT text,
+ INT xpos, breite, font, modifikationen,
+ modifikationen fuer x move,
+ offset index, naechster token index,
+ BOOL block token ),
+
+ YPOS = STRUCT (INT ypos, vorheriger ypos index, naechster ypos index,
+ erster token index, letzter token index ),
+
+ TOKENLISTE = STRUCT (ROW max token TOKEN token liste,
+ ROW max ypos YPOS ypos liste );
+
+DATASPACE VAR ds;
+
+BOUND TOKENLISTE VAR tokenspeicher;
+
+TOKEN VAR d token, offset token;
+
+INT VAR erster ypos index a, letzter ypos index a,
+ erster ypos index d, letzter ypos index d,
+ ypos index, ypos index f, ypos index a, ypos index d,
+ token index, token index f;
+
+. t : tokenspeicher. token liste (token index)
+. tf : tokenspeicher. token liste (token index f)
+
+. y : tokenspeicher. ypos liste (ypos index)
+. yf : tokenspeicher. ypos liste (ypos index f)
+. ya : tokenspeicher. ypos liste (ypos index a)
+. yd : tokenspeicher. ypos liste (ypos index d)
+
+. loesche druckspeicher :
+ erster ypos index d := 0;
+ ypos index f := 0;
+ token index f := 0;
+
+. druckspeicher ist nicht leer :
+ erster ypos index d <> 0
+
+. loesche analysespeicher :
+ erster ypos index a := 0;
+
+. analysespeicher ist nicht leer :
+ erster ypos index a <> 0
+.;
+
+(******************************************************************)
+(*** anweisungsspeicher ***)
+
+INT VAR anweisungszaehler;
+TEXT VAR anweisungs indizes, params1 zeiger, params2 zeiger;
+THESAURUS VAR params1, params2;
+
+PROC loesche anweisungsspeicher :
+
+ anweisungs zaehler := 0;
+ anweisungs indizes := "";
+ params1 zeiger := "";
+ params2 zeiger := "";
+ params1 := empty thesaurus;
+ params2 := empty thesaurus;
+
+END PROC loesche anweisungsspeicher;
+
+(******************************************************************)
+(*** indexspeicher ***)
+
+INT VAR index zaehler;
+TEXT VAR grosse fonts, verschiebungen;
+
+PROC loesche indexspeicher :
+
+ index zaehler := 0;
+ grosse fonts := "";
+ verschiebungen := "";
+
+END PROC loesche indexspeicher;
+
+
+(******************************************************************)
+(*** tabellenspeicher ***)
+
+LET max tabs = 30,
+ TABELLENEINTRAG = STRUCT (INT tab typ, tab position, tab param);
+
+TEXT VAR tab liste, fill char;
+THESAURUS VAR d strings;
+ROW max tabs TABELLENEINTRAG VAR tabspeicher;
+
+INT VAR tab index;
+
+. tab typ : tab speicher (tab liste ISUB tab index). tab typ
+. tab position : tab speicher (tab liste ISUB tab index). tab position
+. tab param : tab speicher (tab liste ISUB tab index). tab param
+. anzahl tabs : LENGTH tab liste DIV 2
+.;
+
+PROC loesche tabellenspeicher :
+
+ fill char := " ";
+ tabliste := "";
+ d strings := empty thesaurus;
+ FOR tab index FROM 1 UPTO max tabs
+ REP tab speicher (tab index). tab typ := leer PER;
+
+END PROC loesche tabellenspeicher;
+
+(******************************************************************)
+(*** markierungsspeicher ***)
+
+INT VAR mark index l, mark index r, alter mark index l, alter mark index r;
+
+ROW 4 TOKEN VAR mark token;
+
+. markierung links : mark index l > 0
+. markierung rechts : mark index r > 0
+.;
+
+PROC loesche markierung :
+
+ mark index l := 0;
+ mark index r := 0;
+
+END PROC loesche markierung;
+
+
+PROC loesche alte markierung :
+
+ alter mark index l := 0;
+ alter mark index r := 0;
+
+END PROC loesche alte markierung;
+
+
+PROC initialisiere markierung :
+
+ FOR mark index l FROM 1 UPTO 4
+ REP mark token (mark index l). modifikationen fuer x move := 0;
+ mark token (mark index l). offset index := text token;
+ mark token (mark index l). block token := FALSE;
+ mark token (mark index l). naechster token index := 0;
+ PER;
+
+END PROC initialisiere markierung;
+
+(******************************************************************)
+(*** durchschuss ***)
+
+INT VAR durchschuss 1, durchschuss 2, anzahl durchschuss 1,
+ anzahl durchschuss, zeilen zaehler;
+
+BOOL VAR wechsel := TRUE;
+
+INT PROC durchschuss :
+
+ zeilen zaehler INCR 1;
+ IF zeilen zaehler <= anzahl durchschuss 1
+ THEN durchschuss 1
+ ELIF zeilen zaehler <= anzahl durchschuss
+ THEN durchschuss 2
+ ELSE 0
+ FI
+
+END PROC durchschuss;
+
+
+PROC neuer durchschuss (INT CONST anzahl, rest) :
+
+ zeilen zaehler := 0;
+ anzahl durchschuss := anzahl;
+ IF anzahl > 0
+ THEN IF wechsel
+ THEN durchschuss 1 := rest DIV anzahl durchschuss;
+ durchschuss 2 := durchschuss 1 + sign (rest);
+ anzahl durchschuss 1 := anzahl durchschuss -
+ abs (rest) MOD anzahl durchschuss;
+ wechsel := FALSE;
+ ELSE durchschuss 2 := rest DIV anzahl durchschuss;
+ durchschuss 1 := durchschuss 2 + sign (rest);
+ anzahl durchschuss 1 := abs (rest) MOD anzahl durchschuss;
+ wechsel := TRUE;
+ FI;
+ ELSE loesche durchschuss
+ FI;
+
+END PROC neuer durchschuss;
+
+
+PROC loesche durchschuss :
+
+ durchschuss 1 := 0;
+ durchschuss 2 := 0;
+ anzahl durchschuss 1 := 0;
+ anzahl durchschuss := 0;
+ zeilen zaehler := 0;
+
+END PROC loesche durchschuss;
+
+(****************************************************************)
+
+PROC initialisierung :
+
+ forget (ds);
+ ds := nilspace; tokenspeicher := ds;
+ loesche druckspeicher;
+ loesche anweisungsspeicher;
+ loesche indexspeicher;
+ initialisiere markierung;
+ right modus := FALSE;
+ center modus := FALSE;
+ seite ist offen := FALSE;
+ pass := 0;
+ a breite := 0;
+ a block token := FALSE;
+ a modifikationen fuer x move := 0;
+ d code 1 := leer;
+ erstes fuell token := leer;
+ IF two bytes
+ THEN FOR index FROM 1 UPTO 129 REP zeichen zaehler (index) := 1 PER;
+ FOR index FROM 130 UPTO 160 REP zeichen zaehler (index) := - maxint PER;
+ FOR index FROM 161 UPTO 224 REP zeichen zaehler (index) := 1 PER;
+ FOR index FROM 225 UPTO 240 REP zeichen zaehler (index) := - maxint PER;
+ FOR index FROM 241 UPTO 256 REP zeichen zaehler (index) := 1 PER;
+ ELSE FOR index FROM 1 UPTO 256 REP zeichen zaehler (index) := 1 PER;
+ FI;
+
+END PROC initialisierung;
+
+(****************************************************************)
+(*** print - Kommando ***)
+
+BOOL VAR elan listings erlaubt;
+FILE VAR eingabe;
+
+with elan listings (TRUE);
+
+PROC with elan listings (BOOL CONST flag) :
+ elan listings erlaubt := flag;
+END PROC with elan listings;
+
+BOOL PROC with elan listings : elan listings erlaubt END PROC with elan listings;
+
+
+PROC print (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute ):
+
+ print (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ FALSE, "");
+
+END PROC print;
+
+
+PROC print (FILE VAR file,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ eingabe := file;
+ input (eingabe);
+ print (PROC (TEXT VAR) lese zeile, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ elan listings erlaubt CAND is elan source (eingabe),
+ headline (eingabe) );
+
+END PROC print;
+
+PROC lese zeile (TEXT VAR zeile) : getline (eingabe, zeile) END PROC lese zeile;
+
+BOOL PROC eof : eof (eingabe) END PROC eof;
+
+BOOL PROC is elan source (FILE VAR eingabe) :
+
+hole erstes symbol;
+elan programm tag COR elan programm bold COR kommentar
+
+. elan programm tag :
+ symbol type = tag type CAND pos (zeile, ";") > 0
+
+. elan programm bold :
+ symbol type = bold type CAND is elan bold
+
+ . is elan bold :
+ symbol = "PACKET" COR symbol = "LET"
+ COR proc oder op (symbol) COR deklaration
+ COR proc oder op (naechstes symbol)
+
+ . deklaration :
+ next symbol (naechstes symbol);
+ naechstes symbol = "VAR" OR naechstes symbol = "CONST"
+
+. kommentar :
+ pos (zeile, "(*") > 0 OR pos (zeile, "{") > 0
+
+.
+ hole erstes symbol :
+ hole erstes nicht blankes symbol;
+ scan (zeile);
+ next symbol (symbol, symbol type);
+
+ . hole erstes nicht blankes symbol :
+ IF eof (eingabe) THEN LEAVE is elan source WITH FALSE FI;
+ REP getline (eingabe, zeile);
+ UNTIL pos (zeile, ""33"",""254"", 1) > 0 OR eof (eingabe) PER;
+ reset (eingabe);
+
+END PROC is elan source;
+
+(****************************************************************)
+
+bottom label for elan listings ("");
+
+PROC bottom label for elan listings (TEXT CONST label) :
+ bottom label := label;
+END PROC bottom label for elan listings;
+
+TEXT PROC bottom label for elan listings : bottom label END PROC bottom label for elan listings;
+
+
+PROC print (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ BOOL CONST elan listing, TEXT CONST file name) :
+
+disable stop;
+gedruckte seiten := 0;
+drucke datei (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ elan listing, file name );
+IF is error THEN behandle fehlermeldung FI;
+
+. behandle fehlermeldung :
+ par1 := error message;
+ int param := error line;
+ clear error;
+ IF NOT vor erster seite
+ THEN IF seite ist offen
+ THEN schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute )
+ FI;
+ clear error;
+ close (document, 0);
+ clear error;
+ FI;
+ initialisierung;
+ errorstop (par1 (* + " -> " + text (int param) *) );
+
+END PROC print;
+
+INT PROC x pos : d xpos END PROC x pos;
+INT PROC y pos : d ypos END PROC y pos;
+INT PROC y offset index : d token. offset index END PROC y offset index;
+INT PROC linetype : underline linetype END PROC linetype;
+TEXT PROC material : material wert END PROC material;
+INT PROC pages printed : gedruckte seiten END PROC pages printed;
+
+(****************************************************************)
+
+PROC drucke datei (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ BOOL CONST elan listing, TEXT CONST file name ) :
+
+
+enable stop;
+IF elan listing
+ THEN dateiname := file name;
+ drucke elan listing;
+ ELSE drucke text datei;
+FI;
+
+.
+ drucke text datei :
+ initialisiere druck;
+ WHILE NOT eof
+ REP next line (zeile);
+ analysiere zeile;
+ drucke token soweit wie moeglich;
+ werte anweisungsspeicher aus;
+ PER;
+ schliesse druck ab;
+
+.
+ initialisiere druck :
+ IF NOT initialized (in dieser task)
+ THEN ds := nilspace;
+ initialisierung
+ FI;
+ vor erster seite := TRUE;
+ tabellen modus := FALSE;
+ block modus := FALSE;
+ zeile ist absatzzeile := TRUE;
+ x wanted := x step conversion (std x wanted);
+ y wanted := y step conversion (std y wanted);
+ limit := x step conversion (std limit);
+ pagelength := y step conversion (std pagelength);
+ linefeed faktor := std linefeed faktor;
+ material wert := std material;
+ indentation := 0;
+ modifikations modus := maxint;
+ seitenlaenge := maxint;
+ papierlaenge := maxint;
+ left margin := 0;
+ top margin := 0;
+ a ypos := top margin;
+ a font := -1;
+ a modifikationen := 0;
+ aktuelle spalte := 1;
+ anzahl spalten := 1;
+ stelle neuen font ein (1);
+ loesche tabellenspeicher;
+ loesche markierung;
+ loesche alte markierung;
+ loesche durchschuss;
+
+.
+ schliesse druck ab :
+ IF NOT vor erster seite
+ THEN IF seite ist offen
+ THEN schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute )
+ FI;
+ close (document, 0);
+ FI;
+
+.
+ drucke token soweit wie moeglich :
+ IF analysespeicher ist nicht leer
+ THEN letztes token bei gleicher ypos;
+ IF NOT seite ist offen
+ THEN eroeffne seite (x wanted, y wanted,
+ PROC (INT CONST, INT VAR, INT VAR) open);
+ FI;
+ gehe zur letzten neuen ypos;
+ IF seitenlaenge ueberschritten OR papierlaenge ueberschritten
+ THEN neue seite oder spalte;
+ analysiere zeile nochmal;
+ ELSE sortiere neue token ein;
+ IF in letzter spalte
+ THEN drucke tokenspeicher (a ypos,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ FI;
+ FI;
+
+ . gehe zur letzten neuen ypos :
+ ypos index a := letzter ypos index a
+
+ . seitenlaenge ueberschritten :
+ ya. ypos > seitenlaenge
+
+ . papierlaenge ueberschritten :
+ ya. ypos > papierlaenge
+
+ . neue seite oder spalte :
+ IF in letzter spalte
+ THEN schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ eroeffne seite (x wanted, aktuelles y wanted,
+ PROC (INT CONST, INT VAR, INT VAR) open);
+ ELSE neue spalte;
+ FI;
+
+ . aktuelles y wanted :
+ IF seitenlaenge ueberschritten
+ THEN y wanted
+ ELSE 0
+ FI
+
+ . analysiere zeile nochmal :
+ setze auf alte werte zurueck;
+ loesche anweisungsspeicher;
+ analysiere zeile;
+ letztes token bei gleicher ypos;
+ sortiere neue token ein;
+
+ . setze auf alte werte zurueck :
+ zeile ist absatzzeile := letzte zeile war absatzzeile;
+ a modifikationen := letzte modifikationen;
+ stelle neuen font ein (letzter font);
+
+.
+ werte anweisungsspeicher aus :
+ INT VAR index;
+ FOR index FROM 1 UPTO anweisungszaehler
+ REP
+ SELECT anweisungs indizes ISUB index OF
+ CASE a block : block anweisung
+ CASE a columns : columns anweisung
+ CASE a columnsend : columnsend anweisung
+ CASE a free : free anweisung
+ CASE a limit : limit anweisung
+ CASE a linefeed : linefeed anweisung
+ CASE a material : material anweisung
+ CASE a page0, a page1 : page anweisung
+ CASE a pagelength : pagelength anweisung
+ CASE a start : start anweisung
+ CASE a table : table anweisung
+ CASE a tableend : tableend anweisung
+ CASE a clearpos0 : clearpos0 anweisung
+ CASE a clearpos1 : clearpos1 anweisung
+ CASE a lpos, a rpos, a cpos, a dpos
+ : lpos rpos cpos dpos anweisung
+ CASE a bpos : bpos anweisung
+ CASE a fillchar : fillchar anweisung
+ CASE a textbegin0 : textbegin0 anweisung
+ CASE a textbegin2 : textbegin2 anweisung
+ CASE a textend : textend anweisung
+ CASE a indentation : indentation anweisung
+ CASE a y tab : y tab anweisung
+ END SELECT
+ PER;
+ loesche anweisungsspeicher;
+
+ . block anweisung :
+ blockmodus := TRUE;
+
+ . columns anweisung :
+ IF anzahl spalten = 1 AND int conversion ok (param1)
+ AND real conversion ok (param2)
+ THEN anzahl spalten := max (1, int param);
+ luecke := x step conversion (real param);
+ FI;
+
+ . columnsend anweisung :
+ anzahl spalten := 1;
+ aktuelle spalte := 1;
+ left margin := x wanted - x start + indentation;
+
+ . free anweisung :
+ IF real conversion ok (param1) THEN a ypos INCR y step conversion (real param) FI;
+
+ . limit anweisung :
+ IF real conversion ok (param1) THEN limit := x step conversion (real param) FI;
+
+ . linefeed anweisung :
+ IF real conversion ok (param1)
+ THEN linefeed faktor := real param;
+ letzte zeilenhoehe := neue zeilenhoehe;
+ FI;
+
+ . material anweisung :
+ material wert := param1;
+
+ . page anweisung :
+ IF seite ist offen
+ THEN IF NOT in letzter spalte
+ THEN neue spalte
+ ELSE schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ papier laenge := maxint;
+ FI;
+ ELSE a ypos := top margin;
+ papier laenge := maxint;
+ FI;
+
+ . pagelength anweisung :
+ IF real conversion ok (param1)
+ THEN pagelength := y step conversion (real param);
+ FI;
+
+ . start anweisung :
+ IF real conversion ok (param1) THEN x wanted := x step conversion (real param) FI;
+ IF real conversion ok (param2) THEN y wanted := y step conversion (real param) FI;
+
+ . table anweisung :
+ tabellenmodus := TRUE;
+
+ . tableend anweisung :
+ tabellenmodus := FALSE;
+
+ . clearpos0 anweisung :
+ loesche tabellenspeicher;
+
+ . clearpos1 anweisung :
+ IF real conversion ok (param1)
+ THEN int param := x step conversion (real param);
+ FOR tab index FROM 1 UPTO anzahl tabs
+ REP IF tab position = int param
+ THEN tab typ := leer;
+ delete int (tab liste, tab index);
+ LEAVE clearpos1 anweisung;
+ FI;
+ PER;
+ FI;
+
+ . lpos rpos cpos dpos anweisung :
+ IF real conversion ok (param1)
+ THEN neuer tab eintrag (anweisungs indizes ISUB index, param2) FI;
+
+ . bpos anweisung :
+ IF real conversion ok (param2) CAND real conversion ok (param1)
+ CAND real (param2) > real param
+ THEN neuer tab eintrag (a bpos, param2) FI;
+
+ . fillchar anweisung :
+ fill char := param1;
+
+ . textbegin0 anweisung :
+ aktuelle einrueckbreite := alte einrueckbreite;
+ mark index l := alter mark index l;
+ mark index r := alter mark index r;
+ loesche alte markierung;
+
+ . textbegin2 anweisung :
+ aktuelle einrueckbreite := alte einrueckbreite;
+ mark index l := alter mark index l;
+ mark index r := alter mark index r;
+ loesche alte markierung;
+ neuer durchschuss (int (param1), y step conversion (real (param 2)));
+
+ . textend anweisung :
+ alte einrueckbreite := aktuelle einrueckbreite;
+ alter mark index l := mark index l;
+ alter mark index r := mark index r;
+ loesche markierung;
+ loesche durchschuss;
+
+ . indentation anweisung :
+(* IF real conversion ok (param1)
+ THEN int param := x step conversion (real param);
+ left margin INCR (int param - indentation);
+ indentation := int param;
+ FI;
+ *)
+ . y tab anweisung :
+(* IF real conversion ok (param1)
+ THEN int param := y step conversion (real param);
+ IF int param <= seitenlaenge THEN a ypos := int param FI;
+ FI;
+ *)
+ . param1 :
+ IF (params1 zeiger ISUB index) <> 0
+ THEN name (params1, params1 zeiger ISUB index)
+ ELSE ""
+ FI
+
+ . param2 :
+ IF (params2 zeiger ISUB index) <> 0
+ THEN name (params2, params2 zeiger ISUB index)
+ ELSE ""
+ FI
+
+
+.
+ drucke elan listing :
+ initialisiere elan listing;
+ WHILE NOT eof
+ REP next line (zeile);
+ zeilen nr INCR 1;
+ drucke elan zeile;
+ PER;
+ schliesse elan listing ab;
+
+.
+ initialisiere elan listing :
+ open document cmd;
+ hole elan list font;
+ initialisiere variablen;
+ elan fuss und kopf (1,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ . open document cmd :
+ material wert := "";
+ d token. offset index := 1;
+ erster ypos index d := 0;
+ vor erster seite := FALSE;
+ seite ist offen := FALSE;
+ open (document, x size, y size);
+ vor erster seite := TRUE;
+
+ . hole elan list font :
+ d font := max (1, font ("elanlist"));
+ get replacements (d font, replacements, replacement tabelle);
+ einrueckbreite := indentation pitch (d font) ;
+ font hoehe := font lead (d font) + font height (d font) + font depth (d font);
+
+ . initialisiere variablen :
+ innerhalb der define liste := FALSE;
+ vor erstem packet := TRUE;
+ zeilen nr := 0;
+ y wanted := y size DIV 23;
+ pagelength := y size - y wanted - y wanted;
+ x wanted := (min (x size DIV 10, x step conversion (2.54))
+ DIV einrueckbreite) * einrueckbreite;
+ max zeichen zeile := (x size - x wanted - (x wanted DIV 3)) DIV einrueckbreite;
+ max zeichen fuss := fusszeilenbreite;
+ layout laenge := min (38, max zeichen zeile DIV 3);
+ layout laenge name := layout laenge - zeilen nr laenge - 8;
+ layout blanks := (layout laenge - zeilen nr laenge - 1) * " ";
+ refinement layout zeile := (layout laenge - 1) * " " ;
+ refinement layout zeile CAT "|" ;
+ IF pagelength DIV fonthoehe - 6 < 35 OR max zeichen zeile < 65
+ THEN errorstop ("Schreibfeld fuer 'elan listing' zu klein") FI;
+
+ . fusszeilenbreite :
+ INT CONST dina 4 breite := x step conversion (21.0);
+ IF x size <= dina 4 breite
+ THEN (x size - 2 * x wanted) DIV einrueckbreite
+ ELIF 120 * einrueckbreite <= dina 4 breite - 2 * x wanted
+ THEN (dina 4 breite - 2 * x wanted) DIV einrueckbreite
+ ELSE min (120, (x size - 2 * x wanted) DIV einrueckbreite)
+ FI
+
+.
+ schliesse elan listing ab :
+ elan fuss und kopf (-1,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ close (document, 0);
+
+.
+ drucke elan zeile :
+ IF pos (zeile, "#page#") = 1
+ THEN IF nicht am seiten anfang THEN seiten wechsel FI;
+ ELSE bestimme elan layout;
+ bestimme elan zeile;
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ seitenwechsel wenn noetig;
+ FI;
+
+ . nicht am seitenanfang :
+ rest auf seite < pagelength - 3 * font hoehe
+
+ . seiten wechsel :
+ elan fuss und kopf (0,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+.
+ bestimme elan layout :
+ IF pos (zeile, "P") = 0 AND pos (zeile, ":") = 0
+ THEN leeres layout
+ ELSE analysiere elan zeile
+ FI;
+ elan text CAT "|";
+
+ . leeres layout :
+ elan text := text (zeilen nr, zeilen nr laenge);
+ elan text CAT layout blanks;
+
+ . analysiere elan zeile :
+ scan (zeile);
+ next symbol (symbol, symbol type);
+ next symbol (naechstes symbol, naechster symbol type) ;
+ IF packet anfang THEN packet layout
+ ELIF innerhalb der define liste THEN leeres layout; pruefe ende der define liste
+ ELIF proc op anfang THEN proc op layout
+ ELIF refinement anfang THEN refinement layout
+ ELSE leeres layout
+ FI;
+
+ . packet anfang :
+ symbol = "PACKET"
+
+ . proc op anfang :
+ IF proc oder op (symbol)
+ THEN naechster symbol type <> delimiter type
+ ELIF (symbol <> "END") AND proc oder op (naechstes symbol)
+ THEN symbol := naechstes symbol;
+ next symbol (naechstes symbol, naechster symbol type) ;
+ naechster symbol type <> delimiter type
+ ELSE FALSE
+ FI
+
+ . refinement anfang :
+ symbol type = tag type AND naechstes symbol = ":"
+ AND NOT innerhalb der define liste
+
+ . packet layout :
+ IF nicht am seiten anfang AND
+ (NOT vor erstem packet OR gedruckte seiten > 1)
+ THEN seiten wechsel FI;
+ layout (" ", naechstes symbol, "*") ;
+ vor erstem packet := FALSE ;
+ innerhalb der define liste := TRUE;
+ pruefe ende der define liste;
+
+ . pruefe ende der define liste :
+ IF pos (zeile, ":") <> 0
+ THEN scan (zeile);
+ WHILE innerhalb der define liste
+ REP next symbol (symbol);
+ IF symbol = ":" THEN innerhalb der define liste := FALSE FI;
+ UNTIL symbol = "" PER;
+ FI;
+
+ . proc op layout :
+ IF keine vier zeilen mehr
+ THEN seiten wechsel
+ ELIF nicht am seitenanfang
+ THEN cr plus lf (2, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI ;
+ layout (" ", naechstes symbol, ".");
+
+ . keine vier zeilen mehr :
+ rest auf seite <= 8 * font hoehe
+
+ . refinement layout :
+ IF keine drei zeilen mehr
+ THEN seiten wechsel
+ ELIF nicht am seitenanfang
+ THEN elan text := refinement layout zeile;
+ gib elan text aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI ;
+ layout (" ", symbol, " ");
+
+ . keine drei zeilen mehr :
+ rest auf seite <= 7 * font hoehe
+
+.
+ bestimme elan zeile :
+ IF zeile ist nicht zu lang
+ THEN elan text CAT zeile;
+ ELSE drucke zeile in teilen
+ FI;
+
+ . zeile ist nicht zu lang :
+ zeilen laenge := LENGTH zeile;
+ zeilen laenge <= rest auf zeile
+
+ . rest auf zeile :
+ max zeichen zeile - LENGTH elan text
+
+ . drucke zeile in teilen :
+ zeilen pos := 1;
+ bestimme einrueckung;
+ WHILE zeile noch nicht ganz gedruckt REP teil layout PER;
+
+ . bestimme einrueckung :
+ anzahl einrueck blanks := naechstes nicht blankes zeichen - 1;
+ IF anzahl einrueck blanks > rest auf zeile - 20
+ THEN anzahl einrueck blanks := 0 FI;
+
+ . zeile noch nicht ganz gedruckt :
+ bestimme zeilenteil;
+ NOT zeile ist zu ende
+
+ . bestimme zeilenteil :
+ bestimme laenge;
+ zeilen teil := subtext (zeile, zeilen pos, zeilen pos + laenge - 1);
+ elan text CAT zeilen teil;
+ zeilen pos INCR laenge;
+
+ . zeilen teil : par1
+
+ . bestimme laenge :
+ INT VAR laenge := zeilen laenge - zeilen pos + 1;
+ IF laenge > rest auf zeile
+ THEN laenge := rest auf zeile;
+ WHILE (zeile SUB (zeilen pos + laenge - 1)) <> " "
+ REP laenge DECR 1 UNTIL laenge = 0 PER;
+ IF laenge = 0 THEN laenge := rest auf zeile FI;
+ FI;
+
+ . teil layout :
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ elan text := (zeilen nr laenge - 1) * " ";
+ elan text CAT "+";
+ elan text CAT layout blanks;
+ elan text CAT "|";
+ elan text cat blanks (anzahl einrueck blanks + teil einrueckung);
+
+.
+ seiten wechsel wenn noetig :
+ IF keine zeilen mehr AND NOT eof THEN seiten wechsel FI;
+
+ . keine zeilen mehr :
+ rest auf seite <= 4 * font hoehe
+
+END PROC drucke datei;
+
+
+BOOL PROC real conversion ok (TEXT CONST param) :
+ real param := real (param);
+ last conversion ok AND real param >= 0.0
+END PROC real conversion ok;
+
+
+BOOL PROC int conversion ok (TEXT CONST param) :
+ int param := int (param);
+ last conversion ok AND int param >= 0
+END PROC int conversion ok;
+
+
+PROC neuer tab eintrag (INT CONST typ, TEXT CONST param) :
+
+ suche neuen eintrag;
+ sortiere neue tab position ein;
+ tab typ := typ;
+ tab position := neue tab position;
+ tab param := eventueller parameter;
+
+ . suche neuen eintrag :
+ INT VAR index := 0;
+ REP index INCR 1;
+ IF tab speicher (index). tab typ = leer
+ THEN LEAVE suche neuen eintrag FI;
+ UNTIL index = max tabs PER;
+ LEAVE neuer tab eintrag;
+
+ . sortiere neue tab position ein :
+ INT VAR neue tab position := x step conversion (real param);
+ FOR tab index FROM 1 UPTO anzahl tabs
+ REP IF tab position = neue tab position
+ THEN LEAVE neuer tab eintrag
+ ELIF tab position > neue tab position
+ THEN insert int (tab liste, tab index, index);
+ LEAVE sortiere neue tab position ein;
+ FI;
+ PER;
+ tab liste CAT index;
+ tab index := anzahl tabs;
+
+ . eventueller parameter :
+ INT VAR link;
+ SELECT typ OF
+ CASE a dpos : insert (d strings, param, link); link
+ CASE a bpos : x step conversion (real(param))
+ OTHERWISE : 0
+ END SELECT
+
+END PROC neuer tab eintrag;
+
+
+PROC neue spalte :
+ a ypos := top margin;
+ left margin INCR (limit + luecke);
+ aktuelle spalte INCR 1;
+END PROC neue spalte ;
+
+
+BOOL PROC proc oder op (TEXT CONST symbol) :
+
+ symbol = "PROC" OR symbol = "PROCEDURE"
+ OR symbol = "OP" OR symbol = "OPERATOR"
+
+ENDPROC proc oder op ;
+
+
+PROC layout (TEXT CONST pre, TEXT VAR name, TEXT CONST post) :
+
+name := subtext (name, 1, layout laenge name) ;
+elan text := text (zeilen nr, zeilen nr laenge);
+elan text CAT pre;
+elan text CAT name;
+elan text CAT " ";
+generiere strukturiertes layout;
+
+. generiere strukturiertes layout :
+ INT VAR index;
+ FOR index FROM 1 UPTO layout laenge - LENGTH elan text - 1
+ REP elan text CAT post PER;
+
+ENDPROC layout ;
+
+
+PROC elan text cat blanks (INT CONST anzahl) :
+
+ par2 := anzahl * " ";
+ elan text CAT par2;
+
+END PROC elan text cat blanks;
+
+
+(***********************************************************************)
+
+PROC analysiere zeile :
+
+loesche analysespeicher;
+behandle fuehrende blanks;
+pruefe ob anweisungszeile;
+pruefe ob markierung links;
+
+IF tabellen modus
+ THEN analysiere tabellenzeile
+ELIF letzte zeile war absatzzeile
+ THEN analysiere zeile nach absatzzeile
+ ELSE analysiere zeile nach blockzeile
+FI;
+
+pruefe center und right modus;
+pruefe ob tabulation vorliegt;
+werte indexspeicher aus;
+berechne zeilenhoehe;
+pruefe ob markierung rechts;
+
+.
+ analysiere zeile nach absatzzeile :
+ test auf aufzaehlung;
+ IF zeile muss geblockt werden
+ THEN analysiere blockzeile nach absatzzeile
+ ELSE analysiere absatzzeile nach absatzzeile
+ FI;
+.
+ analysiere zeile nach blockzeile :
+ IF zeile muss geblockt werden
+ THEN analysiere blockzeile nach blockzeile
+ ELSE analysiere absatzzeile nach blockzeile
+ FI;
+
+
+.
+ behandle fuehrende blanks :
+ zeilenpos := 1;
+ zeilenpos := naechstes nicht blankes zeichen;
+ IF zeilenpos = 0
+ THEN behandle leerzeile;
+ LEAVE analysiere zeile;
+ ELSE letzte zeile war absatzzeile := zeile ist absatzzeile;
+ IF letzte zeile war absatzzeile THEN neue einrueckung FI;
+ initialisiere analyse;
+ FI;
+
+ . behandle leerzeile :
+ a ypos INCR (letzte zeilenhoehe + durchschuss);
+ zeile ist absatzzeile := LENGTH zeile > 0;
+ pruefe ob markierung links;
+ pruefe ob markierung rechts;
+
+ . neue einrueckung :
+ aktuelle einrueckbreite := einrueckbreite;
+
+ . initialisiere analyse :
+ zeile ist absatzzeile := (zeile SUB LENGTH zeile) = blank;
+ zeile muss geblockt werden := block modus AND NOT zeile ist absatzzeile;
+ erstes token der zeile := token index f + 1;
+ groesste fonthoehe := fonthoehe;
+ aktuelle zeilenhoehe := letzte zeilenhoehe;
+ zeilen laenge := laenge der zeile;
+ anzahl einrueck blanks := zeilen pos - 1;
+ anzahl zeichen := anzahl einrueck blanks;
+ a xpos := left margin + anzahl zeichen * aktuelle einrueckbreite;
+ a modifikationen fuer x move := 0;
+ letzter font := a font;
+ letzte modifikationen := a modifikationen;
+ IF zeile muss geblockt werden THEN initialisiere tab variablen FI;
+
+ . laenge der zeile :
+ IF zeile ist absatzzeile
+ THEN LENGTH zeile - 1
+ ELSE LENGTH zeile
+ FI
+.
+ pruefe ob anweisungszeile :
+ IF erstes zeichen ist anweisungszeichen
+ THEN REP analysiere anweisung;
+ IF zeile ist zu ende THEN LEAVE analysiere zeile FI;
+ UNTIL zeichen ist kein anweisungs zeichen PER;
+ FI;
+
+ . erstes zeichen ist anweisungszeichen :
+ pos (zeile, anweisungszeichen, 1, 1) <> 0
+
+ . zeichen ist kein anweisungszeichen :
+ pos (zeile, anweisungszeichen, zeilen pos, zeilen pos) = 0
+
+.
+ pruefe ob markierung links :
+ IF markierung links
+ THEN mark token (mark index l). xpos :=
+ left margin - mark token (mark index l). breite;
+ lege markierungs token an (mark index l);
+ erstes token der zeile := token index f + 1;
+ initialisiere tab variablen;
+ FI;
+
+.
+ analysiere tabellenzeile :
+ anfangs blankmodus := doppel blank;
+ alte zeilenpos := zeilen pos;
+ a xpos := 0;
+ FOR tab index FROM 1 UPTO anzahl tabs
+ REP lege fuell token an wenn noetig;
+ initialisiere tab variablen;
+ SELECT tab typ OF
+ CASE a lpos : linksbuendige spalte
+ CASE a rpos : rechtsbuendige spalte
+ CASE a cpos : zentrierte spalte
+ CASE a dpos : dezimale spalte
+ CASE a bpos : geblockte spalte
+ END SELECT;
+ berechne fuell token wenn noetig;
+ tabulation;
+ PER;
+ analysiere rest der zeile;
+
+ . lege fuell token an wenn noetig :
+ IF fill char <> blank
+ THEN fuellzeichen := fill char;
+ fuellzeichen breite := string breite (fuellzeichen);
+ token zeiger := zeilen pos;
+ erstes fuell token := token index f + 1;
+ lege text token an;
+ letztes fuell token := token index f;
+ a modifikationen fuer x move := a modifikationen
+ FI;
+
+ . berechne fuell token wenn noetig :
+ IF erstes fuell token <> leer
+ THEN IF letztes fuell token <> token index f
+ THEN berechne fuell token;
+ ELSE loesche letzte token;
+ FI;
+ erstes fuell token := leer
+ FI;
+
+ . berechne fuell token :
+ INT VAR anzahl fuellzeichen, fuell breite;
+ token index := erstes fuell token;
+ anzahl fuellzeichen := (tab anfang - t. xpos + left margin)
+ DIV fuellzeichen breite;
+ rest := (tab anfang - t. xpos + left margin)
+ MOD fuellzeichen breite;
+ IF anzahl fuell zeichen > 0
+ THEN fuell text := anzahl fuellzeichen * fuellzeichen;
+ fuell breite := anzahl fuellzeichen * fuellzeichen breite;
+ FOR token index FROM erstes fuell token UPTO letztes fuell token
+ REP t. text := fuell text;
+ t. breite := fuell breite;
+ IF erstes fuell token <> erstes token der zeile
+ THEN t. xpos INCR rest DIV 2;
+ t. modifikationen fuer x move := t. modifikationen;
+ FI;
+ PER;
+ FI;
+
+ . fuell text : par1
+
+ . loesche letzte token :
+ FOR token index FROM letztes fuell token DOWNTO erstes fuell token
+ REP loesche letztes token PER;
+
+ . tabulation :
+ alte zeilenpos := zeilenpos;
+ zeilenpos := naechstes nicht blankes zeichen;
+ IF zeilenpos = 0
+ THEN zeilenpos := zeilenlaenge + 1;
+ LEAVE analysiere tabellenzeile;
+ FI;
+ anzahl zeichen INCR zeilenpos - alte zeilenpos;
+
+ . linksbuendige spalte :
+ a xpos := left margin + tab position;
+ tab anfang := tab position;
+ bestimme token bis terminator oder zeilenende;
+
+ . rechtsbuendige spalte :
+ bestimme token bis terminator oder zeilenende;
+ schreibe zeile rechtsbuendig (tab position);
+
+ . zentrierte spalte :
+ bestimme token bis terminator oder zeilenende;
+ zentriere zeile (tab position);
+
+ . dezimale spalte :
+ d string := name (d strings, tab param);
+ d code 1 := code (d string SUB 1) + 1;
+ d pitch := zeichenbreiten (d code 1);
+ zeichenbreiten (d code 1) := d code ausgang;
+ bestimme token bis terminator oder zeilenende;
+ zeichenbreiten (d code 1) := d pitch;
+ d code 1 := leer;
+ schreibe zeile rechtsbuendig (tab position);
+ IF zeichen ist dezimal zeichen
+ THEN IF tab position <> zeilen breite
+ THEN a xpos := left margin + tab position;
+ tab anfang := tab position;
+ FI;
+ bestimme token bis terminator oder zeilenende
+ FI;
+
+ . zeichen ist dezimal zeichen :
+ pos (zeile, d string, zeilen pos) = zeilen pos
+
+ . geblockte spalte :
+ blankmodus := einfach blank;
+ a xpos := left margin + tab position;
+ tab anfang := tab position;
+ REP bestimme token bis terminator oder zeilenende;
+ IF zeile ist zu ende OR naechstes zeichen ist blank
+ THEN blocke spalte wenn noetig;
+ LEAVE geblockte spalte;
+ ELSE dehnbares blank gefunden;
+ FI;
+ PER;
+
+ . blocke spalte wenn noetig :
+ IF letztes zeichen ist kein geschuetztes blank
+ THEN blocke zeile (tab param) FI;
+ blank modus := doppel blank;
+
+ . letztes zeichen ist kein geschuetztes blank :
+ pos (zeile, geschuetztes blank, zeilen pos - 1, zeilen pos - 1) = 0
+ AND NOT within kanji (zeile, zeilen pos - 2)
+
+ . analysiere rest der zeile :
+ blankmodus := keine blankanalyse;
+ zeilen pos := alte zeilenpos;
+ bestimme token bis terminator oder zeilenende;
+
+.
+ test auf aufzaehlung :
+ anfangs blankmodus := einfach blank;
+ bestimme token bis terminator oder zeilenende;
+ IF zeile ist zu ende
+ THEN LEAVE analysiere zeile nach absatzzeile
+ ELSE aufzaehlung moeglich
+ FI;
+
+ . aufzaehlung moeglich :
+ bestimme letztes zeichen;
+ IF (anzahl zeichen bei aufzaehlung < 2 AND letztes zeichen = "-")
+ OR (anzahl zeichen bei aufzaehlung < 20 AND letztes zeichen = ":")
+ OR (anzahl zeichen bei aufzaehlung < 7
+ AND pos (".)", letztes zeichen) <> 0)
+ OR naechstes zeichen ist blank
+ THEN tabulator position gefunden;
+ ELIF zeile muss geblockt werden
+ THEN dehnbares blank gefunden;
+ FI;
+
+ . bestimme letztes zeichen :
+ token index := token index f;
+ WHILE token index >= erstes token der zeile
+ REP IF token ist text token
+ THEN letztes zeichen := t. text SUB LENGTH t. text;
+ LEAVE bestimme letztes zeichen;
+ FI;
+ token index DECR 1;
+ PER;
+ letztes zeichen := "";
+
+ . letztes zeichen : par1
+
+ . anzahl zeichen bei aufzaehlung :
+ anzahl zeichen - anzahl einrueck blanks
+
+ . token ist text token :
+ t. offset index >= text token
+.
+ analysiere blockzeile nach absatzzeile :
+ REP bestimme token bis terminator oder zeilenende;
+ IF zeile ist zu ende
+ THEN blocke zeile (limit);
+ LEAVE analysiere blockzeile nach absatzzeile
+ ELSE analysiere blank in blockzeile nach absatzzeile
+ FI;
+ PER;
+
+ . analysiere blank in blockzeile nach absatzzeile :
+ IF naechstes zeichen ist blank
+ THEN tabulator position gefunden;
+ ELSE dehnbares blank gefunden;
+ FI;
+
+.
+ analysiere absatzzeile nach absatzzeile :
+ blankmodus := doppel blank;
+ REP bestimme token bis terminator oder zeilenende;
+ IF zeile ist zu ende
+ THEN LEAVE analysiere absatzzeile nach absatzzeile
+ ELSE tabulator position gefunden
+ FI;
+ PER;
+
+.
+ analysiere blockzeile nach blockzeile :
+ anfangs blankmodus := einfach blank;
+ REP bestimme token bis terminator oder zeilenende;
+ IF zeile ist zu ende
+ THEN blocke zeile (limit);
+ LEAVE analysiere blockzeile nach blockzeile
+ ELSE dehnbares blank gefunden
+ FI;
+ PER;
+
+.
+ analysiere absatzzeile nach blockzeile :
+ anfangs blankmodus := keine blankanalyse;
+ bestimme token bis terminator oder zeilenende;
+
+.
+ dehnbares blank gefunden :
+ anzahl zeichen INCR 1;
+ zeilenpos INCR 1;
+ a xpos INCR blankbreite;
+ a modifikationen fuer x move := a modifikationen;
+ IF NOT a block token
+ THEN anzahl blanks INCR 1;
+ a block token := TRUE;
+ FI;
+.
+ tabulator position gefunden :
+ alte zeilenpos := zeilenpos;
+ zeilenpos := naechstes nicht blankes zeichen;
+ IF zeilenpos = 0
+ THEN zeilenpos := zeilen laenge + 1;
+ ELSE IF erstes token der zeile > token index f
+ THEN token zeiger := zeilen pos;
+ lege text token an;
+ FI;
+ anzahl zeichen INCR (zeilenpos - alte zeilenpos);
+ a xpos := left margin + anzahl zeichen * aktuelle einrueckbreite;
+ a modifikationen fuer x move := a modifikationen;
+ IF zeile muss geblockt werden THEN initialisiere tab variablen FI;
+ FI;
+
+.
+ pruefe center und right modus :
+ IF center modus THEN zentriere zeile (limit DIV 2) FI;
+ IF right modus THEN schreibe zeile rechtsbuendig (limit) FI;
+.
+ pruefe ob tabulation vorliegt:
+ IF analyse speicher ist nicht leer CAND a xpos > tf. xpos + tf. breite
+ THEN a modifikationen fuer x move := a modifikationen;
+ token zeiger := zeilen pos;
+ lege text token an;
+ FI;
+.
+ werte indexspeicher aus :
+ INT VAR index;
+ IF index zaehler > 0
+ THEN FOR index FROM index zaehler DOWNTO 1
+ REP a ypos DECR (verschiebungen ISUB index) PER;
+ stelle neuen font ein (grosse fonts ISUB 1);
+ loesche index speicher;
+ FI;
+.
+ berechne zeilenhoehe :
+ verschiebung := aktuelle zeilenhoehe + durchschuss;
+ a ypos INCR verschiebung;
+ verschiebe token ypos (verschiebung);
+
+.
+ pruefe ob markierung rechts :
+ IF markierung rechts
+ THEN mark token (mark index r). xpos := left margin + limit;
+ lege markierungs token an (mark index r);
+ FI;
+
+END PROC analysiere zeile;
+
+
+PROC blocke zeile (INT CONST rechter rand) :
+
+rest := rechter rand - zeilen breite;
+IF rest > 0 AND anzahl blanks > 0
+ THEN INT CONST schmaler schritt := rest DIV anzahl blanks,
+ breiter schritt := schmaler schritt + 1,
+ anzahl breite schritte := rest MOD anzahl blanks;
+ IF rechts
+ THEN blocke token xpos (breiter schritt, schmaler schritt,
+ anzahl breite schritte);
+ rechts := FALSE;
+ ELSE blocke token xpos (schmaler schritt, breiter schritt,
+ anzahl blanks - anzahl breite schritte);
+ rechts := TRUE;
+ FI;
+ a xpos INCR ( breiter schritt * anzahl breite schritte +
+ schmaler schritt * (anzahl blanks - anzahl breite schritte) );
+FI;
+
+END PROC blocke zeile;
+
+
+PROC zentriere zeile (INT CONST zentrier pos) :
+
+IF erstes tab token <= token index f
+ THEN verschiebung := zentrier pos - tab anfang -
+ (zeilen breite - tab anfang) DIV 2;
+ verschiebe token xpos (verschiebung);
+ a xpos INCR verschiebung;
+ tab anfang INCR verschiebung;
+FI;
+center modus := FALSE;
+
+END PROC zentriere zeile;
+
+
+PROC schreibe zeile rechtsbuendig (INT CONST rechte pos) :
+
+IF erstes tab token <= token index f
+ THEN verschiebung := rechte pos - zeilen breite;
+ verschiebe token xpos (verschiebung);
+ a xpos INCR verschiebung;
+ tab anfang INCR verschiebung;
+FI;
+right modus := FALSE;
+
+
+END PROC schreibe zeile rechtsbuendig;
+
+
+PROC bestimme token bis terminator oder zeilenende :
+
+token zeiger := zeilen pos;
+REP stranalyze (zeichenbreiten, a breite, max breite,
+ zeile, zeilen pos, zeilen laenge,
+ ausgang);
+ zeilen pos INCR 1;
+ IF ausgang = blank ausgang
+ THEN analysiere blank
+ ELIF ausgang = anweisungs ausgang
+ THEN anweisung gefunden
+ ELIF ausgang = d code ausgang
+ THEN analysiere d string
+ ELIF ausgang = erweiterungs ausgang
+ THEN erweiterung gefunden
+ ELSE terminator oder zeilenende gefunden
+ FI;
+PER;
+
+. analysiere blank :
+ IF blankmodus = einfach blank OR
+ (blankmodus = doppel blank AND naechstes zeichen ist blank)
+ THEN terminator oder zeilenende gefunden
+ ELSE a breite INCR blankbreite;
+ zeilenpos INCR 1;
+ FI;
+
+. analysiere d string :
+ IF pos (zeile, d string, zeilen pos) = zeilen pos
+ THEN terminator oder zeilenende gefunden
+ ELSE IF d pitch = maxint
+ THEN erweiterung gefunden
+ ELIF d pitch < 0
+ THEN a breite INCR (d pitch XOR - maxint - 1);
+ zeilen pos INCR 2;
+ ELSE a breite INCR d pitch;
+ zeilenpos INCR 1;
+ FI;
+ FI;
+
+. erweiterung gefunden :
+ a breite INCR extended char pitch (a font, zeile SUB zeilen pos,
+ zeile SUB zeilen pos + 1);
+ zeilen pos INCR 2;
+
+. anweisung gefunden :
+ gegebenfalls neues token gefunden;
+ analysiere anweisung;
+ IF zeile ist zu ende
+ THEN LEAVE bestimme token bis terminator oder zeilenende FI;
+ token zeiger := zeilenpos;
+
+. terminator oder zeilenende gefunden :
+ IF ausgang = null ausgang THEN zeilen laenge DECR 1 FI;
+ gegebenfalls neues token gefunden;
+ LEAVE bestimme token bis terminator oder zeilenende;
+
+ . gegebenfalls neues token gefunden :
+ IF token zeiger < zeilenpos THEN lege text token an FI;
+
+END PROC bestimme token bis terminator oder zeilen ende;
+
+
+PROC analysiere anweisung :
+
+ bestimme anweisung;
+ IF anweisung ist kommando
+ THEN lege kommando token an;
+ ELSE werte anweisung aus;
+ FI;
+
+ . anweisungsanfang : token zeiger
+
+ . anweisungsende : zeilen pos - 2
+
+ . erstes zeichen : par1
+
+. bestimme anweisung :
+ anweisungsanfang := zeilenpos + 1;
+ zeilen pos := pos (zeile, anweisungszeichen, anweisungsanfang, zeilenlaenge);
+ IF zeilenpos = 0
+ THEN zeilenpos := anweisungsanfang - 1;
+ replace (zeile, zeilenpos, geschuetztes anweisungszeichen);
+ LEAVE analysiere anweisung;
+ FI;
+ zeilen pos INCR 1;
+ anweisung := subtext (zeile, anweisungsanfang, anweisungsende);
+ erstes zeichen := anweisung SUB 1;
+
+. anweisung ist kommando :
+ IF erstes zeichen = quote
+ THEN scan (anweisung);
+ next symbol (anweisung, symbol type);
+ next symbol (par2, naechster symbol type);
+ IF symbol type <> text type OR naechster symbol type <> eof type
+ THEN LEAVE analysiere anweisung FI;
+ TRUE
+ ELIF erstes zeichen = druckerkommando zeichen
+ THEN delete char (anweisung, 1);
+ TRUE
+ ELSE FALSE
+ FI
+
+.
+ werte anweisung aus :
+ analyze command (anweisungs liste, anweisung, number type,
+ anweisungs index, anzahl params, par1, par2);
+ SELECT anweisungs index OF
+ CASE a type : type anweisung
+ CASE a on : on anweisung
+ CASE a off : off anweisung
+ CASE a ub, a fb : ub fb anweisung
+ CASE a ue, a fe : ue fe anweisung
+ CASE a center : center anweisung
+ CASE a right : right anweisung
+ CASE a up, a down : index anweisung
+ CASE a end up or down : end index anweisung
+ CASE a bsp : bsp anweisung
+ CASE a fillchar : fillchar anweisung
+ CASE a mark : mark anweisung
+ CASE a markend : markend anweisung
+ OTHERWISE : IF anweisungs index > 0 THEN speichere anweisung FI;
+ END SELECT;
+
+ . type anweisung :
+ change all (par1, " ", "");
+ stelle neuen font ein (font (par1));
+ groesste fonthoehe := max (groesste fonthoehe, fonthoehe);
+ a modifikationen := 0;
+ IF nicht innerhalb eines indexes THEN berechne aktuelle zeilenhoehe FI;
+
+ . nicht innerhalb eines indexes :
+ index zaehler = 0
+
+ . berechne aktuelle zeilenhoehe :
+ IF linefeed faktor >= 1.0
+ THEN aktuelle zeilenhoehe := max (groesste fonthoehe,
+ letzte zeilenhoehe);
+ ELSE aktuelle zeilenhoehe := max (aktuelle zeilenhoehe,
+ letzte zeilenhoehe);
+ FI;
+
+ . on anweisung :
+ par1 := par1 SUB 1;
+ IF pos (modifikations liste, par1) > 0
+ THEN set bit (a modifikationen, pos (modifikations liste, par1) - 1 );
+ FI;
+
+ . off anweisung :
+ par1 := par1 SUB 1;
+ IF pos (modifikations liste, par1) > 0
+ THEN reset bit (a modifikationen, pos (modifikations liste, par1) - 1 );
+ FI;
+
+ . ub fb anweisung :
+ IF anweisungs index = a ub
+ THEN par1 := "u"
+ ELSE par1 := "b"
+ FI;
+ on anweisung;
+
+ . ue fe anweisung :
+ IF anweisungs index = a ue
+ THEN par1 := "u"
+ ELSE par1 := "b"
+ FI;
+ off anweisung;
+
+ . center anweisung :
+ IF NOT zeile muss geblockt werden AND NOT tabellen modus
+ AND NOT right modus
+ THEN center modus := TRUE;
+ blankmodus := keine blankanalyse;
+ initialisiere tab variablen;
+ FI;
+
+ . right anweisung :
+ IF NOT zeile muss geblockt werden AND NOT tabellen modus
+ THEN IF center modus THEN zentriere zeile (limit DIV 2) FI;
+ right modus := TRUE;
+ blankmodus := keine blankanalyse;
+ initialisiere tab variablen;
+ FI;
+
+ . index anweisung :
+ INT CONST grosser font := a font, grosse fonthoehe := fonthoehe;
+ INT VAR kleiner font;
+ IF next smaller font exists (grosser font, kleiner font)
+ THEN stelle neuen font ein (kleiner font) FI;
+ IF font hoehe < grosse fonthoehe
+ THEN berechne verschiebung fuer kleinen font
+ ELSE berechne verschiebung fuer grossen font
+ FI;
+ a ypos INCR verschiebung;
+ merke grossen font und verschiebung;
+
+ . berechne verschiebung fuer kleinen font :
+ IF anweisungs index = a down
+ THEN verschiebung := 15 PROZENT grosse fonthoehe;
+ ELSE verschiebung := - ( 9 PROZENT grosse fonthoehe )
+ - (grosse fonthoehe - fonthoehe);
+ FI;
+
+ . berechne verschiebung fuer grossen font :
+ IF anweisungs index = a down
+ THEN verschiebung := 25 PROZENT fonthoehe;
+ ELSE verschiebung := - (50 PROZENT fonthoehe);
+ FI;
+
+ . merke grossen font und verschiebung :
+ index zaehler INCR 1;
+ grosse fonts CAT grosser font;
+ verschiebungen CAT verschiebung;
+ IF index zaehler = 1
+ THEN alter blankmodus := blankmodus;
+ blankmodus := keine blankanalyse;
+ FI;
+
+ . end index anweisung :
+ IF index zaehler > 0
+ THEN schalte auf groesseren font zurueck;
+ FI;
+
+ . schalte auf groesseren font zurueck :
+ a ypos DECR (verschiebungen ISUB index zaehler);
+ stelle neuen font ein (grosse fonts ISUB index zaehler);
+ IF index zaehler = 1
+ THEN blankmodus := alter blankmodus;
+ FI;
+ index zaehler DECR 1;
+ verschiebungen := subtext (verschiebungen, 1, 2 * index zaehler);
+ grosse fonts := subtext (grosse fonts, 1, 2 * index zaehler);
+
+ . bsp anweisung :
+ INT VAR breite davor, breite dahinter;
+ IF anweisungs anfang - 2 >= 1 AND anweisungs ende + 2 <= zeilen laenge
+ THEN IF is kanji esc (zeile SUB anweisungs anfang - 3)
+ THEN zeichen davor := subtext (zeile, anweisungs anfang - 3,
+ anweisungs anfang - 2);
+ ELSE zeichen davor := zeile SUB anweisungs anfang - 2;
+ FI;
+ IF is kanji esc (zeile SUB anweisungs ende + 2)
+ THEN zeichen dahinter := subtext (zeile, anweisungs ende + 2,
+ anweisungs ende + 3 );
+ ELSE zeichen dahinter := zeile SUB anweisungs ende + 2;
+ FI;
+ IF pos (" #", zeichen davor) = 0 AND pos (" #", zeichen dahinter) = 0
+ THEN breite davor := char pitch (a font, zeichen davor);
+ breite dahinter := char pitch (a font, zeichen dahinter);
+ IF breite davor < breite dahinter THEN vertausche zeichen FI;
+ lege token fuer zeichen dahinter an;
+ a xpos INCR (breite davor - breite dahinter) DIV 2;
+ FI;
+ FI;
+
+ . zeichen davor : par1
+ . zeichen dahinter : par2
+
+ . vertausche zeichen :
+ change (zeile, anweisungs anfang - 2 - LENGTH zeichen davor + 1,
+ anweisungs anfang - 2, zeichen dahinter);
+ change (zeile, anweisungs ende + 2,
+ anweisungs ende + 2 + LENGTH zeichen dahinter - 1, zeichen davor);
+ change (tf. text, LENGTH tf. text - LENGTH zeichen davor + 1,
+ LENGTH tf. text, zeichen dahinter);
+ tf. breite INCR (breite dahinter - breite davor);
+ a xpos INCR (breite dahinter - breite davor);
+ int param := breite davor;
+ breite davor := breite dahinter;
+ breite dahinter := int param;
+
+ . lege token fuer zeichen dahinter an :
+ token zeiger := zeilen pos;
+ a breite := breite dahinter;
+ zeilen pos INCR LENGTH zeichen dahinter;
+ a xpos DECR (breite davor + breite dahinter) DIV 2;
+ lege text token an;
+ anzahl zeichen DECR 1;
+
+ . fillchar anweisung :
+ IF par1 = "" THEN par1 := " " FI;
+ fill char := par1;
+ speichere anweisung;
+
+ . mark anweisung :
+ IF par1 <> ""
+ THEN mark index l := (alter mark index l MOD 2) + 1;
+ neue markierung (par1, mark index l);
+ ELSE mark index l := 0;
+ FI;
+ IF par2 <> ""
+ THEN mark index r := (alter mark index r MOD 2) + 3;
+ neue markierung (par2, mark index r);
+ ELSE mark index r := 0;
+ FI;
+
+ . markend anweisung :
+ loesche markierung;
+
+ . speichere anweisung :
+ anweisungs zaehler INCR 1;
+ anweisungs indizes CAT anweisungs index;
+ IF par1 <> ""
+ THEN insert (params1, par1);
+ params1 zeiger CAT highest entry (params1);
+ ELSE params1 zeiger CAT 0;
+ FI;
+ IF par2 <> ""
+ THEN insert (params2, par2);
+ params2 zeiger CAT highest entry (params2);
+ ELSE params2 zeiger CAT 0;
+ FI;
+
+END PROC analysiere anweisung;
+
+
+PROC stelle neuen font ein (INT CONST font nr ) :
+
+ IF font nr <> a font THEN neuer font FI;
+
+ . neuer font :
+ a font := max (1, font nr);
+ get font (a font, einrueckbreite, font durchschuss, font hoehe, font tiefe,
+ zeichenbreiten);
+ font hoehe INCR (font durchschuss + font tiefe);
+ letzte zeilenhoehe := neue zeilenhoehe;
+ blankbreite := zeichenbreiten (blank code 1);
+ zeichenbreiten (blank code 1) := blank ausgang;
+ zeichenbreiten (anweisungs zeichen code 1) := anweisungs ausgang;
+ font offsets := y offsets (a font);
+ offsets := LENGTH font offsets > 2;
+ IF d code 1 <> leer
+ THEN d pitch := zeichenbreiten (d code 1);
+ zeichenbreiten (d code 1) := d code ausgang;
+ FI;
+
+END PROC stelle neuen font ein;
+
+
+INT OP PROZENT (INT CONST prozent, wert) :
+
+ (wert * prozent + 99) DIV 100
+
+END OP PROZENT;
+
+
+PROC neue markierung (TEXT CONST text, INT CONST mark index) :
+
+ mark token (mark index). text := text;
+ mark token (mark index). breite := string breite (text);
+ mark token (mark index). font := a font;
+ mark token (mark index). modifikationen := a modifikationen;
+
+END PROC neue markierung;
+
+
+INT PROC string breite (TEXT CONST string) :
+
+ INT VAR summe := 0, pos := 1;
+ REP stranalyze (zeichenbreiten, summe, max breite, string, pos, maxint, ausgang);
+ IF ausgang = erweiterungs ausgang
+ THEN summe INCR extended char pitch (a font,
+ string SUB pos+1, string SUB pos+2);
+ pos INCR 3;
+ ELIF ausgang = blank ausgang
+ THEN summe INCR blankbreite;
+ pos INCR 2;
+ ELIF ausgang = anweisungs ausgang
+ THEN summe INCR char pitch (a font, anweisungszeichen);
+ pos INCR 2;
+ ELSE LEAVE string breite WITH summe
+ FI;
+ PER;
+ 0
+
+END PROC string breite;
+
+(*******************************************************************)
+
+PROC lege text token an :
+
+ aktuelle ypos := a ypos + (font offsets ISUB 1);
+ neuer token index;
+ uebertrage text token (tf);
+ IF offsets THEN lege offsets an (font offsets) FI;
+ stranalyze (zeichen zaehler, anzahl zeichen, max int,
+ zeile, token zeiger, zeilen pos - 1, ausgang);
+ a xpos INCR a breite;
+ a breite := 0;
+ a modifikationen fuer x move := 0;
+ a block token := FALSE;
+
+END PROC lege text token an;
+
+
+PROC uebertrage text token (TOKEN VAR tf) :
+
+ tf. text := subtext (zeile, token zeiger, zeilenpos - 1);
+ tf. xpos := a xpos;
+ tf. breite := a breite;
+ tf. font := a font;
+ tf. modifikationen := a modifikationen;
+ tf. modifikationen fuer x move := a modifikationen fuer x move;
+ tf. offset index := text token;
+ tf. block token := a block token;
+
+END PROC uebertrage text token;
+
+
+PROC lege kommando token an :
+
+ aktuelle ypos := a ypos + (font offsets ISUB 1);
+ neuer token index;
+ uebertrage kommando token (tf);
+ a modifikationen fuer x move := 0;
+ a block token := FALSE;
+
+END PROC lege kommando token an;
+
+
+PROC uebertrage kommando token (TOKEN VAR tf) :
+
+ tf. text := anweisung;
+ tf. breite := 0;
+ tf. xpos := a xpos;
+ tf. font := a font;
+ tf. modifikationen := a modifikationen;
+ tf. modifikationen fuer x move := a modifikationen fuer x move;
+ tf. offset index := kommando token;
+ tf. block token := a block token;
+
+END PROC uebertrage kommando token;
+
+
+PROC lege markierungs token an (INT CONST mark index) :
+
+ aktuelle ypos := a ypos + (mark font offsets ISUB 1);
+ neuer token index;
+ tf := mark token (mark index);
+ IF mark offsets THEN lege offsets an (mark font offsets) FI;
+
+ . mark font offsets : y offsets (mark token (mark index). font)
+
+ . mark offsets : LENGTH mark font offsets > 2
+
+END PROC lege markierungs token an;
+
+
+PROC lege offsets an (TEXT CONST offsets) :
+
+ INT CONST anzahl offsets := LENGTH offsets DIV 2;
+ offset token := tf;
+ offset token. block token := FALSE;
+ reset bit (offset token. modifikationen, underline bit);
+ FOR index FROM 2 UPTO anzahl offsets
+ REP aktuelle ypos := a ypos + (offsets ISUB index);
+ neuer token index;
+ tf := offset token;
+ tf. offset index := index;
+ PER;
+
+END PROC lege offsets an;
+
+
+PROC neuer token index :
+
+IF erster ypos index a = 0
+ THEN erste ypos
+ELIF ya. ypos = aktuelle ypos
+ THEN neues token bei gleicher ypos
+ ELSE fuege neue ypos ein
+FI;
+
+ . erste ypos :
+ ypos index f INCR 1;
+ erster ypos index a := ypos index f;
+ letzter ypos index a := ypos index f;
+ yf. vorheriger ypos index := 0;
+ yf. naechster ypos index := 0;
+ erstes token bei neuer ypos;
+
+ . fuege neue ypos ein :
+ letztes token bei gleicher ypos;
+ IF ya. ypos > aktuelle ypos
+ THEN richtige ypos ist oberhalb
+ ELSE richtige ypos ist unterhalb
+ FI;
+
+ . richtige ypos ist oberhalb :
+ REP ypos index a := ya. vorheriger ypos index;
+ IF ypos index a = 0
+ THEN fuege ypos vor erstem ypos index ein;
+ LEAVE richtige ypos ist oberhalb;
+ ELIF ya. ypos = aktuelle ypos
+ THEN neues token bei neuer ypos;
+ LEAVE richtige ypos ist oberhalb;
+ ELIF ya. ypos < aktuelle ypos
+ THEN fuege ypos nach ypos index ein;
+ LEAVE richtige ypos ist oberhalb;
+ FI;
+ PER;
+
+ . richtige ypos ist unterhalb :
+ REP ypos index a := ya. naechster ypos index;
+ IF ypos index a = 0
+ THEN fuege ypos nach letztem ypos index ein;
+ LEAVE richtige ypos ist unterhalb;
+ ELIF ya. ypos = aktuelle ypos
+ THEN neues token bei neuer ypos;
+ LEAVE richtige ypos ist unterhalb;
+ ELIF ya. ypos > aktuelle ypos
+ THEN fuege ypos vor ypos index ein;
+ LEAVE richtige ypos ist unterhalb;
+ FI;
+ PER;
+
+ . fuege ypos vor erstem ypos index ein :
+ ypos index f INCR 1;
+ yf. vorheriger ypos index := 0;
+ yf. naechster ypos index := erster ypos index a;
+ erster ypos index a := ypos index f;
+ ypos index a := yf. naechster ypos index;
+ ya. vorheriger ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+ . fuege ypos nach ypos index ein :
+ ypos index f INCR 1;
+ yf. vorheriger ypos index := ypos index a;
+ yf. naechster ypos index := ya. naechster ypos index;
+ ya. naechster ypos index := ypos index f;
+ ypos index a := yf. naechster ypos index;
+ ya. vorheriger ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+ . fuege ypos vor ypos index ein :
+ ypos index f INCR 1;
+ yf. naechster ypos index := ypos index a;
+ yf. vorheriger ypos index := ya. vorheriger ypos index;
+ ya. vorheriger ypos index := ypos index f;
+ ypos index a := yf. vorheriger ypos index;
+ ya. naechster ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+ . fuege ypos nach letztem ypos index ein :
+ ypos index f INCR 1;
+ yf. naechster ypos index := 0;
+ yf. vorheriger ypos index := letzter ypos index a;
+ letzter ypos index a := ypos index f;
+ ypos index a := yf. vorheriger ypos index;
+ ya. naechster ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+END PROC neuer token index;
+
+
+PROC erstes token bei neuer ypos :
+ token index f INCR 1;
+ ypos index a := ypos index f;
+ ya. erster token index := token index f;
+ ya. ypos := aktuelle ypos;
+END PROC erstes token bei neuer ypos;
+
+
+PROC neues token bei neuer ypos :
+ token index f INCR 1;
+ ya. ypos := aktuelle ypos;
+ token index := ya. letzter token index;
+ t. naechster token index := token index f;
+END PROC neues token bei neuer ypos;
+
+
+PROC neues token bei gleicher ypos :
+ tf. naechster token index := token index f + 1;
+ token index f INCR 1;
+END PROC neues token bei gleicher ypos;
+
+
+PROC letztes token bei gleicher ypos :
+ tf. naechster token index := 0;
+ ya. letzter token index := token index f;
+END PROC letztes token bei gleicher ypos;
+
+
+PROC loesche letztes token :
+
+ IF token index f = ya. erster token index
+ THEN loesche ypos
+ ELSE token index f DECR 1;
+ FI;
+
+ . loesche ypos :
+ kette vorgaenger um;
+ kette nachfolger um;
+ bestimme letzten ypos index;
+
+ . kette vorgaenger um :
+ ypos index := ya. vorheriger ypos index;
+ IF ypos index = 0
+ THEN erster ypos index a := ya. naechster ypos index;
+ ELSE y. naechster ypos index := ya. naechster ypos index;
+ FI;
+
+ . kette nachfolger um :
+ ypos index := ya. naechster ypos index;
+ IF ypos index = 0
+ THEN letzter ypos index a := ya. vorheriger ypos index;
+ ELSE y. vorheriger ypos index := ya. vorheriger ypos index;
+ FI;
+
+ . bestimme letzten ypos index :
+ IF ypos index a = ypos index f THEN ypos index f DECR 1 FI;
+ token index f DECR 1;
+ ypos index a := letzter ypos index a;
+ WHILE ypos index a <> 0
+ CAND ya. letzter token index <> token index f
+ REP ypos index a := ya. vorheriger ypos index PER;
+
+END PROC loesche letztes token;
+
+
+PROC blocke token xpos (INT CONST dehnung 1, dehnung 2,
+ anzahl dehnungen fuer dehnung 1 ) :
+
+ INT VAR dehnung := 0, anzahl dehnungen := 0;
+ token index := erstes tab token;
+ WHILE token index <= token index f
+ REP erhoehe token xpos bei block token;
+ t. xpos INCR dehnung;
+ token index INCR 1;
+ PER;
+
+ . erhoehe token xpos bei block token :
+ IF t. block token
+ THEN IF anzahl dehnungen < anzahl dehnungen fuer dehnung 1
+ THEN anzahl dehnungen INCR 1;
+ dehnung INCR dehnung 1;
+ ELSE dehnung INCR dehnung 2;
+ FI;
+ FI;
+
+END PROC blocke token xpos;
+
+
+PROC verschiebe token xpos (INT CONST verschiebung) :
+
+ token index := erstes tab token;
+ WHILE token index <= token index f
+ REP t. xpos INCR verschiebung;
+ token index INCR 1;
+ PER;
+
+END PROC verschiebe token xpos;
+
+
+PROC verschiebe token ypos (INT CONST verschiebung) :
+
+ ypos index := erster ypos index a;
+ WHILE ypos index <> 0
+ REP y. ypos INCR verschiebung;
+ ypos index := y. naechster ypos index;
+ PER;
+
+END PROC verschiebe token ypos;
+
+
+PROC sortiere neue token ein :
+
+IF analysespeicher ist nicht leer
+ THEN IF druckspeicher ist nicht leer
+ THEN sortiere neue token in sortierte liste ein
+ ELSE sortierte liste ist leer
+ FI;
+FI;
+
+. sortierte liste ist leer :
+ IF erster ypos index a <> 0
+ THEN erster ypos index d := erster ypos index a;
+ letzter ypos index d := letzter ypos index a;
+ ypos index d := letzter ypos index a;
+ FI;
+
+. sortiere neue token in sortierte liste ein :
+ gehe zum ersten neuen token;
+ bestimme erste einsortierposition;
+ WHILE es gibt noch neue token
+ REP IF ypos index d = 0
+ THEN haenge neue token ans ende der sortierten liste
+ ELIF ya. ypos > yd. ypos
+ THEN naechste ypos der sortierten liste
+ ELIF ya. ypos = yd. ypos
+ THEN neues token auf gleicher ypos
+ ELSE neue token vor ypos
+ FI;
+ PER;
+
+ . gehe zum ersten neuen token :
+ ypos index a := erster ypos index a;
+
+ . bestimme erste einsortierposition :
+ WHILE ypos index d <> 0 CAND ya. ypos < yd. ypos
+ REP ypos index d := yd. vorheriger ypos index PER;
+ IF ypos index d = 0 THEN erste neue token vor listen anfang FI;
+
+ . erste neue token vor listen anfang :
+ ypos index d := erster ypos index d;
+ erster ypos index d := erster ypos index a;
+ REP ypos index a := ya. naechster ypos index;
+ IF ypos index a = 0
+ THEN verkette letztes ya mit yd;
+ LEAVE sortiere neue token in sortierte liste ein
+ ELIF ya. ypos = yd. ypos
+ THEN verkette ya mit yd;
+ LEAVE erste neue token vor listen anfang
+ ELIF ya. ypos > yd. ypos
+ THEN verkette vorheriges ya mit yd;
+ ypos index d := yd. naechster ypos index;
+ LEAVE erste neue token vor listen anfang
+ FI;
+ PER;
+
+ . es gibt noch neue token :
+ ypos index a <> 0
+
+ . haenge neue token ans ende der sortierten liste :
+ ypos index d := letzter ypos index d;
+ yd. naechster ypos index := ypos index a;
+ ya. vorheriger ypos index := ypos index d;
+ letzter ypos index d := letzter ypos index a;
+ ypos index d := letzter ypos index a;
+ ypos index a := 0;
+
+ . naechste ypos der sortierten liste :
+ ypos index d := yd. naechster ypos index;
+
+ . neues token auf gleicher ypos :
+ token index := yd. letzter token index;
+ t . naechster token index := ya. erster token index;
+ yd. letzter token index := ya. letzter token index;
+ ypos index a := ya. naechster ypos index;
+ ypos index d := yd. naechster ypos index;
+ IF ypos index d = 0 THEN ypos index d := letzter ypos index d FI;
+
+ . neue token vor ypos :
+ verkette ya mit vorherigem yd;
+ REP ypos index a := ya. naechster ypos index;
+ IF ypos index a = 0
+ THEN verkette letztes ya mit yd;
+ LEAVE sortiere neue token in sortierte liste ein
+ ELIF ya. ypos = yd. ypos
+ THEN verkette ya mit yd;
+ LEAVE neue token vor ypos
+ ELIF ya. ypos > yd. ypos
+ THEN verkette vorheriges ya mit yd;
+ ypos index d := yd. naechster ypos index;
+ LEAVE neue token vor ypos
+ FI;
+ PER;
+
+
+. verkette ya mit vorherigem yd :
+ index := ypos index d;
+ ypos index d := yd. vorheriger ypos index;
+ yd. naechster ypos index := ypos index a;
+ ya. vorheriger ypos index := ypos index d;
+ ypos index d := index;
+
+. verkette letztes ya mit yd :
+ ypos index a := letzter ypos index a;
+ yd. vorheriger ypos index := ypos index a;
+ ya. naechster ypos index := ypos index d;
+ ypos index a := 0;
+
+. verkette vorheriges ya mit yd :
+ index := ypos index a;
+ ypos index a := ya. vorheriger ypos index;
+ yd. vorheriger ypos index := ypos index a;
+ ya. naechster ypos index := ypos index d;
+ ypos index a := index;
+
+. verkette ya mit yd :
+ verkette vorheriges ya mit yd;
+ neues token auf gleicher ypos;
+
+END PROC sortiere neue token ein;
+
+(***************************************************************)
+
+PROC drucke tokenspeicher
+ (INT CONST max ypos,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+IF druckspeicher ist nicht leer
+ THEN gehe zur ersten ypos;
+ WHILE yd. ypos <= max ypos
+ REP drucke token bei ypos;
+ gehe zur naechsten ypos;
+ PER;
+ loesche gedruckte token;
+FI;
+
+. gehe zur ersten ypos :
+ ypos index d := erster ypos index d;
+
+. drucke token bei ypos :
+ IF yd. ypos >= - y start
+ THEN druck durchgang;
+ IF bold pass THEN fett durchgang FI;
+ IF underline pass THEN unterstreich durchgang FI;
+ FI;
+
+ . bold pass : bit (pass, bold bit)
+
+ . underline pass : bit (pass, underline bit)
+
+. gehe zur naechsten ypos :
+ IF ypos index d = letzter ypos index d
+ THEN loesche druckspeicher;
+ LEAVE drucke tokenspeicher;
+ FI;
+ ypos index d := yd. naechster ypos index;
+
+. loesche gedruckte token :
+ erster ypos index d := ypos index d;
+ yd. vorheriger ypos index := 0;
+
+.
+ druck durchgang :
+ verschiebung := yd. ypos - d ypos;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ gehe zum ersten token dieser ypos;
+ REP drucke token UNTIL kein token mehr vorhanden PER;
+ gib cr aus;
+
+ . drucke token :
+ IF NOT token passt in zeile THEN berechne token teil FI;
+ font wechsel wenn noetig;
+ x move mit modifikations ueberpruefung;
+ IF token ist text token
+ THEN gib text token aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ ELSE gib kommando token aus
+ FI;
+
+ . gib kommando token aus :
+ execute (write cmd, d token. text, 1, LENGTH d token. text)
+
+ . berechne token teil :
+ INT CONST fuenf punkte := 5 * char pitch (d token. font, punkt);
+ INT VAR token pos, token breite, anzahl punkte, zeichen laenge, zeichen breite;
+ IF d token. xpos < - x start
+ AND d token. xpos + d token. breite > - x start
+ THEN berechne token teil von links
+ ELIF d token. xpos < papierbreite
+ AND d token. xpos + d token. breite > papierbreite
+ THEN berechne token teil nach rechts
+ ELSE LEAVE drucke token
+ FI;
+
+ . berechne token teil von links :
+ rest := min (x size, d token. xpos + d token. breite + x start);
+ d token. xpos := - x start;
+ IF rest <= fuenf punkte
+ THEN anzahl punkte := rest DIV char pitch (d token. font, punkt);
+ d token. text := anzahl punkte * punkt;
+ d token. breite := anzahl punkte * char pitch (d token. font, punkt);
+ ELSE token pos := LENGTH d token. text + 1;
+ token breite := fuenf punkte;
+ berechne token teil breite von hinten;
+ change (d token. text, 1, token pos - 1, 5 * punkt);
+ d token. breite := token breite;
+ FI;
+
+ . berechne token teil breite von hinten :
+ WHILE naechstes zeichen passt noch davor
+ REP token breite INCR zeichen breite;
+ token pos DECR zeichen laenge;
+ PER;
+
+ . naechstes zeichen passt noch davor :
+ IF within kanji (d token. text, token pos - 1)
+ THEN zeichen laenge := 2
+ ELSE zeichen laenge := 1
+ FI;
+ zeichen breite := char pitch (d token. font,
+ subtext (d token. text, token pos - zeichen laenge, token pos - 1));
+ token breite + zeichen breite < rest
+
+ . berechne token teil nach rechts :
+ rest := papier breite - d token. xpos;
+ IF rest <= fuenf punkte
+ THEN anzahl punkte := rest DIV char pitch (d token. font, punkt);
+ d token. text := anzahl punkte * punkt;
+ d token. breite := anzahl punkte * char pitch (d token. font, punkt);
+ ELSE token pos := 0;
+ token breite := fuenf punkte;
+ berechne token teil breite von vorne;
+ change (d token. text, token pos + 1, LENGTH d token. text, 5 * punkt);
+ d token. breite := token breite;
+ FI;
+
+ . berechne token teil breite von vorne :
+ WHILE naechstes zeichen passt noch dahinter
+ REP token breite INCR zeichen breite;
+ token pos INCR zeichen laenge;
+ PER;
+
+ . naechstes zeichen passt noch dahinter :
+ IF is kanji esc (d token. text SUB token pos + 1)
+ THEN zeichen laenge := 2
+ ELSE zeichen laenge := 1
+ FI;
+ zeichen breite := char pitch (d token. font,
+ subtext (d token. text, token pos + 1, token pos + zeichen laenge));
+ token breite + zeichen breite < rest
+
+.
+ fett durchgang :
+ reset bit (pass, bold bit);
+ gehe zum ersten token dieser ypos;
+ REP gib token nochmal aus UNTIL kein token mehr vorhanden PER;
+ schalte modifikationen aus wenn noetig;
+ gib cr aus;
+
+ . gib token nochmal aus :
+ INT CONST min verschiebung := bold offset (d token. font);
+ d token. xpos INCR min verschiebung;
+ IF bit (d token. modifikationen, bold bit) AND
+ token passt in zeile AND token ist text token
+ THEN verschiebung := d token. xpos - d xpos;
+ font wechsel wenn noetig;
+ schalte italics ein wenn noetig;
+ x move wenn noetig;
+ gib text token aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ d token. xpos DECR min verschiebung;
+
+ . schalte italics ein wenn noetig :
+ IF bit (d token. modifikationen, italics bit)
+ THEN neue modifikationen := modifikations werte (italics bit + 1);
+ schalte modifikationen ein wenn noetig;
+ ELSE schalte modifikationen aus wenn noetig;
+ FI;
+
+.
+ unterstreich durchgang :
+ INT VAR l xpos := 0;
+ reset bit (pass, underline bit);
+ schalte modifikationen aus wenn noetig;
+ gehe zum ersten token dieser ypos;
+ REP unterstreiche token UNTIL kein token mehr vorhanden PER;
+ gib cr aus;
+
+ . unterstreiche token :
+ IF token muss unterstrichen werden AND
+ token passt in zeile AND token ist text token
+ THEN font wechsel wenn noetig;
+ berechne x move laenge;
+ x move wenn noetig;
+ berechne unterstreich laenge;
+ unterstreiche;
+ FI;
+ l xpos := d token. xpos + d token. breite;
+
+ . token muss unterstrichen werden :
+ bit (d token. modifikationen, underline bit) OR
+ bit (d token. modifikationen fuer x move, underline bit)
+
+ . berechne x move laenge :
+ IF bit (d token. modifikationen fuer x move, underline bit)
+ THEN verschiebung := l xpos - d xpos
+ ELSE verschiebung := d token. xpos - d xpos
+ FI;
+
+ . berechne unterstreich laenge :
+ INT VAR unterstreich verschiebung;
+ IF bit (d token. modifikationen, underline bit)
+ THEN unterstreich verschiebung := d token. xpos +
+ d token. breite - d xpos
+ ELSE unterstreich verschiebung := d token. xpos - d xpos
+ FI;
+
+
+. gehe zum ersten token dieser ypos :
+ token index := yd. erster token index;
+ d token := t;
+
+. kein token mehr vorhanden :
+ token index := d token. naechster token index;
+ IF token index = 0
+ THEN TRUE
+ ELSE d token := t;
+ FALSE
+ FI
+
+. token ist text token :
+ d token. offset index >= text token
+
+. token passt in zeile :
+ d token. xpos >= - x start AND
+ d token. xpos + d token. breite <= papier breite
+
+. font wechsel wenn noetig :
+ IF d token. font <> d font
+ THEN font wechsel (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. schalte modifikationen ein wenn noetig :
+ IF d modifikationen <> neue modifikationen
+ THEN schalte modifikationen ein (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. schalte modifikationen aus wenn noetig :
+ IF d modifikationen <> 0
+ THEN schalte modifikationen aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. x move wenn noetig :
+ IF verschiebung <> 0
+ THEN x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. gib cr aus :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+
+.
+ x move mit modifikations ueberpruefung :
+ verschiebung := d token. xpos - d xpos;
+ IF verschiebung <> 0
+ THEN neue modifikationen := d token. modifikationen fuer x move;
+ schalte modifikationen ein wenn noetig;
+ x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ neue modifikationen := d token. modifikationen;
+ schalte modifikationen ein wenn noetig;
+
+.
+ unterstreiche :
+ IF unterstreich verschiebung > 0
+ THEN disable stop;
+ d xpos INCR unterstreich verschiebung;
+ execute (draw, "", unterstreich verschiebung, 0);
+ IF is error
+ THEN unterstreiche nach cr;
+ FI;
+ enable stop;
+ FI;
+
+ . unterstreiche nach cr :
+ clear error;
+ d xpos DECR unterstreich verschiebung;
+ verschiebung := d xpos;
+ gib cr aus;
+ x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ d xpos INCR unterstreich verschiebung;
+ execute (draw, "", unterstreich verschiebung, 0);
+ IF is error
+ THEN clear error;
+ d xpos DECR unterstreich verschiebung;
+ gib cr aus;
+ LEAVE unterstreich durchgang;
+ FI;
+
+END PROC drucke tokenspeicher;
+
+PROC y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ IF verschiebung <> 0
+ THEN disable stop;
+ d ypos INCR verschiebung;
+ execute (move, "", 0, verschiebung);
+ IF is error
+ THEN clear error;
+ d ypos DECR verschiebung;
+ verschiebung := 0;
+ FI;
+ enable stop;
+ FI;
+
+END PROC y move;
+
+
+PROC x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ d xpos INCR verschiebung;
+ execute (move, "", verschiebung, 0);
+ IF is error
+ THEN fuehre x move nach cr aus
+ FI;
+
+ . fuehre x move nach cr aus :
+ clear error;
+ schalte modifikationen aus wenn noetig;
+ gib cr aus;
+ IF d xpos <> 0
+ THEN execute (move, "", d xpos, 0);
+ IF is error
+ THEN clear error;
+ d xpos := 0;
+ FI
+ FI;
+ schalte modifikationen ein wenn noetig;
+
+ . gib cr aus :
+ execute (carriage return, "", d xpos - verschiebung, 0);
+
+ . schalte modifikationen aus wenn noetig :
+ neue modifikationen := d modifikationen;
+ IF d modifikationen <> 0
+ THEN schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+
+ . schalte modifikationen ein wenn noetig :
+ IF d modifikationen <> neue modifikationen
+ THEN schalte modifikationen ein
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+
+END PROC x move;
+
+
+PROC schalte modifikationen ein
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ INT VAR index;
+ IF d modifikationen <> 0
+ THEN schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ d modifikationen := neue modifikationen;
+ FOR index FROM 1 UPTO anzahl modifikationen
+ REP IF bit (d modifikationen, modifikations bit)
+ THEN modifikation muss eingeschaltet werden
+ FI;
+ PER;
+
+ . modifikations bit : index - 1
+
+ . modifikation muss eingeschaltet werden :
+ IF bit (modifikations modus, modifikations bit)
+ THEN execute (on, "", modifikations werte (index), 0);
+ IF is error
+ THEN clear error;
+ reset bit (modifikations modus, modifikations bit);
+ set bit (pass, modifikations bit);
+ FI;
+ ELSE set bit (pass, modifikations bit);
+ FI;
+
+END PROC schalte modifikationen ein;
+
+
+PROC schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ INT VAR index;
+ FOR index FROM 1 UPTO anzahl modifikationen
+ REP IF bit (d modifikationen, modifikations bit)
+ THEN modifikation muss ausgeschaltet werden
+ FI;
+ PER;
+ d modifikationen := 0;
+
+ . modifikations bit : index - 1
+
+ . modifikation muss ausgeschaltet werden :
+ IF bit (modifikations modus, modifikations bit)
+ THEN execute (off, "", modifikations werte (index), 0);
+ IF is error THEN clear error FI;
+ FI;
+
+END PROC schalte modifikationen aus;
+
+
+PROC font wechsel
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ d font := d token. font;
+ get replacements (d font, replacements, replacement tabelle);
+ execute (type, "", d font, 0);
+ IF is error THEN font wechsel nach cr FI;
+ enable stop;
+
+ . font wechsel nach cr :
+ clear error;
+ verschiebung := d xpos;
+ gib cr aus;
+ execute (type, "", d font, 0);
+ IF NOT is error
+ THEN schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ x move
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+
+ . gib cr aus :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+
+END PROC font wechsel;
+
+
+PROC gib text token aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ INT CONST token laenge := LENGTH d token. text;
+ INT VAR token pos := 1, alte token pos, summe := 0;
+ IF token laenge > 0
+ THEN REP alte token pos := token pos;
+ stranalyze (replacement tabelle, summe, 0,
+ d token. text, token pos, token laenge,
+ ausgang);
+ IF ausgang = 0
+ THEN gib token rest aus;
+ ELSE gib token teil aus;
+ gib ersatzdarstellung aus;
+ FI;
+ PER;
+ FI;
+
+ . gib token rest aus :
+ IF token laenge >= alte token pos
+ THEN execute (write text, d token. text, alte token pos, token laenge) FI;
+ d xpos INCR d token. breite;
+ LEAVE gib text token aus;
+
+ . gib token teil aus :
+ IF token pos >= alte token pos
+ THEN execute (write text, d token. text, alte token pos, token pos) FI;
+
+ . gib ersatzdarstellung aus :
+ IF ausgang = maxint
+ THEN ersatzdarstellung := extended replacement (d token. font,
+ d token. text SUB token pos + 1, d token. text SUB token pos + 2);
+ execute (write text, ersatzdarstellung, 1, LENGTH ersatzdarstellung);
+ tokenpos INCR 3;
+ ELSE IF ausgang < 0
+ THEN ausgang := ausgang XOR (-32767-1);
+ token pos INCR 1;
+ FI;
+ execute (write text, replacements, ausgang + 1, ausgang + code (replacements SUB ausgang));
+ token pos INCR 2;
+ FI;
+
+ . ersatzdarstellung : par1
+
+END PROC gib text token aus;
+
+
+PROC schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+enable stop;
+gebe restliche token aus;
+seiten ende kommando;
+
+. gebe restliche token aus :
+ IF erster ypos index d <> 0
+ THEN drucke tokenspeicher (maxint,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ rest := papier laenge - d ypos;
+
+. seiten ende kommando :
+ seite ist offen := FALSE;
+ a ypos := top margin;
+ aktuelle spalte := 1;
+ close (page, rest);
+
+END PROC schliesse seite ab;
+
+
+PROC eroeffne seite (INT CONST x wanted, y wanted,
+ PROC (INT CONST, INT VAR, INT VAR) open ) :
+
+IF vor erster seite THEN eroeffne druck FI;
+seiten anfang kommando;
+initialisiere neue seite;
+
+. eroeffne druck :
+ open (document, x size, y size);
+ vor erster seite := FALSE;
+ d font := -1;
+ d modifikationen := 0;
+
+. seiten anfang kommando :
+ x start := x wanted;
+ y start := y wanted;
+ open (page, x start, y start);
+ gedruckte seiten INCR 1;
+ seite ist offen := TRUE;
+
+. initialisiere neue seite :
+ INT CONST dif left margin := x wanted - x start - left margin + indentation,
+ dif top margin := y wanted - y start - top margin;
+ IF dif left margin <> 0
+ THEN erstes tab token := 1;
+ verschiebe token xpos (dif left margin);
+ a xpos INCR dif left margin;
+ left margin INCR dif left margin;
+ FI;
+ IF dif top margin <> 0
+ THEN verschiebe token ypos (dif top margin);
+ a ypos INCR dif top margin;
+ top margin INCR dif top margin;
+ FI;
+ d xpos := 0;
+ d ypos := 0;
+ IF seitenlaenge <= papierlaenge
+ THEN seitenlaenge := top margin + pagelength;
+ ELSE seitenlaenge DECR papierlaenge;
+ FI;
+ papierlaenge := y size - y start;
+ papierbreite := x size - x start;
+
+END PROC eroeffne seite;
+
+(****************************************************************)
+
+PROC elan fuss und kopf (INT CONST fuss oder kopf,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+IF fuss oder kopf <= 0 THEN elan fuss FI;
+IF fuss oder kopf >= 0 THEN elan kopf FI;
+
+.
+ elan fuss :
+ y move zur fusszeile;
+ drucke elan fuss;
+ close page cmd;
+
+. y move zur fusszeile :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ verschiebung := rest auf seite - font hoehe;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+. drucke elan fuss :
+ IF bottom label = ""
+ THEN seiten nr := ""
+ ELSE seiten nr := bottom label;
+ seiten nr CAT "/";
+ FI;
+ seiten nr CAT text (gedruckte seiten);
+ elan text := seiten nr;
+ elan text CAT " ";
+ elan text cat blanks ((max zeichen fuss - LENGTH dateiname) DIV 2 - LENGTH elan text);
+ elan text CAT dateiname;
+ elan text cat blanks (max zeichen fuss - LENGTH seiten nr - LENGTH elan text - 3);
+ elan text CAT " ";
+ elan text CAT seiten nr;
+ IF LENGTH elan text > max zeichen zeile
+ THEN elan text := subtext (elan text, 1, max zeichen zeile) FI;
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ . seiten nr : par1
+
+. close page cmd :
+ close (page, papierlaenge - d ypos);
+ seite ist offen := FALSE;
+
+.
+ elan kopf :
+ open page cmd ;
+ y move zur kopfzeile;
+ drucke elan kopf;
+
+. open page cmd :
+ x start := x wanted;
+ y start := y wanted;
+ open (page, x start, y start);
+ IF fuss oder kopf = 1 THEN execute (type, "", d font, 0) FI;
+ gedruckte seiten INCR 1;
+ seite ist offen := TRUE;
+ top margin := y wanted - y start;
+ left margin := x wanted - x start;
+ rest auf seite := pagelength;
+ papierlaenge := y size - y start;
+ d ypos := 0;
+ d xpos := 0;
+
+. y move zur kopf zeile :
+ verschiebung := top margin;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ IF verschiebung = 0 THEN rest auf seite INCR top margin FI;
+
+. drucke elan kopf :
+ elan text := headline pre;
+ elan text CAT date;
+ elan text CAT headline post;
+ elan text CAT datei name;
+ IF LENGTH elan text > max zeichen zeile
+ THEN elan text := subtext (elan text, 1, max zeichen zeile) FI;
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ cr plus lf (2, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ENDPROC elan fuss und kopf;
+
+
+PROC gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+cr plus lf (1, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+linker rand wenn noetig;
+d token. breite := LENGTH elan text * einrueckbreite;
+gib text token aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+. linker rand wenn noetig :
+ IF left margin > 0
+ THEN disable stop;
+ d xpos := left margin;
+ execute (move, "", left margin, 0);
+ IF is error
+ THEN clear error;
+ d xpos := 0;
+ FI;
+ enable stop;
+ FI;
+
+END PROC gib elan text aus;
+
+
+PROC cr plus lf (INT CONST anzahl,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+gib cr aus;
+gib lf aus;
+rest auf seite DECR verschiebung;
+
+. gib cr aus :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+
+. gib lf aus :
+ verschiebung := anzahl * font hoehe;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+END PROC cr plus lf ;
+
+
+END PACKET eumel printer;
diff --git a/system/std.zusatz/1.7.5/src/font convertor 9 b/system/std.zusatz/1.7.5/src/font convertor 9 new file mode 100644 index 0000000..22ce9af --- /dev/null +++ b/system/std.zusatz/1.7.5/src/font convertor 9 @@ -0,0 +1,1065 @@ +PACKET font convertor (* Autor : Rudolf Ruland *)
+ (* Stand : 11.07.86 *)
+ DEFINES create font table , (* Version 9 *)
+ add fonts,
+ create font file :
+
+
+LET t tag = 1,
+ t bold = 2,
+ t number = 3,
+ t text = 4,
+ t operator = 5,
+ t delimiter = 6,
+ t end of file = 7,
+
+ nil modus = 0,
+ font table modus = 1,
+ font modus = 2,
+ extension modus = 3,
+
+ x unit = 1,
+ y unit = 2,
+ on string = 3,
+ off string = 4,
+ indentation pitch = 5,
+ font lead = 6,
+ font height = 7,
+ font depth = 8,
+ larger font = 9,
+ smaller font = 10,
+ font string = 11,
+ y off sets = 12,
+ bold off set = 13;
+
+THESAURUS VAR names, english identification := empty thesaurus,
+ german identification := empty thesaurus;
+
+insert (english identification, "xunit");
+insert (english identification, "yunit");
+insert (english identification, "onstring");
+insert (english identification, "offstring");
+insert (english identification, "indentationpitch");
+insert (english identification, "fontlead");
+insert (english identification, "fontheight");
+insert (english identification, "fontdepth");
+insert (english identification, "nextlargerfont");
+insert (english identification, "nextsmallerfont");
+insert (english identification, "fontstring");
+insert (english identification, "yoffsets");
+insert (english identification, "boldoffset");
+
+insert (german identification, "xeinheit");
+insert (german identification, "yeinheit");
+insert (german identification, "onsequenz");
+insert (german identification, "offsequenz");
+insert (german identification, "einrueckbreite");
+insert (german identification, "durchschuss");
+insert (german identification, "fonthoehe");
+insert (german identification, "fonttiefe");
+insert (german identification, "groessererfont");
+insert (german identification, "kleinererfont");
+insert (german identification, "fontsequenz");
+insert (german identification, "yverschiebungen");
+insert (german identification, "boldverschiebung");
+
+INT VAR modus, last modus, symbol type, int symbol, pitch,
+ identification nr, link nr, extension code 1,
+ char code 1, char code, char pos, vorzeichen,
+ replacements length, index;
+TEXT VAR symbol, font table name, replacement, char, buffer, z;
+BOOL VAR english;
+FILE VAR file, font file;
+
+(*****************************************************************)
+
+LET max fonts = 50,
+ max extensions = 120,
+ font table type = 3009,
+
+ FONTTABLE = STRUCT (
+
+ THESAURUS font names,
+
+ TEXT replacements, font name links,
+ extension chars, extension indexes,
+
+ ROW 4 TEXT on strings, off strings,
+
+ REAL x unit, y unit,
+
+ ROW 256 INT replacements table,
+
+ INT last font, last extension
+
+ ROW max fonts STRUCT (
+ TEXT font string, font name indexes, replacements,
+ extension chars, extension indexes, y offsets,
+ ROW 256 INT pitch table, replacements table,
+ INT indentation pitch, font lead, font height, font depth,
+ next larger font, next smaller font, bold offset ) fonts ,
+
+ ROW max extensions STRUCT (
+ TEXT replacements,
+ ROW 256 INT pitch table, replacements table,
+ INT std pitch ) extensions ,
+
+ );
+
+BOUND FONTTABLE VAR font table;
+
+DATASPACE VAR ds;
+
+INT VAR font nr, extension nr;
+
+. font : font table. fonts (font nr)
+. extension : font table. extensions (extension nr)
+. line nr : line no (file) - 1
+.;
+
+(*****************************************************************)
+
+
+PROC create font table :
+
+ create font table (last param)
+
+END PROC create font table;
+
+
+PROC create font table (TEXT CONST font file) :
+
+file := sequential file (input, font file);
+disable stop;
+ds := nilspace;
+modus := nil modus;
+load;
+IF is error THEN error (errormessage) FI;
+forget (ds);
+
+END PROC create font table;
+
+
+PROC add fonts (TEXT CONST font tab name, font file) :
+
+file := sequential file (input, font file);
+font table name := font tab name;
+change all (font table name, " ", "");
+IF NOT exists (font table name) COR type (old (font table name)) <> font table type
+ THEN errorstop ("Fonttabelle """ + font table name + """ gibt es nicht")
+FI;
+disable stop;
+ds := old (font table name);
+fonttable := ds;
+modus := font modus;
+font nr := fonttable. last font;
+extension nr := fonttable. last extension;
+load;
+IF is error THEN error (errormessage) FI;
+forget (ds);
+
+END PROC add fonts;
+
+
+PROC load :
+
+enable stop;
+initialize loading;
+REP get kennung;
+ get identification;
+ get char specifications;
+UNTIL eof (file) OR symbol type = t end of file PER;
+font table found;
+
+. initialize loading :
+ scan (file);
+ get next symbol;
+
+. font table found :
+ IF font nr = 0
+ THEN errorstop ("Fonts zur Fonttabelle """
+ + font table name + """ fehlen");
+ ELSE font table. last font := font nr;
+ font table. last extension := extension nr;
+ forget (font table name, quiet);
+ copy (ds, font table name);
+ type (old (font table name), font table type);
+ forget (ds); ds := nilspace;
+ FI;
+
+. get next symbol :
+ next symbol (file, symbol, symbol type);
+
+. get semicolon :
+ get next symbol;
+ IF symbol <> ";" OR symbol type <> t delimiter
+ THEN errorstop ("';' erwartet") FI;
+
+.
+ get kennung :
+ cout (line nr);
+ IF symbol type <> t bold
+ THEN errorstop ("Kennung erwartet") FI;
+ IF symbol = "FONTTABLE" OR symbol = "FONTTABELLE"
+ THEN initialize font table;
+ get font table name;
+ ELIF symbol = "FONT"
+ THEN initialize font;
+ get font names;
+ ELIF symbol = "EXTENSION" OR symbol = "ERWEITERUNG"
+ THEN get extension char;
+ initialize extension;
+ ELIF modus = nil modus
+ THEN errorstop ("Kennung 'FONTTABLE' oder 'FONTTABELLE' zu Beginn der Datei erwartet")
+ ELSE errorstop ("unzulaessige Kennung")
+ FI;
+
+ . initialize font table :
+ IF modus <> nil modus THEN font table found FI;
+ modus := font table modus;
+ font nr := 0;
+ extension nr := 0;
+ font table := ds;
+ font table. font names := empty thesaurus;
+ font table. replacements := "";
+ font table. font name links := "";
+ font table. extension chars := "";
+ font table. extension indexes := "";
+ font table. x unit := 10.0/2.54;
+ font table. y unit := 6.0/2.54;
+ font table. replacements table := 0;
+ FOR index FROM 1 UPTO 4
+ REP font table. on strings (index) := "";
+ font table. off strings (index) := "";
+ PER;
+
+ . get font table name :
+ get name list;
+ symbol type := t text;
+ symbol := name (names, 1);
+ IF exists (symbol)
+ THEN forget (symbol);
+ IF exists (symbol)
+ THEN errorstop ("Fonttabelle existiert schon") FI;
+ FI;
+ font table name := symbol;
+
+ . initialize font :
+ IF font nr = max fonts
+ THEN errorstop ("zu viele Fonts") FI;
+ font nr INCR 1;
+ modus := font modus;
+ replacements length := LENGTH font table. replacements;
+ font. font string := "";
+ font. font name indexes := "";
+ font. replacements := "";
+ font. extension chars := "";
+ font. extension indexes := "";
+ font. y offsets := ""0""0"";
+ font. indentation pitch := int (font table. x unit * 2.54 / 10.0);
+ font. font lead := 0;
+ font. font height := int (font table. y unit * 2.54 / 6.0);
+ font. font depth := 0;
+ font. next larger font := 0;
+ font. next smaller font := 0;
+ font. bold offset := 0;
+ font. pitch table := font. indentation pitch;
+ font. replacements table := font table. replacements table;
+ FOR index FROM 1 UPTO LENGTH font table. extension chars
+ REP font. replacements table
+ ( code (font table. extension chars SUB index) + 1 ) := maxint;
+ PER;
+
+ . get font names :
+ get name list;
+ index := 0;
+ symbol type := t text;
+ WHILE next font name
+ REP link nr := link (font table. font names, symbol);
+ IF link nr = 0
+ THEN insert (font table. font names, symbol, link nr);
+ font table. font name links CAT font nr;
+ ELIF (font table. font name links ISUB link nr) = 0
+ THEN replace (font table. font name links, link nr, font nr);
+ ELSE errorstop ("Font existiert in Fonttabelle """
+ + font table name + """ schon")
+ FI;
+ font. font name indexes CAT link nr;
+ PER;
+
+ . next font name :
+ get (names, symbol, index);
+ symbol <> ""
+
+ . get extension char :
+ get name list;
+ symbol type := t text;
+ symbol := name (names, 1);
+ IF LENGTH symbol <> 1
+ THEN errorstop ("nur ein Zeichen bei Erweiterung erlaubt") FI;
+ extension code 1 := code (symbol) + 1;
+ IF NOT is kanji esc (symbol)
+ THEN errorstop ("ESC-Zeichen erwartet") FI;
+
+ . initialize extension :
+ IF NOT two bytes
+ THEN errorstop ("Erweiterungen nur im zwei-Byte-Modus erlaubt") FI;
+ IF extension nr = max extensions
+ THEN errorstop ("zu viele Erweiterungen") FI;
+ extension nr INCR 1;
+ IF modus <> extension modus THEN last modus := modus FI;
+ modus := extension modus;
+ IF last modus = font table modus
+ THEN initalize font table extension
+ ELSE initalize font extension
+ FI;
+
+ . initalize font table extension :
+ IF pos (font table. extension chars, symbol) <> 0
+ THEN errorstop ("Erweiterung wurde schon definiert") FI;
+ extension. replacements := "";
+ extension. std pitch := 0;
+ extension. pitch table := 0;
+ extension. replacements table := 0;
+ font table. extension chars CAT symbol;
+ font table. extension indexes CAT extension nr;
+ font table. replacements table (extension code 1) := max int;
+ replacements length := 0;
+
+ . initalize font extension :
+ IF pos (font. extension chars, symbol) <> 0
+ THEN errorstop ("Erweiterung wurde schon definiert") FI;
+ extension. replacements := "";
+ extension. std pitch := font. pitch table (extension code 1) XOR (-maxint-1);
+ extension. pitch table := extension. std pitch;
+ font. extension chars CAT symbol;
+ font. extension indexes CAT extension nr;
+ char pos := pos (font table. extension chars, symbol);
+ IF char pos <> 0
+ THEN index := font table. extension indexes ISUB char pos;
+ extension. replacements table :=
+ font table. extensions (index). replacements table;
+ replacements length :=
+ LENGTH font table. extensions (index). replacements;
+ font. replacements table (extension code 1) := max int;
+ ELSE extension. replacements table := 0;
+ replacements length := 0;
+ FI;
+
+.
+ get identification :
+ WHILE identification found
+ REP cout (line nr);
+ determine identification link nr;
+ select identification;
+ PER;
+
+ . identification found :
+ get next symbol;
+ symbol type = t tag
+
+ . determine identification link nr :
+ identification nr := link (english identification, symbol);
+ english := TRUE;
+ IF identification nr = 0
+ THEN identification nr := link (german identification, symbol);
+ english := FALSE;
+ IF identification nr = 0
+ THEN errorstop ("unzulaesige Identifikation") FI;
+ FI;
+
+ . select identification :
+ get next symbol;
+ IF symbol <> "=" OR symbol type <> t operator
+ THEN errorstop ("'=' nach Identifikation fehlt") FI;
+ get next symbol;
+ SELECT identification nr OF
+ CASE x unit : x unit found
+ CASE y unit : y unit found
+ CASE on string : on string found
+ CASE off string : off string found
+ CASE indentation pitch : indentation pitch found
+ CASE font lead : font lead found
+ CASE font height : font height found
+ CASE font depth : font depth found
+ CASE larger font : larger font found
+ CASE smaller font : smaller font found
+ CASE font string : font string found
+ CASE y offsets : y offsets found
+ CASE bold offset : bold offset found
+ END SELECT;
+
+ . x unit found :
+ check modus (font table modus);
+ font table. x unit := real (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("REAL-Denoter nach 'x unit' erwartet")
+ ELSE errorstop ("REAL-Denoter nach 'x einheit' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+ . y unit found :
+ check modus (font table modus);
+ font table. y unit := real (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("REAL-Denoter nach 'y unit' erwartet")
+ ELSE errorstop ("REAL-Denoter nach 'y einheit' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+ . on string found :
+ check modus (font table modus);
+ FOR index FROM 1 UPTO 4
+ REP IF symbol type <> t text
+ THEN IF english
+ THEN errorstop ("TEXT-Denoter nach 'on string' erwartet")
+ ELSE errorstop ("TEXT-Denoter nach 'on sequenz' erwartet")
+ FI;
+ FI;
+ font table. on strings (index) := symbol;
+ get next symbol;
+ IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter
+ THEN errorstop ("',' oder ';' in Liste erwartet") FI;
+ IF symbol = ";" THEN LEAVE on string found FI;
+ IF index = 4 THEN errorstop ("';' erwartet") FI;
+ get next symbol;
+ PER;
+
+ . off string found :
+ check modus (font table modus);
+ FOR index FROM 1 UPTO 4
+ REP IF symbol type <> t text
+ THEN IF english
+ THEN errorstop ("TEXT-Denoter nach 'off string' erwartet")
+ ELSE errorstop ("TEXT-Denoter nach 'off sequenz' erwartet")
+ FI;
+ FI;
+ font table. off strings (index) := symbol;
+ get next symbol;
+ IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter
+ THEN errorstop ("',' oder ';' in Liste erwartet") FI;
+ IF symbol = ";" THEN LEAVE off string found FI;
+ IF index = 4 THEN errorstop ("';' erwartet") FI;
+ get next symbol;
+ PER;
+
+ . indentation pitch found :
+ check modus (font modus);
+ font. indentation pitch := int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'indentation pitch' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'einrueckbreite' erwartet")
+ FI;
+ FI;
+ font. pitch table := font. indentation pitch;
+ get semicolon;
+
+ . font lead found :
+ check modus (font modus);
+ font. font lead := int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'font lead' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'durchschuss' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+ . font height found :
+ check modus (font modus);
+ font. font height := int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'font height' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'fonthoehe' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+ . font depth found :
+ check modus (font modus);
+ font. font depth := int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'font depth' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'fonttiefe' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+ . larger font found :
+ check modus (font modus);
+ IF symbol type <> t text
+ THEN IF english
+ THEN errorstop ("TEXT-Denoter nach 'next larger font' erwartet")
+ ELSE errorstop ("TEXT-Denoter nach 'groesserer font' erwartet")
+ FI;
+ FI;
+ determine link nr;
+ font. next larger font := link nr;
+ get semicolon;
+
+ . smaller font found :
+ check modus (font modus);
+ IF symbol type <> t text
+ THEN IF english
+ THEN errorstop ("TEXT-Denoter nach 'next smaller font' erwartet")
+ ELSE errorstop ("TEXT-Denoter nach 'kleinerer font' erwartet")
+ FI;
+ FI;
+ determine link nr;
+ font. next smaller font := link nr;
+ get semicolon;
+
+ . determine link nr :
+ change all (symbol, " ", "");
+ IF symbol = ""
+ THEN link nr := 0
+ ELSE link nr := link (font table. font names, symbol);
+ IF link nr = 0
+ THEN insert (font table. font names, symbol, link nr);
+ font table. font name links CAT 0;
+ FI;
+ FI;
+
+ . font string found :
+ check modus (font modus);
+ IF symbol type <> t text
+ THEN IF english
+ THEN errorstop ("TEXT-Denoter nach 'font string' erwartet")
+ ELSE errorstop ("TEXT-Denoter nach 'fontsequenz' erwartet")
+ FI;
+ FI;
+ font. font string := symbol;
+ get semicolon;
+
+ . y offsets found :
+ check modus (font modus);
+ font. y offsets := "";
+ REP IF symbol = "-" AND symbol type = t operator
+ THEN vorzeichen := -1;
+ get next symbol;
+ ELSE vorzeichen := 1;
+ FI;
+ int symbol := vorzeichen * int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'y offsets' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'y verschiebungen' erwartet")
+ FI;
+ FI;
+ font. y offsets CAT int symbol;
+ get next symbol;
+ IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter
+ THEN errorstop ("',' oder ';' in Liste erwartet") FI;
+ IF symbol = ";" THEN LEAVE y offsets found FI;
+ get next symbol;
+ PER;
+
+ . bold offset found :
+ check modus (font modus);
+ IF symbol = "-" AND symbol type = t operator
+ THEN vorzeichen := -1;
+ get next symbol;
+ ELSE vorzeichen := 1;
+ FI;
+ font. bold offset := vorzeichen * int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'bold offset' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'bold verschiebungen' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+.
+ get char specifications :
+ WHILE char found
+ REP cout (line nr);
+ char specification;
+ get next symbol;
+ PER;
+
+ . char found :
+ symbol type = t text
+
+ . char specification :
+ IF LENGTH symbol <> 1
+ THEN errorstop ("nur ein Zeichen bei Zeichenangabe erlaubt") FI;
+ char := symbol;
+ char code 1 := code (char) + 1;
+ look for specification;
+ look for specification;
+ get semicolon;
+
+ . look for specification :
+ get next symbol;
+ IF symbol = ";" AND symbol type = t delimiter
+ THEN LEAVE char specification
+ ELIF symbol = "," AND symbol type = t delimiter
+ THEN get specification
+ ELSE errorstop ("',' oder ';' bei Zeichenspezifikation erwartet")
+ FI;
+
+ . get specification :
+ get next symbol;
+ IF symbol type = t number
+ THEN pitch specification;
+ ELIF symbol type = t text
+ THEN replacement specification
+ ELSE errorstop ("unzulaessiger Wert bei Zeichenspezifikation")
+ FI;
+
+ . pitch specification :
+ int symbol := int (symbol);
+ IF NOT last conversion ok
+ THEN errorstop ("INT-Denoter bei Breitenangabe erwartet") FI;
+ IF modus = font modus
+ THEN font. pitch table (char code 1) := int symbol;
+ IF is kanji esc (char)
+ THEN set bit (font. pitch table (char code 1), 15) FI;
+ ELIF modus = extension modus
+ THEN IF last modus = font modus AND
+ font. pitch table (extension code 1) <> max int
+ THEN font. pitch table (extension code 1) := max int FI;
+ extension. pitch table (char code 1) := int symbol;
+ FI;
+
+ . replacement specification :
+ IF LENGTH symbol > 255
+ THEN errorstop ("Ersatzdarstellungen duerfen nur 255 Zeichen haben") FI;
+ IF modus = font table modus
+ THEN font table. replacements table (char code 1) :=
+ (LENGTH font table. replacements + 1);
+ font table. replacements CAT code (LENGTH symbol);
+ font table. replacements CAT symbol;
+ IF is kanji esc (char)
+ THEN set bit (font table. replacements table (char code 1), 15) FI;
+ ELIF modus = font modus
+ THEN font. replacements table (char code 1) :=
+ (replacements length + LENGTH font. replacements + 1);
+ font. replacements CAT code (LENGTH symbol);
+ font. replacements CAT symbol;
+ IF is kanji esc (char)
+ THEN set bit (font. replacements table (char code 1), 15) FI;
+ ELIF modus = extension modus
+ THEN IF last modus = font modus AND
+ font. replacements table (extension code 1) <> max int
+ THEN font. replacements table (extension code 1) := max int FI;
+ extension. replacements table (char code 1) :=
+ (replacements length + LENGTH extension. replacements + 1);
+ extension. replacements CAT code (LENGTH symbol);
+ extension. replacements CAT symbol;
+ FI;
+
+END PROC load;
+
+
+PROC get name list :
+
+ names := empty thesaurus;
+ get next symbol;
+ IF symbol <> ":" OR symbol type <> t delimiter
+ THEN errorstop ("':' nach Kennung erwartet") FI;
+ REP get next symbol;
+ change all (symbol, " ", "");
+ IF symbol type <> t text
+ THEN errorstop ("TEXT-Denoter in Namesliste erwartet") FI;
+ IF symbol = ""
+ THEN errorstop ("'niltext' als Name nicht erlaubt") FI;
+ insert (names, symbol);
+ get next symbol;
+ IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter
+ THEN errorstop ("',' oder ';' in Liste erwartet") FI;
+ UNTIL symbol = ";" PER;
+
+ . get next symbol :
+ next symbol (file, symbol, symbol type);
+
+END PROC get name list;
+
+
+OP := (ROW 256 INT VAR l, INT CONST r) :
+
+INT VAR i;
+IF modus = extension modus OR NOT two bytes
+ THEN FOR i FROM 1 UPTO 256 REP l (i) := r PER;
+ ELSE FOR i FROM 1 UPTO 129 REP l (i) := r PER;
+ FOR i FROM 130 UPTO 160 REP l (i) := r - maxint - 1 PER;
+ FOR i FROM 161 UPTO 224 REP l (i) := r PER;
+ FOR i FROM 225 UPTO 240 REP l (i) := r - maxint - 1 PER;
+ FOR i FROM 241 UPTO 256 REP l (i) := r PER;
+FI;
+
+END OP :=;
+
+
+PROC check modus (INT CONST mod) :
+
+ IF mod <> modus THEN errorstop ("unzulaessige Identifikation") FI;
+
+END PROC check modus;
+
+
+PROC error (TEXT CONST message) :
+
+(*INT CONST l := error line;*)
+ clear error;
+ errorstop ("Zeile " + text (line nr) + " bei " + letztes symbol +
+ " : " + message (* + errorline if neccessary *) );
+
+ . letztes symbol :
+ IF symbol type <> t text
+ THEN symbol
+ ELSE decode (symbol);
+ """" + symbol + """"
+ FI
+(*
+ . errorline if neccessary :
+ IF l = 0
+ THEN ""
+ ELSE " -> " + text (l)
+ FI
+*)
+END PROC error;
+
+
+(*******************************************************************)
+
+
+PROC create font file (TEXT CONST font table name, font file name) :
+
+enable stop;
+connect font table;
+put font table in font file;
+
+.
+ connect font table :
+ buffer := font table name;
+ change all (buffer, " ", "");
+ IF NOT exists (buffer) COR type (old (buffer)) <> font table type
+ THEN errorstop ("Fonttabelle """ + buffer + """ gibt es nicht")
+ FI;
+ font table := old (buffer);
+
+.
+ put font table in font file :
+ enable stop;
+ font file := sequential file (output, font file name);
+ z := " ";
+ max line length (font file, 1000);
+ put font table;
+ FOR font nr FROM 1 UPTO font table. last font REP put font PER;
+
+. put font table :
+ z CAT "FONTTABLE : """; z CAT buffer; z CAT """;"; put z;
+ z CAT " x unit = "; z CAT text (font table. x unit); z CAT ";"; put z;
+ z CAT " y unit = "; z CAT text (font table. y unit); z CAT ";"; put z;
+ z CAT " on string = """; z cat on strings; z CAT """;"; put z;
+ z CAT " off string = """; z cat off strings; z CAT """;"; put z;
+ put font table replacements;
+ put font table extensions;
+ put z;
+
+ . z cat on strings :
+ FOR index FROM 1 UPTO 4
+ REP buffer := font table. on strings (index);
+ decode (buffer);
+ z CAT buffer;
+ IF index <> 4 THEN z CAT """, """ FI;
+ PER;
+
+ . z cat off strings :
+ FOR index FROM 1 UPTO 4
+ REP buffer := font table. off strings (index);
+ decode (buffer);
+ z CAT buffer;
+ IF index <> 4 THEN z CAT """, """ FI;
+ PER;
+
+ . put font table replacements :
+ put z;
+ FOR char code FROM 0 UPTO 255
+ REP char code 1 := char code + 1;
+ link nr := font table. replacements table (char code 1);
+ reset bit (link nr, 15);
+ IF link nr > 0 AND link nr <> maxint
+ THEN z CAT " ";
+ put char code;
+ put font table replacement;
+ put z;
+ FI;
+ PER;
+
+ . put font table replacement :
+ replacement := subtext (font table. replacements, link nr + 1,
+ link nr + code (font table. replacements SUB link nr) );
+ put replacement;
+
+ . put font table extensions :
+ IF font table. extension chars <> ""
+ THEN FOR index FROM 1 UPTO LENGTH font table. extension chars
+ REP put font table extension PER;
+ FI;
+
+ . put font table extension :
+ put z;
+ z CAT " EXTENSION : """"";
+ z CAT text 3 (code (font table. extension chars SUB index));
+ z CAT """"";";
+ put z; put z;
+ replacements length := 0;
+ extension nr := font table. extension indexes ISUB index;
+ FOR char code FROM 0 UPTO 255
+ REP char code 1 := char code + 1;
+ link nr := extension. replacements table (char code 1);
+ IF link nr > 0
+ THEN z CAT " ";
+ put char code;
+ put extension replacement;
+ put z;
+ FI;
+ PER;
+
+. put font :
+ put z;
+ z CAT " FONT : "; z cat font names; z CAT ";"; put z;
+ z CAT " indentation pitch = ";
+ z CAT text(font. indentation pitch);
+ z CAT ";"; put z;
+ IF font. font lead <> 0
+ THEN z CAT " font lead = ";
+ z CAT text(font. font lead);
+ z CAT ";"; put z;
+ FI;
+ z CAT " font height = ";
+ z CAT text(font. font height);
+ z CAT ";"; put z;
+ IF font. font depth <> 0
+ THEN z CAT " font depth = ";
+ z CAT text(font. font depth);
+ z CAT ";"; put z;
+ FI;
+ IF next larger <> ""
+ THEN z CAT " next larger font = """;
+ z CAT next larger;
+ z CAT """;"; put z;
+ FI;
+ IF next smaller <> ""
+ THEN z CAT " next smaller font = """;
+ z CAT next smaller;
+ z CAT """;"; put z;
+ FI;
+ IF font. font string <> ""
+ THEN z CAT " font string = """;
+ z CAT font string;
+ z CAT """;"; put z;
+ FI;
+ IF (font. y offsets ISUB 1) <> 0 OR LENGTH font. y offsets > 2
+ THEN z CAT " y offsets = ";
+ z cat y offsets;
+ z CAT ";"; put z;
+ FI;
+ IF font. bold offset <> 0
+ THEN z CAT " bold offset = ";
+ z CAT text(font. bold offset);
+ z CAT ";"; put z;
+ FI;
+ put font pitches and replacements;
+ put font extensions;
+
+ . next larger : name (font table. font names, font. next larger font)
+ . next smaller : name (font table. font names, font. next smaller font)
+ . font string : buffer := font. font string; decode (buffer); buffer
+
+ . z cat font names :
+ z CAT """";
+ z CAT name (font table. font names, font. font name indexes ISUB 1);
+ z CAT """";
+ FOR index FROM 2 UPTO LENGTH font. font name indexes DIV 2
+ REP z CAT ", """;
+ z CAT name (font table. font names, font. font name indexes ISUB index);
+ z CAT """";
+ PER;
+
+ . z cat y offsets :
+ z CAT text (font. y offsets ISUB 1);
+ FOR index FROM 2 UPTO LENGTH font. y offsets DIV 2
+ REP z CAT ", ";
+ z CAT text (font. y offsets ISUB index);
+ PER;
+
+ . put font pitches and replacements :
+ BOOL VAR ausgabe := FALSE;
+ replacements length := LENGTH font table. replacements;
+ put z;
+ z CAT " ";
+ FOR char code FROM 0 UPTO 255
+ REP char code 1 := char code + 1;
+ pitch := font. pitch table (char code 1);
+ reset bit (pitch, 15);
+ link nr := font. replacements table (char code 1);
+ reset bit (link nr, 15);
+ IF (pitch <> font. indentation pitch) OR
+ (link nr > replacements length AND link nr <> maxint)
+ THEN put font char pitch and replacement;
+ IF ausgabe
+ THEN put z;
+ ausgabe := FALSE;
+ ELSE ausgabe := TRUE;
+ FI;
+ z CAT " ";
+ FI;
+ PER;
+ IF ausgabe THEN put z ELSE z := " " FI;
+
+ . put font char pitch and replacement :
+ put char code;
+ put font char pitch;
+ IF link nr > replacements length AND link nr <> maxint
+ THEN put font replacement;
+ IF NOT ausgabe THEN z CAT (6 - LENGTH replacement) * " " FI;
+ ELIF ausgabe
+ THEN z CAT ";"
+ ELSE z CAT "; ";
+ FI;
+
+ . put font char pitch :
+ IF pitch = max int
+ THEN char pos := pos (font. extension chars, code (char code));
+ IF char pos <> 0
+ THEN pitch := font table. extensions
+ (font. extension indexes ISUB char pos). std pitch
+ FI;
+ FI;
+ put char pitch;
+
+ . put font replacement :
+ link nr DECR replacements length;
+ replacement := subtext (font. replacements, link nr + 1,
+ link nr + code (font. replacements SUB link nr) );
+ put replacement;
+
+ . put font extensions :
+ IF font. extension chars <> ""
+ THEN FOR index FROM 1 UPTO LENGTH font. extension chars
+ REP put font extension PER;
+ FI;
+
+ . put font extension :
+ put z;
+ z CAT " ERWEITERUNG : """"";
+ z CAT text 3 (code (font. extension chars SUB index));
+ z CAT """"";";
+ put z; put z; z CAT " ";
+ detemine replacements length;
+ extension nr := font. extension indexes ISUB index;
+ ausgabe := FALSE;
+ FOR char code FROM 0 UPTO 255
+ REP char code 1 := char code + 1;
+ pitch := extension. pitch table (char code 1);
+ link nr := extension. replacements table (char code 1);
+ IF pitch <> extension. std pitch OR link nr > replacements length
+ THEN put extension char pitch and replacement;
+ IF ausgabe
+ THEN put z;
+ ausgabe := FALSE;
+ ELSE ausgabe := TRUE;
+ FI;
+ z CAT " ";
+ FI;
+ PER;
+ IF ausgabe THEN put z ELSE z := " " FI;
+
+ . detemine replacements length :
+ char pos := pos (font table. extension chars,
+ font. extension chars SUB index);
+ IF char pos <> 0
+ THEN replacements length := LENGTH font table. extensions
+ (font table. extension indexes ISUB char pos). replacements;
+ ELSE replacements length := 0;
+ FI;
+
+ . put extension char pitch and replacement :
+ put char code;
+ put char pitch;
+ IF link nr > replacements length
+ THEN put extension replacement;
+ IF NOT ausgabe THEN z CAT (6 - LENGTH replacement) * " " FI;
+ ELIF ausgabe
+ THEN z CAT ";"
+ ELSE z CAT "; ";
+ FI;
+
+. put extension replacement :
+ link nr DECR replacements length;
+ replacement := subtext (extension. replacements, link nr + 1,
+ link nr + code (extension. replacements SUB link nr) );
+ put replacement;
+
+. put char code :
+ IF (char code >= 32 AND char code <= 122) OR
+ (char code >= 214 AND char code <= 223) OR
+ char code = 124 OR char code = 126 OR char code = 251
+ THEN z CAT "(* ";
+ z CAT code (char code);
+ z CAT " *) """"";
+ ELSE z CAT " """"";
+ FI;
+ z CAT text 3 (char code);
+ z CAT """""";
+
+. put char pitch :
+ z CAT ",";
+ z CAT text (pitch, 5);
+
+. put replacement :
+ decode (replacement);
+ z CAT ", """;
+ z CAT replacement;
+ z CAT """;"
+
+END PROC create font file;
+
+
+PROC put z :
+
+ putline (font file, z);
+ cout (lines (font file));
+ z := " ";
+
+END PROC put z;
+
+
+PROC decode (TEXT VAR string) :
+
+ INT VAR p;
+ change all (string, """", """""");
+ p := pos (string, ""0"", ""31"", 1);
+ WHILE p <> 0
+ REP change (string, p, p, """" + text (code(string SUB p)) + """");
+ p := pos (string, ""0"", ""31"", p);
+ PER;
+ p := pos (string, ""127"", ""255"", 1);
+ WHILE p <> 0
+ REP change (string, p, p, """" + text (code(string SUB p)) + """");
+ p := pos (string, ""127"", ""255"", p);
+ PER;
+
+END PROC decode;
+
+
+TEXT PROC text 3 (INT CONST value) :
+
+ buffer := text (value, 3);
+ change all (buffer, " ", "0");
+ buffer
+
+END PROC text 3;
+
+END PACKET font convertor;
|